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: Use new `match' instead of cdadring

Browse source 
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/psyntax.scm: Use `match' more.  NFC.
This commit is contained in:
Andy Wingo 2024-11-15 14:26:25 +01:00
parent d94292724b
commit 0295409483
2 changed files with 154 additions and 107 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -74,17 +74,46 @@
(lambda (sourcev name var exp) (make-lexical-set sourcev name var (maybe-name-value name 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) (let* ((v mod)
(bare-cont #f var) (fk (lambda ()
(let ((kind (car mod)) (mod (cdr mod))) (let ((fk (lambda ()
(let ((key kind)) (let ((fk (lambda ()
(cond (let ((fk (lambda ()
((memv key '(public)) (modref-cont mod var #t)) (let ((fk (lambda () (error "value failed to match" v))))
((memv key '(private hygiene)) (if (pair? v)
(if (equal? mod (module-name (current-module))) (bare-cont mod var) (modref-cont mod var #f))) (let ((vx (car v)) (vy (cdr v)))
((memv key '(bare)) (bare-cont var)) (if (eq? vx 'primitive.)
((memv key '(primitive)) (syntax-violation #f "primitive not in operator position" var)) (if (pair? vy)
(else (syntax-violation #f "bad module kind" var mod)))))))) (let ((vx (car vy)) (vy (cdr vy)))
(if (null? vy)
(syntax-violation
#f
"primitive not in operator position"
var)
(fk)))
(fk))
(fk)))
(fk))))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(if (eq? vx 'bare) (bare-cont var) (fk)))
(fk))))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let ((tk (lambda ()
(let ((mod vy))
(if (equal? mod (module-name (current-module)))
(bare-cont mod var)
(modref-cont mod var #f))))))
(if (eq? vx 'private)
(tk)
(let* ((tk (lambda () (tk))) (hygiene vx)) (tk)))))
(fk))))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(if (eq? vx 'public) (let ((mod vy)) (modref-cont mod var #t)) (fk)))
(fk))))))
(if (eq? v #f) (bare-cont #f var) (fk)))))
(build-global-reference (build-global-reference
(lambda (sourcev var mod) (lambda (sourcev var mod)
(analyze-variable (analyze-variable
@ -115,27 +144,49 @@
(build-data (lambda (src exp) (make-const src exp))) (build-data (lambda (src exp) (make-const src exp)))
(build-sequence (build-sequence
(lambda (src exps) (lambda (src exps)
(if (null? (cdr exps)) (car exps) (make-seq src (car exps) (build-sequence #f (cdr exps)))))) (let* ((v exps)
(fk (lambda ()
(let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((head vx) (tail vy)) (make-seq src head (build-sequence #f tail))))
(fk))))))
(if (pair? v) (let ((vx (car v)) (vy (cdr v))) (let ((tail vx)) (if (null? vy) tail (fk)))) (fk)))))
(build-let (build-let
(lambda (src ids vars val-exps body-exp) (lambda (src ids vars val-exps body-exp)
(let ((val-exps (map maybe-name-value ids val-exps))) (let* ((v (map maybe-name-value ids val-exps))
(if (null? vars) body-exp (make-let src ids vars val-exps body-exp))))) (fk (lambda ()
(let* ((fk (lambda () (error "value failed to match" v))) (val-exps v))
(make-let src ids vars val-exps body-exp)))))
(if (null? v) body-exp (fk)))))
(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* ((v vars) (fk (lambda () (error "value failed to match" v))))
(let ((proc (build-simple-lambda src ids #f vars '() body-exp))) (if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((f vx) (vars vy) (v ids) (fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((f-name vx) (ids vy) (proc (build-simple-lambda src ids #f vars '() body-exp)))
(make-letrec (make-letrec
src src
#f #f
(list f-name) (list f-name)
(list f) (list f)
(list (maybe-name-value f-name proc)) (list (maybe-name-value f-name proc))
(build-call src (build-lexical-reference 'fun src f-name f) (map maybe-name-value ids val-exps))))))) (build-call
src
(build-lexical-reference 'fun src f-name f)
(map maybe-name-value ids val-exps)))))
(fk))))
(fk)))))
(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) (let* ((v (map maybe-name-value ids val-exps))
body-exp (fk (lambda ()
(make-letrec src in-order? ids vars (map maybe-name-value ids val-exps) body-exp)))) (let* ((fk (lambda () (error "value failed to match" v))) (val-exps v))
(make-letrec src in-order? ids vars val-exps body-exp)))))
(if (null? v) body-exp (fk)))))
(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)
@ -794,11 +845,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-e6b transformer-environment) (let* ((t-680b775fb37a463-f01 transformer-environment)
(t-680b775fb37a463-e6c (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-f02 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-e6b t-680b775fb37a463-f01
t-680b775fb37a463-e6c t-680b775fb37a463-f02
(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)
@ -1328,11 +1379,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-10e7 (map (lambda (tmp-680b775fb37a463-117d
tmp-680b775fb37a463-10e6 tmp-680b775fb37a463-117c
tmp-680b775fb37a463-10e5) tmp-680b775fb37a463-117b)
(cons tmp-680b775fb37a463-10e5 (cons tmp-680b775fb37a463-117b
(cons tmp-680b775fb37a463-10e6 tmp-680b775fb37a463-10e7))) (cons tmp-680b775fb37a463-117c tmp-680b775fb37a463-117d)))
e2* e2*
e1* e1*
args*))) args*)))
@ -2442,11 +2493,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-121c (map (lambda (tmp-680b775fb37a463-12b2
tmp-680b775fb37a463-121b tmp-680b775fb37a463-12b1
tmp-680b775fb37a463-121a) tmp-680b775fb37a463-12b0)
(list (cons tmp-680b775fb37a463-121a tmp-680b775fb37a463-121b) (list (cons tmp-680b775fb37a463-12b0 tmp-680b775fb37a463-12b1)
tmp-680b775fb37a463-121c)) tmp-680b775fb37a463-12b2))
template template
pattern pattern
keyword))) keyword)))
@ -2458,9 +2509,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-12cb
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-12ca
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-12c9)
(list (cons tmp-680b775fb37a463-12c9 tmp-680b775fb37a463-12ca)
tmp-680b775fb37a463-12cb))
template template
pattern pattern
keyword))) keyword)))
@ -2476,11 +2529,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-2 (map (lambda (tmp-680b775fb37a463-12ea
tmp-680b775fb37a463-1 tmp-680b775fb37a463-12e9
tmp-680b775fb37a463) tmp-680b775fb37a463-12e8)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) (list (cons tmp-680b775fb37a463-12e8 tmp-680b775fb37a463-12e9)
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-12ea))
template template
pattern pattern
keyword))) keyword)))
@ -2635,9 +2688,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-139c)
(list "value" (list "value"
tmp-680b775fb37a463)) tmp-680b775fb37a463-139c))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2673,8 +2726,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-131c) (map (lambda (tmp-680b775fb37a463-13b2)
(list "value" tmp-680b775fb37a463-131c)) (list "value" tmp-680b775fb37a463-13b2))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2694,8 +2747,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-13b7)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-13b7))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2777,8 +2830,7 @@
(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-136a) (apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463))
(cons "vector" t-680b775fb37a463-136a))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2788,7 +2840,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) (list "quote" tmp-680b775fb37a463)) (k (map (lambda (tmp-680b775fb37a463-140c)
(list "quote" tmp-680b775fb37a463-140c))
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))))
@ -2799,8 +2852,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 tmp)) (let ((t-680b775fb37a463-141b tmp))
(list "list->vector" t-680b775fb37a463))))))))))))))))) (list "list->vector" t-680b775fb37a463-141b)))))))))))))))))
(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))))
@ -2812,9 +2865,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) (apply (lambda (t-680b775fb37a463-142a)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-142a))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2830,14 +2883,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-13a8 (apply (lambda (t-680b775fb37a463-143e
t-680b775fb37a463-13a7) t-680b775fb37a463-143d)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-13a8 t-680b775fb37a463-143e
t-680b775fb37a463-13a7)) t-680b775fb37a463-143d))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2850,12 +2903,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-13b4) (apply (lambda (t-680b775fb37a463-144a)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-13b4)) t-680b775fb37a463-144a))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2868,12 +2921,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-13c0) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax (cons (make-syntax
'vector 'vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-13c0)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2884,12 +2937,12 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-13cc tmp)) (let ((t-680b775fb37a463 tmp))
(list (make-syntax (list (make-syntax
'list->vector 'list->vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-13cc)))) 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

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

@ -221,19 +221,16 @@
(make-lexical-set sourcev name var (maybe-name-value name exp))) (make-lexical-set sourcev name var (maybe-name-value name exp)))
(define (analyze-variable mod var modref-cont bare-cont) (define (analyze-variable mod var modref-cont bare-cont)
(if (not mod) (match mod
(bare-cont #f var) (#f (bare-cont #f var))
(let ((kind (car mod)) (('public . mod) (modref-cont mod var #t))
(mod (cdr mod))) (((or 'private hygiene) . mod)
(case kind (if (equal? mod (module-name (current-module)))
((public) (modref-cont mod var #t))
((private hygiene) (if (equal? mod (module-name (current-module)))
(bare-cont mod var) (bare-cont mod var)
(modref-cont mod var #f))) (modref-cont mod var #f)))
((bare) (bare-cont var)) (('bare . _) (bare-cont var))
((primitive) (('primitive. _)
(syntax-violation #f "primitive not in operator position" var)) (syntax-violation #f "primitive not in operator position" var))))
(else (syntax-violation #f "bad module kind" var mod))))))
(define (build-global-reference sourcev var mod) (define (build-global-reference sourcev var mod)
(analyze-variable (analyze-variable
@ -290,35 +287,32 @@
(make-const src exp)) (make-const src exp))
(define (build-sequence src exps) (define (build-sequence src exps)
(if (null? (cdr exps)) (match exps
(car exps) ((tail) tail)
(make-seq src (car exps) (build-sequence #f (cdr exps))))) ((head . tail)
(make-seq src head (build-sequence #f tail)))))
(define (build-let src ids vars val-exps body-exp) (define (build-let src ids vars val-exps body-exp)
(let ((val-exps (map maybe-name-value ids val-exps))) (match (map maybe-name-value ids val-exps)
(if (null? vars) (() body-exp)
body-exp (val-exps (make-let src ids vars val-exps body-exp))))
(make-let src ids vars val-exps body-exp))))
(define (build-named-let src ids vars val-exps body-exp) (define (build-named-let src ids vars val-exps body-exp)
(let ((f (car vars)) (match vars
(f-name (car ids)) ((f . vars)
(vars (cdr vars)) (match ids
(ids (cdr ids))) ((f-name . ids)
(let ((proc (build-simple-lambda src ids #f vars '() body-exp))) (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
(make-letrec (make-letrec
src #f src #f
(list f-name) (list f) (list (maybe-name-value f-name 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)
(map maybe-name-value ids val-exps)))))) (map maybe-name-value ids val-exps)))))))))
(define (build-letrec src in-order? ids vars val-exps body-exp) (define (build-letrec src in-order? ids vars val-exps body-exp)
(if (null? vars) (match (map maybe-name-value ids val-exps)
body-exp (() body-exp)
(make-letrec src in-order? ids vars (val-exps (make-letrec src in-order? ids vars val-exps body-exp))))
(map maybe-name-value ids val-exps)
body-exp)))
(define (gen-lexical id) (define (gen-lexical id)
;; Generate a unique symbol for a lexical variable. These need to ;; Generate a unique symbol for a lexical variable. These need to