diff options
author | Andy Wingo <wingo@pobox.com> | 2024-11-19 14:23:47 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2024-11-19 14:23:47 +0100 |
commit | 2f684989e1c42638fe64e12669b9f18129e4dd06 (patch) | |
tree | 782aaf0f2d7f43f36331392280f85c9cdc88411f /module/ice-9 | |
parent | 7379049d3093fe2076f110c35d482a2aa96d6496 (diff) | |
download | guile-2f684989e1c42638fe64e12669b9f18129e4dd06.tar.gz |
psyntax: Simplify output constructors.
* module/ice-9/psyntax.scm: Eta-reduce build-void, build-call, et al.
* module/ice-9/psyntax-pp.scm: Regenerate.
Diffstat (limited to 'module/ice-9')
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 156 | ||||
-rw-r--r-- | module/ice-9/psyntax.scm | 45 |
2 files changed, 82 insertions, 119 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 0d86fabf1..858b9ec2a 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -122,11 +122,10 @@ (let ((meta (lambda-meta val))) (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-call (lambda (sourcev fun-exp arg-exps) (make-call sourcev fun-exp arg-exps))) - (build-conditional - (lambda (sourcev test-exp then-exp else-exp) (make-conditional sourcev test-exp then-exp else-exp))) - (build-lexical-reference (lambda (sourcev name var) (make-lexical-ref sourcev name var))) + (build-void make-void) + (build-call make-call) + (build-conditional make-conditional) + (build-lexical-reference make-lexical-ref) (build-lexical-assignment (lambda (sourcev name var exp) (make-lexical-set sourcev name var (maybe-name-value name exp)))) (analyze-variable @@ -182,13 +181,11 @@ (build-simple-lambda (lambda (src req rest vars meta exp) (make-lambda src meta (make-lambda-case src req #f rest #f '() vars exp #f)))) - (build-case-lambda (lambda (src meta body) (make-lambda src meta body))) - (build-lambda-case - (lambda (src req opt rest kw inits vars body else-case) - (make-lambda-case src req opt rest kw inits vars body else-case))) - (build-primcall (lambda (src name args) (make-primcall src name args))) - (build-primref (lambda (src name) (make-primitive-ref src name))) - (build-data (lambda (src exp) (make-const src exp))) + (build-case-lambda make-lambda) + (build-lambda-case make-lambda-case) + (build-primcall make-primcall) + (build-primref make-primitive-ref) + (build-data make-const) (build-sequence (lambda (src exps) (let* ((v exps) @@ -1200,11 +1197,11 @@ (source-wrap e w (wrap-subst w) mod) x)) (else (decorate-source x)))))) - (let* ((t-680b775fb37a463-cc2 transformer-environment) - (t-680b775fb37a463-cc3 (lambda (k) (k e r w s rib mod)))) + (let* ((t-680b775fb37a463-c86 transformer-environment) + (t-680b775fb37a463-c87 (lambda (k) (k e r w s rib mod)))) (with-fluid* - t-680b775fb37a463-cc2 - t-680b775fb37a463-cc3 + t-680b775fb37a463-c86 + t-680b775fb37a463-c87 (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (expand-body (lambda (body outer-form r w mod) @@ -1735,11 +1732,11 @@ s mod get-formals - (map (lambda (tmp-680b775fb37a463-f4b - tmp-680b775fb37a463-f4a - tmp-680b775fb37a463-f49) - (cons tmp-680b775fb37a463-f49 - (cons tmp-680b775fb37a463-f4a tmp-680b775fb37a463-f4b))) + (map (lambda (tmp-680b775fb37a463-f0f + tmp-680b775fb37a463-f0e + tmp-680b775fb37a463-f0d) + (cons tmp-680b775fb37a463-f0d + (cons tmp-680b775fb37a463-f0e tmp-680b775fb37a463-f0f))) e2* e1* args*))) @@ -2012,11 +2009,8 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-11b0 - tmp-680b775fb37a463-11af - tmp-680b775fb37a463-11ae) - (cons tmp-680b775fb37a463-11ae - (cons tmp-680b775fb37a463-11af tmp-680b775fb37a463-11b0))) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) e2 e1 args))) @@ -2026,11 +2020,9 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-11c6 - tmp-680b775fb37a463-11c5 - tmp-680b775fb37a463-11c4) - (cons tmp-680b775fb37a463-11c4 - (cons tmp-680b775fb37a463-11c5 tmp-680b775fb37a463-11c6))) + (map (lambda (tmp-680b775fb37a463-118a tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (cons tmp-680b775fb37a463 + (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-118a))) e2 e1 args))) @@ -2048,11 +2040,11 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-11e6 - tmp-680b775fb37a463-11e5 - tmp-680b775fb37a463-11e4) - (cons tmp-680b775fb37a463-11e4 - (cons tmp-680b775fb37a463-11e5 tmp-680b775fb37a463-11e6))) + (map (lambda (tmp-680b775fb37a463-11aa + tmp-680b775fb37a463-11a9 + tmp-680b775fb37a463-11a8) + (cons tmp-680b775fb37a463-11a8 + (cons tmp-680b775fb37a463-11a9 tmp-680b775fb37a463-11aa))) e2 e1 args))) @@ -2062,11 +2054,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-11fc - tmp-680b775fb37a463-11fb - tmp-680b775fb37a463-11fa) - (cons tmp-680b775fb37a463-11fa - (cons tmp-680b775fb37a463-11fb tmp-680b775fb37a463-11fc))) + (map (lambda (tmp-680b775fb37a463-11c0 + tmp-680b775fb37a463-11bf + tmp-680b775fb37a463-11be) + (cons tmp-680b775fb37a463-11be + (cons tmp-680b775fb37a463-11bf tmp-680b775fb37a463-11c0))) e2 e1 args))) @@ -2876,9 +2868,9 @@ #f k '() - (map (lambda (tmp-680b775fb37a463-14da tmp-680b775fb37a463-14d9 tmp-680b775fb37a463-14d8) - (list (cons tmp-680b775fb37a463-14d8 tmp-680b775fb37a463-14d9) - tmp-680b775fb37a463-14da)) + (map (lambda (tmp-680b775fb37a463-149e tmp-680b775fb37a463-149d tmp-680b775fb37a463-149c) + (list (cons tmp-680b775fb37a463-149c tmp-680b775fb37a463-149d) + tmp-680b775fb37a463-149e)) template pattern keyword))) @@ -2893,11 +2885,11 @@ #f k (list docstring) - (map (lambda (tmp-680b775fb37a463-14f3 - tmp-680b775fb37a463-14f2 - tmp-680b775fb37a463-14f1) - (list (cons tmp-680b775fb37a463-14f1 tmp-680b775fb37a463-14f2) - tmp-680b775fb37a463-14f3)) + (map (lambda (tmp-680b775fb37a463-14b7 + tmp-680b775fb37a463-14b6 + tmp-680b775fb37a463-14b5) + (list (cons tmp-680b775fb37a463-14b5 tmp-680b775fb37a463-14b6) + tmp-680b775fb37a463-14b7)) template pattern keyword))) @@ -2909,11 +2901,11 @@ dots k '() - (map (lambda (tmp-680b775fb37a463-150c - tmp-680b775fb37a463-150b - tmp-680b775fb37a463-150a) - (list (cons tmp-680b775fb37a463-150a tmp-680b775fb37a463-150b) - tmp-680b775fb37a463-150c)) + (map (lambda (tmp-680b775fb37a463-14d0 + tmp-680b775fb37a463-14cf + tmp-680b775fb37a463-14ce) + (list (cons tmp-680b775fb37a463-14ce tmp-680b775fb37a463-14cf) + tmp-680b775fb37a463-14d0)) template pattern keyword))) @@ -2929,11 +2921,11 @@ dots k (list docstring) - (map (lambda (tmp-680b775fb37a463-152b - tmp-680b775fb37a463-152a - tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-152a) - tmp-680b775fb37a463-152b)) + (map (lambda (tmp-680b775fb37a463-14ef + tmp-680b775fb37a463-14ee + tmp-680b775fb37a463-14ed) + (list (cons tmp-680b775fb37a463-14ed tmp-680b775fb37a463-14ee) + tmp-680b775fb37a463-14ef)) template pattern keyword))) @@ -3061,9 +3053,9 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-15d8) + (map (lambda (tmp-680b775fb37a463-159c) (list "value" - tmp-680b775fb37a463-15d8)) + tmp-680b775fb37a463-159c)) p) (quasi q lev)) (quasicons @@ -3089,9 +3081,9 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-15dd) + (map (lambda (tmp-680b775fb37a463-15a1) (list "value" - tmp-680b775fb37a463-15dd)) + tmp-680b775fb37a463-15a1)) p) (quasi q lev)) (quasicons @@ -3127,8 +3119,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-15f3) - (list "value" tmp-680b775fb37a463-15f3)) + (map (lambda (tmp-680b775fb37a463-15b7) + (list "value" tmp-680b775fb37a463-15b7)) p) (vquasi q lev)) (quasicons @@ -3148,8 +3140,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-15f8) - (list "value" tmp-680b775fb37a463-15f8)) + (map (lambda (tmp-680b775fb37a463-15bc) + (list "value" tmp-680b775fb37a463-15bc)) p) (vquasi q lev)) (quasicons @@ -3241,8 +3233,7 @@ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (if tmp-1 (apply (lambda (y) - (k (map (lambda (tmp-680b775fb37a463-164d) - (list "quote" tmp-680b775fb37a463-164d)) + (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463)) y))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) @@ -3253,8 +3244,8 @@ (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (let ((else tmp)) (let ((tmp x)) - (let ((t-680b775fb37a463-165c tmp)) - (list "list->vector" t-680b775fb37a463-165c))))))))))))))))) + (let ((t-680b775fb37a463 tmp)) + (list "list->vector" t-680b775fb37a463))))))))))))))))) (emit (lambda (x) (let ((tmp x)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) @@ -3266,9 +3257,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-166b) + (apply (lambda (t-680b775fb37a463-162f) (cons (make-syntax 'list '((top)) '(hygiene guile)) - t-680b775fb37a463-166b)) + t-680b775fb37a463-162f)) tmp) (syntax-violation #f @@ -3284,14 +3275,13 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-680b775fb37a463-167f - t-680b775fb37a463-167e) + (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463) (list (make-syntax 'cons '((top)) '(hygiene guile)) - t-680b775fb37a463-167f - t-680b775fb37a463-167e)) + t-680b775fb37a463-1 + t-680b775fb37a463)) tmp) (syntax-violation #f @@ -3304,12 +3294,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-168b) + (apply (lambda (t-680b775fb37a463-164f) (cons (make-syntax 'append '((top)) '(hygiene guile)) - t-680b775fb37a463-168b)) + t-680b775fb37a463-164f)) tmp) (syntax-violation #f @@ -3322,12 +3312,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463) + (apply (lambda (t-680b775fb37a463-165b) (cons (make-syntax 'vector '((top)) '(hygiene guile)) - t-680b775fb37a463)) + t-680b775fb37a463-165b)) tmp) (syntax-violation #f @@ -3338,12 +3328,12 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t-680b775fb37a463-16a3 tmp)) + (let ((t-680b775fb37a463 tmp)) (list (make-syntax 'list->vector '((top)) '(hygiene guile)) - t-680b775fb37a463-16a3)))) + t-680b775fb37a463)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (if tmp-1 diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 5a33768f4..b24e889f7 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -228,18 +228,10 @@ val)) ;; output constructors - (define (build-void sourcev) - (make-void sourcev)) - - (define (build-call sourcev fun-exp arg-exps) - (make-call sourcev fun-exp arg-exps)) - - (define (build-conditional sourcev test-exp then-exp else-exp) - (make-conditional sourcev test-exp then-exp else-exp)) - - (define (build-lexical-reference sourcev name var) - (make-lexical-ref sourcev name var)) - + (define build-void make-void) + (define build-call make-call) + (define build-conditional make-conditional) + (define build-lexical-reference make-lexical-ref) (define (build-lexical-assignment sourcev name var exp) (make-lexical-set sourcev name var (maybe-name-value name exp))) @@ -283,30 +275,11 @@ ;; src req opt rest kw inits vars body else src req #f rest #f '() vars exp #f))) - (define (build-case-lambda src meta body) - (make-lambda src meta body)) - - (define (build-lambda-case src req opt rest kw inits vars body else-case) - ;; req := (name ...) - ;; opt := (name ...) | #f - ;; rest := name | #f - ;; kw := (allow-other-keys? (keyword name var) ...) | #f - ;; inits: (init ...) - ;; vars: (sym ...) - ;; vars map to named arguments in the following order: - ;; required, optional (positional), rest, keyword. - ;; the body of a lambda: anything, already expanded - ;; else: lambda-case | #f - (make-lambda-case src req opt rest kw inits vars body else-case)) - - (define (build-primcall src name args) - (make-primcall src name args)) - - (define (build-primref src name) - (make-primitive-ref src name)) - - (define (build-data src exp) - (make-const src exp)) + (define build-case-lambda make-lambda) + (define build-lambda-case make-lambda-case) + (define build-primcall make-primcall) + (define build-primref make-primitive-ref) + (define build-data make-const) (define (build-sequence src exps) (match exps |