naming of procedures improved and their line numbers match

parent cb306371
......@@ -3,7 +3,7 @@
#:use-module (ice-9 control)
#:use-module (oop pf-objects)
#:use-module (oop goops)
#:use-module ((oop dict) #:select (leveler))
#:use-module ((oop dict) #:select (slask-it))
#:use-module (system syntax internal)
#:use-module (rnrs bytevectors)
#:use-module (language python guilemod)
......@@ -47,53 +47,43 @@
(define-inlinable (H x) `(@ (language python hash) ,x))
(define-inlinable (W x) `(@ (language python with) ,x))
(define (NRR name n m f x)
(set-procedure-property! x 'source
`((filename . ,f) (line . ,n) (column . ,m)))
(set-procedure-property! x 'filename f)
(set-procedure-property! x 'line n)
(set-procedure-property! x 'column m)
(if name (set-procedure-property! x 'name name))
x)
(cond-expand
(guile-2.2
(define (set-position stx line col)
(let ((r (syntax-expression stx)))
(pk 1 line col (source-properties r))
(set-source-property! r 'line line)
(set-source-property! r 'column col)
(pk 2 line col (source-properties r))
stx))
(define-syntax NR
(lambda (x)
(syntax-case x ()
((_ line col stx)
#t
(begin
(set-position #'stx (syntax->datum #'col) (syntax->datum #'line))
#'stx))))))
(guile-2.2
(define-syntax NR
(lambda (x)
(syntax-case x ()
((_ name n m y)
(let* ((xx (if (syntax? x) (syntax-expression x) #f))
(yy (if xx (source-properties xx) #f)))
#`(NRR name n m
#,(if yy (aif it (assoc 'filename yy) (cdr it) #f) #f)
y)))))))
(guile-2.0
(define-syntax NR
(lambda (x)
(syntax-case x ()
((_ line col stx)
#t
#'stx))))))
(guile-2.0
(define-syntax NR
(lambda (x)
(syntax-case x ()
((_ name line col stx)
#t
#'stx))))))
(define (get-pos y)
(aif it (object-property y 'position)
`(,(car it) ,(cdr it))
(list 0 0)))
(define (pos x y)
(if (vector? x)
(let ((x (vector-ref x 0)))
(if (pair? x)
(aif it (object-property y 'position)
`(,(C 'NR) ,(car it) ,(cdr it) ,x)
x)
x))
x))
(cond-expand
(guile-3.0
(define (not-inline x) (leveler x)))
(define (not-inline x) (slask-it x)))
(guile-2.0
(define-syntax not-inline (syntax-rules () ((_ x) x)))))
......@@ -1278,7 +1268,6 @@ empty list."
(#:classdef
((_ class parents code)
(vector
(with-fluids ((is-class? (exp vs class)))
(let ()
(define (clean l)
......@@ -1316,7 +1305,7 @@ empty list."
`(,(G 'cons) (,(G 'quote) ()) (,(G 'quote) ())))
,doc
,(map (lambda (x) `(define ,x ,(gw-persson x vo))) ls)
,cd))))))))))
,cd)))))))))
(#:verb
((_ x) x))
......@@ -1829,7 +1818,6 @@ empty list."
(#:types-args-list . args)
#f
code)
(vector
(let* ((decor (let ((r (fluid-ref decorations)))
(fluid-set! decorations '())
r))
......@@ -1861,8 +1849,9 @@ empty list."
(cd (car cd.doc))
(doc (cdr cd.doc))
(docv (gensym "fv"))
(docer (lambda (x) `(,(G 'let) ((,docv ,x))
(,(C 'set) ,docv (,(G 'quote) __doc__) ,doc)
(docer (lambda (x) `(,(G 'let) ((,docv ,x))
(,(C 'set) ,docv (,(G 'quote) __doc__)
,doc)
,docv))))
(define (mk code)
`(let-syntax ((,y (syntax-rules ()
......@@ -1876,43 +1865,55 @@ empty list."
(if c?
(if y?
`(set! ,f
(,(C 'NR) (,(G 'quote) ,f) ,N ,M
,(docer
`(,(C 'def-decor) ,decor ,N ,M
(,(C 'def-wrap) ,y? ,f ,ab ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,cd)))))))))
`(,(C 'def-decor) ,decor
(,(C 'def-wrap) ,y? ,f ,ab
(,(C 'not-inline)
(,(C 'NR) (,(G 'quote) ,f) ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,cd))))))))))))
`(set! ,f
,(docer
`(,(C 'def-decor) ,decor ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,cd)))))))))
(,(C 'NR) (,(G 'quote) ,f) ,N ,M
,(docer
`(,(C 'def-decor) ,decor
(,(C 'not-inline)
(,(C 'NR) (,(G 'quote) ,f) ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,cd))))))))))))
(if y?
`(set! ,f
,(docer
`(,(C 'def-decor) ,decor ,N ,M
(,(C 'def-wrap) ,y? ,f ,ab ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(mk cd)))))))))
(,(C 'NR) ',f ,N ,M
,(docer
`(,(C 'def-decor) ,decor
(,(C 'def-wrap) ,y? (,(G 'quote) ,f) ,ab
(,(C 'not-inline)
(,(C 'NR) (,(G 'quote) ,f) ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(mk cd))))))))))))
`(set! ,f
,(docer
`(,(C 'def-decor) ,decor ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(mk cd))))))))))))))
(,(C 'NR) (,(G 'quote) ,f) ,N ,M
,(docer
`(,(C 'def-decor) ,decor
(,(C 'not-inline)
(,(C 'NR) (,(G 'quote) ,f) ,N ,M
(,(D 'lam) ,aa
(,(C 'with-return) ,r
(,(G 'let) ,(map (lambda (x) (list x #f)) ls)
(,(C 'with-self) ,c? ,aa
,(mk cd))))))))))))))))
(#:global
((_ . _)
`(,cvalues)))
......@@ -1959,16 +1960,14 @@ empty list."
(#:lambdef
((_ (#:var-args-list . v) e)
(vector
(let ((as (get-args_ vs v))
(a= (get-args= vs v))
(a* (get-args* vs v))
(** (get-args** vs v)))
(list (C `lam) `(,@as ,@a* ,@a= ,@**) (exp vs e)))))
(list (C `lam) `(,@as ,@a* ,@a= ,@**) (exp vs e))))
((_ () e)
(vector
(list (C `lam) `() (exp vs e)))))
(list (C `lam) `() (exp vs e))))
(#:stmt
((_ l)
......@@ -2183,13 +2182,12 @@ empty list."
((tag . l)
(let ((ll (get-pos x)))
(pos
(apply (hash-ref tagis tag
(lambda y
(warn (format #f "not tag in tagis ~a" tag)) x))
(apply (hash-ref tagis tag
(lambda y
(warn (format #f "not tag in tagis ~a" tag)) x))
x vs ll)
x)))
x vs ll)))
(#:True #t)
(#:None (E 'None))
......@@ -2975,12 +2973,11 @@ empty list."
(define-syntax def-wrap
(lambda (x)
(syntax-case x ()
((_ #f f ab n m x)
#'(NR n m x))
((_ #f f ab x)
#'x)
((_ #t f ab n m code)
#'(NR n m
(lambda x
((_ #t f ab code)
#'(lambda x
(define obj (make <yield>))
(define ab (make-prompt-tag))
(slot-set! obj 'k #f)
......@@ -3006,7 +3003,7 @@ empty list."
lam)))
(apply values l))))
lam))))
obj))))))
obj)))))
(define miss (list 'miss))
(define-inlinable (wr o k x)
......@@ -3116,9 +3113,9 @@ empty list."
(define-syntax def-decor
(syntax-rules ()
((_ () n m x) (NR n m x))
((_ (f ... r) n m y)
(def-decor (f ...) n m (r y)))))
((_ () x) x)
((_ (f ... r) y)
(def-decor (f ...) (r y)))))
(define-syntax with-self
(syntax-rules ()
......@@ -3280,3 +3277,4 @@ empty list."
(lambda (x)
(pk (syntax->datum x))
#f))
......@@ -10,6 +10,7 @@
(define e (list 'error))
(define-syntax-rule (aif it p x y) (let ((it p)) (if (not (eq? it e)) x y)))
(define (fold lam s l)
(if (pair? l)
(lam (car l) (fold lam s (cdr l)))
......@@ -75,7 +76,6 @@
(cons (cons #'k #'v) s) s s s )
(define (->kw x) (symbol->keyword (syntax->datum x)))
(syntax-case x (*)
((_ (arg ...) code ...)
(let* ((as (fold get-as '() #'(arg ...)))
......@@ -83,13 +83,12 @@
(ww- (fold get-ww '() #'(arg ...)))
(kv (fold get-kv '() #'(arg ...))))
(if (and-map null? (list kw ww- kv))
#`(object-method
(slask-it
(lambda (#,@as . u12345678)
(if (and (pair? u12345678)
(not (keyword? (car u12345678))))
(raise (ArgumentError "too many arguments to function")))
(let () code ...))))
#`(lambda (#,@as . u12345678)
(if (and (pair? u12345678)
(not (keyword? (car u12345678))))
(raise (ArgumentError
"too many arguments to function")))
(let () code ...))
(with-syntax ((kw (if (null? kw)
(datum->syntax x (gensym "kw"))
(car kw)))
......@@ -99,17 +98,15 @@
((k ...) (map car kv))
((s ...) (map ->kw (map car kv)))
((v ...) (map cdr kv)))
#`(object-method
#,(trstx x
#`(lambda* (#,@as . l)
(call-with-values (lambda () (get-akw l))
(lambda (ww* kw)
(let*-values (((ww* k) (take-1 #,(null? ww-) ww*
kw s v))
...)
(let ((ww ww*)
(kw (pytonize kw)))
(let () code ...)))))))))))))))
#`(lambda (#,@as . l)
(call-with-values (lambda () (get-akw l))
(lambda (ww* kw)
(let*-values (((ww* k) (take-1 #,(null? ww-) ww*
kw s v))
...)
(let ((ww ww*)
(kw (pytonize kw)))
(let () code ...)))))))))))))
(define-syntax-rule (def (f . args) code ...) (define f (lam args code ...)))
......
......@@ -42,9 +42,10 @@
(fluid-ref
%dont-warn-list)))))
(mk-commands (system base compile) mod-C define-C define-exp-C define-set-C)
(mk-commands (system base message) mod-M define-M define-exp-M define-set-M)
(mk-commands (guile) mod-G define-G define-exp-G define-set-G)
(mk-commands (system base compile) mod-C define-C define-exp-C define-set-C)
(mk-commands (system vm program) mod-C2 define-C2 define-exp-C2 define-set-C2)
(mk-commands (system base message) mod-M define-M define-exp-M define-set-M)
(mk-commands (guile) mod-G define-G define-exp-G define-set-G)
(define-syntax-rule (C x) (@@ (system base compile) x))
(define-syntax-rule (M x) (@@ (system base message) x))
......@@ -305,7 +306,8 @@ property alist) using the data in ARGS."
(M %warning-types))))
))
(define guile-load (@@ (guile) primitive-load-path))
(define guile-load (@@ (guile) primitive-load-path))
(define guile-load2 (@@ (guile) primitive-load))
(cond-expand
(guile-3.0
......@@ -358,34 +360,50 @@ property alist) using the data in ARGS."
(lambda (canon)
(and=> (fallback-file-name canon)
(lambda (go-file-name) go-file-name)))))
(define (docompile? name)
(let ((scmstat (stat name #f))
(gostat (stat (get-go name) #f)))
(let* ((scmstat (catch #t (lambda () (stat name #f)) (lambda x #f)))
(go (get-go name))
(gostat (catch #t (lambda () (stat go #f)) (lambda x #f))))
(if scmstat
(not
(and gostat scmstat (more-recent? gostat scmstat)))
(if (not
(and gostat scmstat (more-recent? gostat scmstat)))
go
#f)
#f)))
(define pload
(lambda (p . q)
#;(define (goit x)
(string-join
(let* ((r (string-split x #\/))
(rev (reverse r))
(c (string-append (car (string-split (car rev) #\.))
".go")))
(reverse (cons c (cdr rev))))
"/"))
(define (goit x) x)
(let ((tag (make-prompt-tag)))
(call-with-prompt
tag
(lambda ()
(let lp ((l *extension-dispatches*))
(if (pair? l)
(let lp2 ((u (caar l)))
(if (pair? u)
(aif it (%search-load-path
(string-append p "." (car u)))
(begin
(when (docompile? it)
((@ (system base compile) compile-file) it))
(apply guile-load it q))
(lp2 (cdr u)))
(lp (cdr l))))
(apply guile-load p q))))
(let ((q (list (lambda x (abort-to-prompt tag)))))
(let lp ((l *extension-dispatches*))
(if (pair? l)
(let lp2 ((u (caar l)))
(if (pair? u)
(aif it (%search-load-path
(string-append p "." (car u)))
(begin
(aif go (aif it (docompile? it) (goit it) #f)
(begin
(pk "Compile File " it "to .go" go)
((@ (system base compile) compile-file)
it #:output-file go)))
(apply guile-load (get-go it) q))
(lp2 (cdr u)))
(lp (cdr l))))
(apply guile-load p q)))))
(lambda (k)
(let lp ((l *extension-dispatches*))
(if (pair? l)
......@@ -393,9 +411,11 @@ property alist) using the data in ARGS."
(if (pair? u)
(aif it (%search-load-path
(string-append p "." (car u)))
(begin
((@ (system base compile) compile-file) it)
(apply guile-load it q))
(let ((go (goit (get-go it))))
(pk "Compile File " it "to go" go)
((@ (system base compile) compile-file)
it #:output-file go)
(apply guile-load go q))
(lp2 (cdr u)))
(lp (cdr l))))
(if (pair? q)
......@@ -426,3 +446,98 @@ property alist) using the data in ARGS."
(define-set-G primitive-load-path pload)
(define-syntax-rule (C2 m) (@@ (system vm program) m))
(cond-expand
(guile-3.0
(define (mk-source x)
(catch #t
(lambda ()
(cons* 0
(cdr (assoc 'filename x))
(- (cdr (assoc 'line x)) 1)
(cdr (assoc 'column x))))
(lambda x
#f)))
(define (source-for source)
(catch #t
(lambda ()
(cons* 0
((C2 source-file) source)
((C2 source-line) source)
((C2 source-column) source)))
(lambda x #f)))
(define* (print-program #:optional program (port (current-output-port))
#:key
(addr ((C2 program-code) program))
(always-print-addr? #f)
(never-print-addr? #f)
(always-print-source? #f)
(never-print-source? #f)
(name-only? #f)
(print-formals? #t))
(let* ((pdi ((C2 find-program-debug-info) addr))
;; It could be the procedure had its name property set via the
;; procedure property interface.
(name (or (and program (procedure-name program))
(and pdi ((C2 program-debug-info-name) pdi))))
(source (or (and program (mk-source
(procedure-property program 'source)))
(source-for
((C2 match) ((C2 find-program-sources) addr)
(() #f)
((source . _) source)))))
(formals (if program
((C2 program-arguments-alists) program)
(let ((arities ((C2 find-program-arities) addr)))
(if arities
(map (C2 arity-arguments-alist) arities)
'())))))
(define (hex n)
(number->string n 16))
(cond
((and name-only? name)
(format port "~a" name))
(else
(format port "#<procedure")
(format port " ~a"
(or name
(and program (hex (object-address program)))
(if never-print-addr?
""
(string-append "@" (hex addr)))))
(when (and always-print-addr? (not never-print-addr?))
(unless (and (not name) (not program))
(format port " @~a" (hex addr))))
(when (and source (not never-print-source?)
(or always-print-source? (not name)))
(format port " at ~a:~a:~a"
(or ((C2 source:file) source) "<unknown port>")
((C2 source:line-for-user) source)
((C2 source:column) source)))
(unless (or (null? formals) (not print-formals?))
(format port "~a"
(string-append
" " (string-join
(map (lambda (a)
((C2 object->string)
((C2 arguments-alist->lambda-list) a)))
formals)
" | "))))
(format port ">")))))
(define (write-program prog port)
(print-program prog port))
(define-set-C2 print-program print-program)
(define-set-C2 write-program write-program))
(guile-2.0
(values)))
def f(x):
g(x)
raise
pk(3,x)
def g(x):
if x:
raise
raise
pk(4,x)
def h(x):
x
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment