mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

psyntax: Functional annotation of function names

Browse source 
* module/ice-9/psyntax.scm (maybe-name-value): Return a fresh lambda
instead of mutating the given lambda.
(define-expansion-accessors): No need to define setters.
This commit is contained in:
Andy Wingo 2024-11-14 16:45:29 +01:00
parent f376e6445d
commit 8c78234e80
2 changed files with 100 additions and 106 deletions
Download patch file Download diff file Expand all files Collapse all files

108
module/ice-9/psyntax-pp.scm
View file

@ -43,8 +43,9 @@
(lambda (src in-order? names gensyms vals body) (lambda (src in-order? names gensyms vals body)
(make-struct/simple (vector-ref %expanded-vtables 17) src in-order? names gensyms vals body))) (make-struct/simple (vector-ref %expanded-vtables 17) src in-order? names gensyms vals body)))
(lambda? (lambda (x) (and (struct? x) (eq? (struct-vtable x) (vector-ref %expanded-vtables 14))))) (lambda? (lambda (x) (and (struct? x) (eq? (struct-vtable x) (vector-ref %expanded-vtables 14)))))
(lambda-src (lambda (x) (struct-ref x 0)))
(lambda-meta (lambda (x) (struct-ref x 1))) (lambda-meta (lambda (x) (struct-ref x 1)))
(set-lambda-meta! (lambda (x v) (struct-set! x 1 v))) (lambda-body (lambda (x) (struct-ref x 2)))
(top-level-eval (lambda (x mod) (primitive-eval x))) (top-level-eval (lambda (x mod) (primitive-eval x)))
(local-eval (lambda (x mod) (primitive-eval x))) (local-eval (lambda (x mod) (primitive-eval x)))
(sourcev-filename (lambda (s) (vector-ref s 0))) (sourcev-filename (lambda (s) (vector-ref s 0)))
@ -58,18 +59,19 @@
'filename 'filename
(sourcev-filename sourcev) (sourcev-filename sourcev)
(list (cons 'line (sourcev-line sourcev)) (cons 'column (sourcev-column sourcev)))))))) (list (cons 'line (sourcev-line sourcev)) (cons 'column (sourcev-column sourcev))))))))
(maybe-name-value! (maybe-name-value
(lambda (name val) (lambda (name val)
(if (lambda? val) (if (lambda? val)
(let ((meta (lambda-meta val))) (let ((meta (lambda-meta val)))
(if (not (assq 'name meta)) (set-lambda-meta! val (acons 'name name meta))))))) (if (assq 'name meta) val (make-lambda (lambda-src val) (acons 'name name meta) (lambda-body val))))
val)))
(build-void (lambda (sourcev) (make-void sourcev))) (build-void (lambda (sourcev) (make-void sourcev)))
(build-call (lambda (sourcev fun-exp arg-exps) (make-call sourcev fun-exp arg-exps))) (build-call (lambda (sourcev fun-exp arg-exps) (make-call sourcev fun-exp arg-exps)))
(build-conditional (build-conditional
(lambda (sourcev test-exp then-exp else-exp) (make-conditional sourcev test-exp then-exp else-exp))) (lambda (sourcev test-exp then-exp else-exp) (make-conditional sourcev test-exp then-exp else-exp)))
(build-lexical-reference (lambda (type sourcev name var) (make-lexical-ref sourcev name var))) (build-lexical-reference (lambda (type sourcev name var) (make-lexical-ref sourcev name var)))
(build-lexical-assignment (build-lexical-assignment
(lambda (sourcev name var exp) (maybe-name-value! name exp) (make-lexical-set sourcev name var exp))) (lambda (sourcev name var exp) (make-lexical-set sourcev name var (maybe-name-value name exp))))
(analyze-variable (analyze-variable
(lambda (mod var modref-cont bare-cont) (lambda (mod var modref-cont bare-cont)
(if (not mod) (if (not mod)
@ -92,16 +94,15 @@
(lambda (mod var) (make-toplevel-ref sourcev mod var))))) (lambda (mod var) (make-toplevel-ref sourcev mod var)))))
(build-global-assignment (build-global-assignment
(lambda (sourcev var exp mod) (lambda (sourcev var exp mod)
(maybe-name-value! var exp) (let ((exp (maybe-name-value var exp)))
(analyze-variable (analyze-variable
mod mod
var var
(lambda (mod var public?) (make-module-set sourcev mod var public? exp)) (lambda (mod var public?) (make-module-set sourcev mod var public? exp))
(lambda (mod var) (make-toplevel-set sourcev mod var exp))))) (lambda (mod var) (make-toplevel-set sourcev mod var exp))))))
(build-global-definition (build-global-definition
(lambda (sourcev mod var exp) (lambda (sourcev mod var exp)
(maybe-name-value! var exp) (make-toplevel-define sourcev (and mod (cdr mod)) var (maybe-name-value var exp))))
(make-toplevel-define sourcev (and mod (cdr mod)) var exp)))
(build-simple-lambda (build-simple-lambda
(lambda (src req rest vars meta exp) (lambda (src req rest vars meta exp)
(make-lambda src meta (make-lambda-case src req #f rest #f '() vars exp #f)))) (make-lambda src meta (make-lambda-case src req #f rest #f '() vars exp #f))))
@ -117,28 +118,24 @@
(if (null? (cdr exps)) (car exps) (make-seq src (car exps) (build-sequence #f (cdr exps)))))) (if (null? (cdr exps)) (car exps) (make-seq src (car exps) (build-sequence #f (cdr exps))))))
(build-let (build-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
(for-each maybe-name-value! ids val-exps) (let ((val-exps (map maybe-name-value ids val-exps)))
(if (null? vars) body-exp (make-let src ids vars val-exps body-exp)))) (if (null? vars) body-exp (make-let src ids vars val-exps body-exp)))))
(build-named-let (build-named-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
(let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids))) (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids)))
(let ((proc (build-simple-lambda src ids #f vars '() body-exp))) (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
(maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps)
(make-letrec (make-letrec
src src
#f #f
(list f-name) (list f-name)
(list f) (list f)
(list proc) (list (maybe-name-value f-name proc))
(build-call src (build-lexical-reference 'fun src f-name f) val-exps)))))) (build-call src (build-lexical-reference 'fun src f-name f) (map maybe-name-value ids val-exps)))))))
(build-letrec (build-letrec
(lambda (src in-order? ids vars val-exps body-exp) (lambda (src in-order? ids vars val-exps body-exp)
(if (null? vars) (if (null? vars)
body-exp body-exp
(begin (make-letrec src in-order? ids vars (map maybe-name-value ids val-exps) body-exp))))
(for-each maybe-name-value! ids val-exps)
(make-letrec src in-order? ids vars val-exps body-exp)))))
(gen-lexical (lambda (id) (module-gensym (symbol->string id)))) (gen-lexical (lambda (id) (module-gensym (symbol->string id))))
(datum-sourcev (datum-sourcev
(lambda (datum) (lambda (datum)
@ -798,11 +795,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-dac transformer-environment) (let* ((t-680b775fb37a463-db0 transformer-environment)
(t-680b775fb37a463-dad (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-db1 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-dac t-680b775fb37a463-db0
t-680b775fb37a463-dad t-680b775fb37a463-db1
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
(expand-body (expand-body
(lambda (body outer-form r w mod) (lambda (body outer-form r w mod)
@ -1332,11 +1329,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-2 (map (lambda (tmp-680b775fb37a463-102c
tmp-680b775fb37a463-1 tmp-680b775fb37a463-102b
tmp-680b775fb37a463) tmp-680b775fb37a463-102a)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-102a
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463-102b tmp-680b775fb37a463-102c)))
e2* e2*
e1* e1*
args*))) args*)))
@ -2446,11 +2443,8 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-115d (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-115f)
tmp-680b775fb37a463-115c (list (cons tmp-680b775fb37a463-115f tmp-680b775fb37a463) tmp-680b775fb37a463-1))
tmp-680b775fb37a463-115b)
(list (cons tmp-680b775fb37a463-115b tmp-680b775fb37a463-115c)
tmp-680b775fb37a463-115d))
template template
pattern pattern
keyword))) keyword)))
@ -2462,9 +2456,9 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-117a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-117a))
template template
pattern pattern
keyword))) keyword)))
@ -2639,9 +2633,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-124b)
(list "value" (list "value"
tmp-680b775fb37a463)) tmp-680b775fb37a463-124b))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2677,8 +2671,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-125d) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-125d)) (list "value" tmp-680b775fb37a463))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2781,8 +2775,8 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12ab) (apply (lambda (t-680b775fb37a463-12af)
(cons "vector" t-680b775fb37a463-12ab)) (cons "vector" t-680b775fb37a463-12af))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2792,8 +2786,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463-12b7) (k (map (lambda (tmp-680b775fb37a463-12bb)
(list "quote" tmp-680b775fb37a463-12b7)) (list "quote" tmp-680b775fb37a463-12bb))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@ -2804,8 +2798,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463-12c6 tmp)) (let ((t-680b775fb37a463-12ca tmp))
(list "list->vector" t-680b775fb37a463-12c6))))))))))))))))) (list "list->vector" t-680b775fb37a463-12ca)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -2817,9 +2811,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12d5) (apply (lambda (t-680b775fb37a463-12d9)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12d5)) t-680b775fb37a463-12d9))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2835,14 +2829,14 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12e9 (apply (lambda (t-680b775fb37a463-12ed
t-680b775fb37a463-12e8) t-680b775fb37a463-12ec)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-12e9 t-680b775fb37a463-12ed
t-680b775fb37a463-12e8)) t-680b775fb37a463-12ec))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2855,12 +2849,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-12f5) (apply (lambda (t-680b775fb37a463-12f9)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-12f5)) t-680b775fb37a463-12f9))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2889,12 +2883,12 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-130d tmp)) (let ((t-680b775fb37a463 tmp))
(list (make-syntax (list (make-syntax
'list->vector 'list->vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-130d)))) t-680b775fb37a463))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1 (if tmp-1

98
module/ice-9/psyntax.scm
View file

@ -100,29 +100,28 @@
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ stem field ...) ((_ stem field ...)
(let lp ((n 0)) (let ((stem (syntax->datum #'stem))
(let ((vtable (vector-ref %expanded-vtables n)) (fields (map syntax->datum #'(field ...))))
(stem (syntax->datum #'stem))) (let lp ((n 0))
(if (eq? (struct-ref vtable (+ vtable-offset-user 0)) stem) (let ((vtable (vector-ref %expanded-vtables n)))
#`(begin (if (eq? (struct-ref vtable (+ vtable-offset-user 0)) stem)
(define (#,(datum->syntax x (symbol-append stem '?)) x) (let ((pred (datum->syntax x (symbol-append stem '?)))
(and (struct? x) (all-fields (struct-ref vtable (+ vtable-offset-user 2))))
(eq? (struct-vtable x) #`(begin
(vector-ref %expanded-vtables #,n)))) (define (#,pred x)
#,@(map (and (struct? x)
(lambda (f) (eq? (struct-vtable x)
(let ((get (datum->syntax x (symbol-append stem '- f))) (vector-ref %expanded-vtables #,n))))
(set (datum->syntax x (symbol-append 'set- stem '- f '!))) #,@(map
(idx (list-index (struct-ref vtable (lambda (f)
(+ vtable-offset-user 2)) (define get
f))) (datum->syntax x (symbol-append stem '- f)))
#`(begin (define idx
(define (#,get x) (list-index all-fields f))
(struct-ref x #,idx)) #`(define (#,get x)
(define (#,set x v) (struct-ref x #,idx)))
(struct-set! x #,idx v))))) fields)))
(syntax->datum #'(field ...)))) (lp (1+ n))))))))))
(lp (1+ n)))))))))
(define-syntax define-structure (define-syntax define-structure
(lambda (x) (lambda (x)
@ -177,7 +176,7 @@
(let () (let ()
(define-expansion-constructors) (define-expansion-constructors)
(define-expansion-accessors lambda meta) (define-expansion-accessors lambda src meta body)
(define (top-level-eval x mod) (define (top-level-eval x mod)
(primitive-eval x)) (primitive-eval x))
@ -195,11 +194,15 @@
`((line . ,(sourcev-line sourcev)) `((line . ,(sourcev-line sourcev))
(column . ,(sourcev-column sourcev)))))) (column . ,(sourcev-column sourcev))))))
(define (maybe-name-value! name val) (define (maybe-name-value name val)
(if (lambda? val) (if (lambda? val)
(let ((meta (lambda-meta val))) (let ((meta (lambda-meta val)))
(if (not (assq 'name meta)) (if (assq 'name meta)
(set-lambda-meta! val (acons 'name name meta)))))) val
(make-lambda (lambda-src val)
(acons 'name name meta)
(lambda-body val))))
val))
;; output constructors ;; output constructors
(define build-void (define build-void
@ -220,8 +223,7 @@
(define build-lexical-assignment (define build-lexical-assignment
(lambda (sourcev name var exp) (lambda (sourcev name var exp)
(maybe-name-value! name exp) (make-lexical-set sourcev name var (maybe-name-value name exp))))
(make-lexical-set sourcev name var exp)))
(define (analyze-variable mod var modref-cont bare-cont) (define (analyze-variable mod var modref-cont bare-cont)
(if (not mod) (if (not mod)
@ -249,18 +251,18 @@
(define build-global-assignment (define build-global-assignment
(lambda (sourcev var exp mod) (lambda (sourcev var exp mod)
(maybe-name-value! var exp) (let ((exp (maybe-name-value var exp)))
(analyze-variable (analyze-variable
mod var mod var
(lambda (mod var public?) (lambda (mod var public?)
(make-module-set sourcev mod var public? exp)) (make-module-set sourcev mod var public? exp))
(lambda (mod var) (lambda (mod var)
(make-toplevel-set sourcev mod var exp))))) (make-toplevel-set sourcev mod var exp))))))
(define build-global-definition (define build-global-definition
(lambda (sourcev mod var exp) (lambda (sourcev mod var exp)
(maybe-name-value! var exp) (make-toplevel-define sourcev (and mod (cdr mod)) var
(make-toplevel-define sourcev (and mod (cdr mod)) var exp))) (maybe-name-value var exp))))
(define build-simple-lambda (define build-simple-lambda
(lambda (src req rest vars meta exp) (lambda (src req rest vars meta exp)
@ -308,10 +310,10 @@
(define build-let (define build-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
(for-each maybe-name-value! ids val-exps) (let ((val-exps (map maybe-name-value ids val-exps)))
(if (null? vars) (if (null? vars)
body-exp body-exp
(make-let src ids vars val-exps body-exp)))) (make-let src ids vars val-exps body-exp)))))
(define build-named-let (define build-named-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
@ -320,21 +322,19 @@
(vars (cdr vars)) (vars (cdr vars))
(ids (cdr ids))) (ids (cdr ids)))
(let ((proc (build-simple-lambda src ids #f vars '() body-exp))) (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
(maybe-name-value! f-name proc)
(for-each maybe-name-value! ids val-exps)
(make-letrec (make-letrec
src #f src #f
(list f-name) (list f) (list proc) (list f-name) (list f) (list (maybe-name-value f-name proc))
(build-call src (build-lexical-reference 'fun src f-name f) (build-call src (build-lexical-reference 'fun src f-name f)
val-exps)))))) (map maybe-name-value ids val-exps)))))))
(define build-letrec (define build-letrec
(lambda (src in-order? ids vars val-exps body-exp) (lambda (src in-order? ids vars val-exps body-exp)
(if (null? vars) (if (null? vars)
body-exp body-exp
(begin (make-letrec src in-order? ids vars
(for-each maybe-name-value! ids val-exps) (map maybe-name-value ids val-exps)
(make-letrec src in-order? ids vars val-exps body-exp))))) body-exp))))
(define (gen-lexical id) (define (gen-lexical id)