diff options
author | Andy Wingo <wingo@pobox.com> | 2024-11-18 16:53:41 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2024-11-18 16:53:41 +0100 |
commit | cdf8473b190ac3ed108437974a41d3d990a27b2d (patch) | |
tree | f720a204e5ee595aaf895e854204f41b67ee3743 /module | |
parent | 6c4f9a58c91a22dccf2bcf2d0633a0c48b871273 (diff) | |
download | guile-cdf8473b190ac3ed108437974a41d3d990a27b2d.tar.gz |
psyntax: Separate core expanders from their installation
* module/ice-9/psyntax.scm (expand-let, expand-letrec, ...): Name these
expanders, then install them. Allows for better code evolution and
decreases the indent.
* module/ice-9/psyntax-pp.scm: Regenerate.
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 1479 | ||||
-rw-r--r-- | module/ice-9/psyntax.scm | 1325 |
2 files changed, 1417 insertions, 1387 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 99e904cbe..df6131d31 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1151,11 +1151,11 @@ (source-wrap e w (wrap-subst w) mod) x)) (else (decorate-source x)))))) - (let* ((t-680b775fb37a463-10a3 transformer-environment) - (t-680b775fb37a463-10a4 (lambda (k) (k e r w s rib mod)))) + (let* ((t-680b775fb37a463-c51 transformer-environment) + (t-680b775fb37a463-c52 (lambda (k) (k e r w s rib mod)))) (with-fluid* - t-680b775fb37a463-10a3 - t-680b775fb37a463-10a4 + t-680b775fb37a463-c51 + t-680b775fb37a463-c52 (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (expand-body (lambda (body outer-form r w mod) @@ -1686,11 +1686,11 @@ s mod get-formals - (map (lambda (tmp-680b775fb37a463-132c - tmp-680b775fb37a463-132b - tmp-680b775fb37a463-132a) - (cons tmp-680b775fb37a463-132a - (cons tmp-680b775fb37a463-132b tmp-680b775fb37a463-132c))) + (map (lambda (tmp-680b775fb37a463-eda + tmp-680b775fb37a463-ed9 + tmp-680b775fb37a463-ed8) + (cons tmp-680b775fb37a463-ed8 + (cons tmp-680b775fb37a463-ed9 tmp-680b775fb37a463-eda))) e2* e1* args*))) @@ -1721,709 +1721,745 @@ ((id? vars) (cons (wrap vars w #f) ls)) ((null? vars) ls) ((syntax? vars) (lvl (syntax-expression vars) ls (join-wraps w (syntax-wrap vars)))) - (else (cons vars ls))))))) - (global-extend 'local-syntax 'letrec-syntax #t) - (global-extend 'local-syntax 'let-syntax #f) - (global-extend - 'core - 'syntax-parameterize - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp)) - (apply (lambda (var val e1 e2) - (let ((names (map (lambda (x) - (call-with-values - (lambda () (resolve-identifier x w r mod #f)) - (lambda (type value mod) - (let ((key type)) - (cond - ((memv key '(displaced-lexical)) - (syntax-violation - 'syntax-parameterize - "identifier out of context" - e - (source-wrap x w s mod))) - ((memv key '(syntax-parameter)) value) - (else (syntax-violation - 'syntax-parameterize - "invalid syntax parameter" - e - (source-wrap x w s mod)))))))) - var)) - (bindings - (let ((trans-r (macros-only-env r))) - (map (lambda (x) - (cons 'syntax-parameter (eval-local-transformer (expand x trans-r w mod) mod))) - val)))) - (expand-body (cons e1 e2) (source-wrap e w s mod) (extend-env names bindings r) w mod))) - tmp) - (syntax-violation 'syntax-parameterize "bad syntax" (source-wrap e w s mod)))))) - (global-extend - 'core - 'quote - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any)))) - (if tmp - (apply (lambda (e) (build-data s (strip e))) tmp) - (syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) - (global-extend - 'core - 'quote-syntax - (lambda (e r w s mod) - (let* ((tmp-1 (source-wrap e w s mod)) (tmp ($sc-dispatch tmp-1 '(_ any)))) - (if tmp (apply (lambda (e) (build-data s e)) tmp) (let ((e tmp-1)) (syntax-violation 'quote "bad syntax" e)))))) - (global-extend - 'core - 'syntax - (letrec* ((gen-syntax - (lambda (src e r maps ellipsis? mod) - (if (id? e) - (call-with-values - (lambda () (resolve-identifier e empty-wrap r mod #f)) - (lambda (type value mod) - (let ((key type)) - (cond - ((memv key '(syntax)) + (else (cons vars ls)))))) + (expand-syntax-parameterize + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp)) + (apply (lambda (var val e1 e2) + (let ((names (map (lambda (x) + (call-with-values + (lambda () (resolve-identifier x w r mod #f)) + (lambda (type value mod) + (let ((key type)) + (cond + ((memv key '(displaced-lexical)) + (syntax-violation + 'syntax-parameterize + "identifier out of context" + e + (source-wrap x w s mod))) + ((memv key '(syntax-parameter)) value) + (else (syntax-violation + 'syntax-parameterize + "invalid syntax parameter" + e + (source-wrap x w s mod)))))))) + var)) + (bindings + (let ((trans-r (macros-only-env r))) + (map (lambda (x) + (cons 'syntax-parameter + (eval-local-transformer (expand x trans-r w mod) mod))) + val)))) + (expand-body (cons e1 e2) (source-wrap e w s mod) (extend-env names bindings r) w mod))) + tmp) + (syntax-violation 'syntax-parameterize "bad syntax" (source-wrap e w s mod)))))) + (expand-quote + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any)))) + (if tmp + (apply (lambda (e) (build-data s (strip e))) tmp) + (syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) + (expand-quote-syntax + (lambda (e r w s mod) + (let* ((tmp-1 (source-wrap e w s mod)) (tmp ($sc-dispatch tmp-1 '(_ any)))) + (if tmp + (apply (lambda (e) (build-data s e)) tmp) + (let ((e tmp-1)) (syntax-violation 'quote "bad syntax" e)))))) + (expand-syntax + (letrec* ((gen-syntax + (lambda (src e r maps ellipsis? mod) + (if (id? e) (call-with-values - (lambda () (gen-ref src (car value) (cdr value) maps)) - (lambda (var maps) (values (list 'ref var) maps)))) - ((ellipsis? e r mod) (syntax-violation 'syntax "misplaced ellipsis" src)) - (else (values (list 'quote e) maps)))))) - (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1)) - (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod)) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) - (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1)) - (apply (lambda (x dots y) - (let f ((y y) - (k (lambda (maps) - (call-with-values - (lambda () (gen-syntax src x r (cons '() maps) ellipsis? mod)) - (lambda (x maps) - (if (null? (car maps)) - (syntax-violation 'syntax "extra ellipsis" src) - (values (gen-map x (car maps)) (cdr maps)))))))) - (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any)))) - (if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp)) - (apply (lambda (dots y) - (f y - (lambda (maps) - (call-with-values - (lambda () (k (cons '() maps))) - (lambda (x maps) - (if (null? (car maps)) - (syntax-violation 'syntax "extra ellipsis" src) - (values (gen-mappend x (car maps)) (cdr maps)))))))) - tmp) - (call-with-values - (lambda () (gen-syntax src y r maps ellipsis? mod)) - (lambda (y maps) - (call-with-values - (lambda () (k maps)) - (lambda (x maps) (values (gen-append x y) maps))))))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if tmp-1 - (apply (lambda (x y) - (call-with-values - (lambda () (gen-syntax src x r maps ellipsis? mod)) - (lambda (x maps) - (call-with-values - (lambda () (gen-syntax src y r maps ellipsis? mod)) - (lambda (y maps) (values (gen-cons x y) maps)))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '#(vector (any . each-any))))) - (if tmp-1 - (apply (lambda (e1 e2) - (call-with-values - (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod)) - (lambda (e maps) (values (gen-vector e) maps)))) - tmp-1) - (let ((tmp-1 (list tmp))) - (if (and tmp-1 (apply (lambda (x) (eq? (syntax->datum x) #nil)) tmp-1)) - (apply (lambda (x) (values ''#nil maps)) tmp-1) - (let ((tmp ($sc-dispatch tmp '()))) - (if tmp - (apply (lambda () (values ''() maps)) tmp) - (values (list 'quote e) maps)))))))))))))))) - (gen-ref - (lambda (src var level maps) - (cond - ((= level 0) (values var maps)) - ((null? maps) (syntax-violation 'syntax "missing ellipsis" src)) - (else (call-with-values - (lambda () (gen-ref src var (#{1-}# level) (cdr maps))) - (lambda (outer-var outer-maps) - (let ((b (assq outer-var (car maps)))) - (if b - (values (cdr b) maps) - (let ((inner-var (gen-var 'tmp))) - (values inner-var (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) - (gen-mappend (lambda (e map-env) (list 'apply '(primitive append) (gen-map e map-env)))) - (gen-map - (lambda (e map-env) - (let ((formals (map cdr map-env)) (actuals (map (lambda (x) (list 'ref (car x))) map-env))) - (cond - ((eq? (car e) 'ref) (car actuals)) - ((and-map (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) (cdr e)) - (cons 'map - (cons (list 'primitive (car e)) - (map (let ((r (map cons formals actuals))) (lambda (x) (cdr (assq (cadr x) r)))) - (cdr e))))) - (else (cons 'map (cons (list 'lambda formals e) actuals))))))) - (gen-cons - (lambda (x y) - (let ((key (car y))) - (cond - ((memv key '(quote)) - (cond - ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y)))) - ((eq? (cadr y) '()) (list 'list x)) - (else (list 'cons x y)))) - ((memv key '(list)) (cons 'list (cons x (cdr y)))) - (else (list 'cons x y)))))) - (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y)))) - (gen-vector - (lambda (x) - (cond - ((eq? (car x) 'list) (cons 'vector (cdr x))) - ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x)))) - (else (list 'list->vector x))))) - (regen (lambda (x) - (let ((key (car x))) + (lambda () (resolve-identifier e empty-wrap r mod #f)) + (lambda (type value mod) + (let ((key type)) + (cond + ((memv key '(syntax)) + (call-with-values + (lambda () (gen-ref src (car value) (cdr value) maps)) + (lambda (var maps) (values (list 'ref var) maps)))) + ((ellipsis? e r mod) (syntax-violation 'syntax "misplaced ellipsis" src)) + (else (values (list 'quote e) maps)))))) + (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1)) + (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod)) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) + (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1)) + (apply (lambda (x dots y) + (let f ((y y) + (k (lambda (maps) + (call-with-values + (lambda () + (gen-syntax src x r (cons '() maps) ellipsis? mod)) + (lambda (x maps) + (if (null? (car maps)) + (syntax-violation 'syntax "extra ellipsis" src) + (values (gen-map x (car maps)) (cdr maps)))))))) + (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any)))) + (if (and tmp + (apply (lambda (dots y) (ellipsis? dots r mod)) tmp)) + (apply (lambda (dots y) + (f y + (lambda (maps) + (call-with-values + (lambda () (k (cons '() maps))) + (lambda (x maps) + (if (null? (car maps)) + (syntax-violation + 'syntax + "extra ellipsis" + src) + (values + (gen-mappend x (car maps)) + (cdr maps)))))))) + tmp) + (call-with-values + (lambda () (gen-syntax src y r maps ellipsis? mod)) + (lambda (y maps) + (call-with-values + (lambda () (k maps)) + (lambda (x maps) (values (gen-append x y) maps))))))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if tmp-1 + (apply (lambda (x y) + (call-with-values + (lambda () (gen-syntax src x r maps ellipsis? mod)) + (lambda (x maps) + (call-with-values + (lambda () (gen-syntax src y r maps ellipsis? mod)) + (lambda (y maps) (values (gen-cons x y) maps)))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '#(vector (any . each-any))))) + (if tmp-1 + (apply (lambda (e1 e2) + (call-with-values + (lambda () + (gen-syntax src (cons e1 e2) r maps ellipsis? mod)) + (lambda (e maps) (values (gen-vector e) maps)))) + tmp-1) + (let ((tmp-1 (list tmp))) + (if (and tmp-1 + (apply (lambda (x) (eq? (syntax->datum x) #nil)) tmp-1)) + (apply (lambda (x) (values ''#nil maps)) tmp-1) + (let ((tmp ($sc-dispatch tmp '()))) + (if tmp + (apply (lambda () (values ''() maps)) tmp) + (values (list 'quote e) maps)))))))))))))))) + (gen-ref + (lambda (src var level maps) (cond - ((memv key '(ref)) (build-lexical-reference no-source (cadr x) (cadr x))) - ((memv key '(primitive)) (build-primref no-source (cadr x))) - ((memv key '(quote)) (build-data no-source (cadr x))) - ((memv key '(lambda)) - (if (list? (cadr x)) - (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x))) - (error "how did we get here" x))) - (else (build-primcall no-source (car x) (map regen (cdr x))))))))) - (lambda (e r w s mod) - (let* ((e (source-wrap e w s mod)) (tmp e) (tmp ($sc-dispatch tmp '(_ any)))) - (if tmp - (apply (lambda (x) - (call-with-values (lambda () (gen-syntax e x r '() ellipsis? mod)) (lambda (e maps) (regen e)))) - tmp) - (syntax-violation 'syntax "bad `syntax' form" e)))))) - (global-extend - 'core - 'lambda - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) - (if tmp - (apply (lambda (args e1 e2) - (call-with-values - (lambda () (lambda-formals args)) - (lambda (req opt rest kw) - (let lp ((body (cons e1 e2)) (meta '())) - (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any)))) - (if (and tmp (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring))) tmp)) - (apply (lambda (docstring e1 e2) - (lp (cons e1 e2) - (append meta (list (cons 'documentation (syntax->datum docstring)))))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any)))) - (if tmp - (apply (lambda (k v e1 e2) - (lp (cons e1 e2) (append meta (syntax->datum (map cons k v))))) - tmp) - (expand-simple-lambda e r w s mod req rest meta body))))))))) - tmp) - (syntax-violation 'lambda "bad lambda" e))))) - (global-extend - 'core - 'lambda* - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) - (if tmp - (apply (lambda (args e1 e2) - (call-with-values - (lambda () (expand-lambda-case e r w s mod lambda*-formals (list (cons args (cons e1 e2))))) - (lambda (meta lcase) (build-case-lambda s meta lcase)))) - tmp) - (syntax-violation 'lambda "bad lambda*" e))))) - (global-extend - 'core - 'case-lambda - (lambda (e r w s mod) - (letrec* ((build-it - (lambda (meta clauses) - (call-with-values - (lambda () (expand-lambda-case e r w s mod lambda-formals clauses)) - (lambda (meta* lcase) (build-case-lambda s (append meta meta*) lcase)))))) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) - (if tmp - (apply (lambda (args e1 e2) - (build-it - '() - (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) - e2 - e1 - args))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) - (if (and tmp (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) tmp)) - (apply (lambda (docstring args e1 e2) - (build-it - (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-6ae tmp-680b775fb37a463-6ad tmp-680b775fb37a463-6ac) - (cons tmp-680b775fb37a463-6ac - (cons tmp-680b775fb37a463-6ad tmp-680b775fb37a463-6ae))) - e2 - e1 - args))) - tmp) - (syntax-violation 'case-lambda "bad case-lambda" e)))))))) - (global-extend - 'core - 'case-lambda* - (lambda (e r w s mod) - (letrec* ((build-it - (lambda (meta clauses) - (call-with-values - (lambda () (expand-lambda-case e r w s mod lambda*-formals clauses)) - (lambda (meta* lcase) (build-case-lambda s (append meta meta*) lcase)))))) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) - (if tmp - (apply (lambda (args e1 e2) - (build-it - '() - (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) - e2 - e1 - args))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) - (if (and tmp (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) tmp)) - (apply (lambda (docstring args e1 e2) - (build-it - (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) - e2 - e1 - args))) + ((= level 0) (values var maps)) + ((null? maps) (syntax-violation 'syntax "missing ellipsis" src)) + (else (call-with-values + (lambda () (gen-ref src var (#{1-}# level) (cdr maps))) + (lambda (outer-var outer-maps) + (let ((b (assq outer-var (car maps)))) + (if b + (values (cdr b) maps) + (let ((inner-var (gen-var 'tmp))) + (values + inner-var + (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) + (gen-mappend (lambda (e map-env) (list 'apply '(primitive append) (gen-map e map-env)))) + (gen-map + (lambda (e map-env) + (let ((formals (map cdr map-env)) (actuals (map (lambda (x) (list 'ref (car x))) map-env))) + (cond + ((eq? (car e) 'ref) (car actuals)) + ((and-map (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) (cdr e)) + (cons 'map + (cons (list 'primitive (car e)) + (map (let ((r (map cons formals actuals))) + (lambda (x) (cdr (assq (cadr x) r)))) + (cdr e))))) + (else (cons 'map (cons (list 'lambda formals e) actuals))))))) + (gen-cons + (lambda (x y) + (let ((key (car y))) + (cond + ((memv key '(quote)) + (cond + ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y)))) + ((eq? (cadr y) '()) (list 'list x)) + (else (list 'cons x y)))) + ((memv key '(list)) (cons 'list (cons x (cdr y)))) + (else (list 'cons x y)))))) + (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y)))) + (gen-vector + (lambda (x) + (cond + ((eq? (car x) 'list) (cons 'vector (cdr x))) + ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x)))) + (else (list 'list->vector x))))) + (regen (lambda (x) + (let ((key (car x))) + (cond + ((memv key '(ref)) (build-lexical-reference no-source (cadr x) (cadr x))) + ((memv key '(primitive)) (build-primref no-source (cadr x))) + ((memv key '(quote)) (build-data no-source (cadr x))) + ((memv key '(lambda)) + (if (list? (cadr x)) + (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x))) + (error "how did we get here" x))) + (else (build-primcall no-source (car x) (map regen (cdr x))))))))) + (lambda (e r w s mod) + (let* ((e (source-wrap e w s mod)) (tmp e) (tmp ($sc-dispatch tmp '(_ any)))) + (if tmp + (apply (lambda (x) + (call-with-values + (lambda () (gen-syntax e x r '() ellipsis? mod)) + (lambda (e maps) (regen e)))) + tmp) + (syntax-violation 'syntax "bad `syntax' form" e)))))) + (expand-lambda + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) + (if tmp + (apply (lambda (args e1 e2) + (call-with-values + (lambda () (lambda-formals args)) + (lambda (req opt rest kw) + (let lp ((body (cons e1 e2)) (meta '())) + (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any)))) + (if (and tmp + (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring))) tmp)) + (apply (lambda (docstring e1 e2) + (lp (cons e1 e2) + (append + meta + (list (cons 'documentation (syntax->datum docstring)))))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any)))) + (if tmp + (apply (lambda (k v e1 e2) + (lp (cons e1 e2) (append meta (syntax->datum (map cons k v))))) + tmp) + (expand-simple-lambda e r w s mod req rest meta body))))))))) tmp) - (syntax-violation 'case-lambda "bad case-lambda*" e)))))))) - (global-extend - 'core - 'with-ellipsis - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) - (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp)) - (apply (lambda (dots e1 e2) - (let ((id (if (symbol? dots) - '#{ $sc-ellipsis }# - (make-syntax - '#{ $sc-ellipsis }# - (syntax-wrap dots) - (syntax-module dots) - (syntax-sourcev dots))))) - (let ((ids (list id)) - (labels (list (gen-label))) - (bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) - (let ((nw (make-binding-wrap ids labels w)) (nr (extend-env labels bindings r))) - (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod))))) - tmp) - (syntax-violation 'with-ellipsis "bad syntax" (source-wrap e w s mod)))))) - (global-extend - 'core - 'let - (letrec* ((expand-let - (lambda (e r w s mod constructor ids vals exps) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'let "duplicate bound variable" e) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (let ((nw (make-binding-wrap ids labels w)) (nr (extend-var-env labels new-vars r))) - (constructor - s - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) vals) - (expand-body exps (source-wrap e nw s mod) nr nw mod)))))))) - (lambda (e r w s mod) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) - (apply (lambda (id val e1 e2) (expand-let e r w s mod build-let id val (cons e1 e2))) tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp)) - (apply (lambda (f id val e1 e2) - (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2))) + (syntax-violation 'lambda "bad lambda" e))))) + (expand-lambda* + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) + (if tmp + (apply (lambda (args e1 e2) + (call-with-values + (lambda () + (expand-lambda-case e r w s mod lambda*-formals (list (cons args (cons e1 e2))))) + (lambda (meta lcase) (build-case-lambda s meta lcase)))) tmp) - (syntax-violation 'let "bad let" (source-wrap e w s mod))))))))) - (global-extend - 'core - 'letrec - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) - (apply (lambda (id val e1 e2) - (let ((ids id)) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'letrec "duplicate bound variable" e) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (let ((w (make-binding-wrap ids labels w)) (r (extend-var-env labels new-vars r))) - (build-letrec - s - #f - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) val) - (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) - tmp) - (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) - (global-extend - 'core - 'letrec* - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) - (apply (lambda (id val e1 e2) - (let ((ids id)) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'letrec* "duplicate bound variable" e) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (let ((w (make-binding-wrap ids labels w)) (r (extend-var-env labels new-vars r))) - (build-letrec - s - #t - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) val) - (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) - tmp) - (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) - (global-extend - 'core - 'set! - (lambda (e r w s mod) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) - (if (and tmp (apply (lambda (id val) (id? id)) tmp)) - (apply (lambda (id val) - (call-with-values - (lambda () (resolve-identifier id w r mod #t)) - (lambda (type value id-mod) - (let ((key type)) - (cond - ((memv key '(lexical)) - (build-lexical-assignment s (syntax->datum id) value (expand val r w mod))) - ((memv key '(global)) (build-global-assignment s value (expand val r w mod) id-mod)) - ((memv key '(macro)) - (if (procedure-property value 'variable-transformer) - (expand (expand-macro value e r w s #f mod) r empty-wrap mod) - (syntax-violation - 'set! - "not a variable transformer" - (wrap e w mod) - (wrap id w id-mod)))) - ((memv key '(displaced-lexical)) - (syntax-violation 'set! "identifier out of context" (wrap id w mod))) - (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any)))) - (if tmp - (apply (lambda (head tail val) + (syntax-violation 'lambda "bad lambda*" e))))) + (expand-case-lambda + (lambda (e r w s mod) + (letrec* ((build-it + (lambda (meta clauses) (call-with-values - (lambda () (syntax-type head r empty-wrap no-source #f mod #t)) - (lambda (type value ee* ee ww ss modmod) - (let ((key type)) - (if (memv key '(module-ref)) - (let ((val (expand val r w mod))) - (call-with-values - (lambda () (value (cons head tail) r w mod)) - (lambda (e r w s* mod) - (let* ((tmp-1 e) (tmp (list tmp-1))) - (if (and tmp (apply (lambda (e) (id? e)) tmp)) - (apply (lambda (e) - (build-global-assignment s (syntax->datum e) val mod)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))))) - (build-call - s - (expand (list (make-syntax 'setter '((top)) '(hygiene guile)) head) r w mod) - (map (lambda (e) (expand e r w mod)) (append tail (list val))))))))) - tmp) - (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) - (global-extend - 'module-ref - '@ - (lambda (e r w mod) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any)))) - (if (and tmp (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp)) - (apply (lambda (mod id) - (values - (syntax->datum id) - r - top-wrap - #f - (syntax->datum (cons (make-syntax 'public '((top)) '(hygiene guile)) mod)))) - tmp) - (syntax-violation #f "source expression failed to match any pattern" tmp-1))))) - (global-extend - 'module-ref - '@@ - (lambda (e r w mod) - (letrec* ((remodulate - (lambda (x mod) - (cond - ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod))) - ((syntax? x) - (make-syntax (remodulate (syntax-expression x) mod) (syntax-wrap x) mod (syntax-sourcev x))) - ((vector? x) - (let* ((n (vector-length x)) (v (make-vector n))) - (let loop ((i 0)) - (if (= i n) - (begin (if #f #f) v) - (begin (vector-set! v i (remodulate (vector-ref x i) mod)) (loop (#{1+}# i))))))) - (else x))))) - (let* ((tmp e) - (tmp-1 ($sc-dispatch - tmp - (list '_ (vector 'free-id (make-syntax 'primitive '((top)) '(hygiene guile))) 'any)))) - (if (and tmp-1 - (apply (lambda (id) - (and (id? id) (equal? (cdr (or (and (syntax? id) (syntax-module id)) mod)) '(guile)))) - tmp-1)) - (apply (lambda (id) (values (syntax->datum id) r top-wrap #f '(primitive))) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any)))) - (if (and tmp-1 (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1)) + (lambda () (expand-lambda-case e r w s mod lambda-formals clauses)) + (lambda (meta* lcase) (build-case-lambda s (append meta meta*) lcase)))))) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) + (if tmp + (apply (lambda (args e1 e2) + (build-it + '() + (map (lambda (tmp-680b775fb37a463-113f + tmp-680b775fb37a463-113e + tmp-680b775fb37a463-113d) + (cons tmp-680b775fb37a463-113d + (cons tmp-680b775fb37a463-113e tmp-680b775fb37a463-113f))) + e2 + e1 + args))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) + (if (and tmp (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) tmp)) + (apply (lambda (docstring args e1 e2) + (build-it + (list (cons 'documentation (syntax->datum docstring))) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (cons tmp-680b775fb37a463 + (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) + e2 + e1 + args))) + tmp) + (syntax-violation 'case-lambda "bad case-lambda" e)))))))) + (expand-case-lambda* + (lambda (e r w s mod) + (letrec* ((build-it + (lambda (meta clauses) + (call-with-values + (lambda () (expand-lambda-case e r w s mod lambda*-formals clauses)) + (lambda (meta* lcase) (build-case-lambda s (append meta meta*) lcase)))))) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) + (if tmp + (apply (lambda (args e1 e2) + (build-it + '() + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) + e2 + e1 + args))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) + (if (and tmp (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) tmp)) + (apply (lambda (docstring args e1 e2) + (build-it + (list (cons 'documentation (syntax->datum docstring))) + (map (lambda (tmp-680b775fb37a463-118b + tmp-680b775fb37a463-118a + tmp-680b775fb37a463) + (cons tmp-680b775fb37a463 + (cons tmp-680b775fb37a463-118a tmp-680b775fb37a463-118b))) + e2 + e1 + args))) + tmp) + (syntax-violation 'case-lambda "bad case-lambda*" e)))))))) + (expand-with-ellipsis + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) + (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp)) + (apply (lambda (dots e1 e2) + (let ((id (if (symbol? dots) + '#{ $sc-ellipsis }# + (make-syntax + '#{ $sc-ellipsis }# + (syntax-wrap dots) + (syntax-module dots) + (syntax-sourcev dots))))) + (let ((ids (list id)) + (labels (list (gen-label))) + (bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) + (let ((nw (make-binding-wrap ids labels w)) (nr (extend-env labels bindings r))) + (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod))))) + tmp) + (syntax-violation 'with-ellipsis "bad syntax" (source-wrap e w s mod)))))) + (expand-let + (letrec* ((expand-let + (lambda (e r w s mod constructor ids vals exps) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'let "duplicate bound variable" e) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (let ((nw (make-binding-wrap ids labels w)) (nr (extend-var-env labels new-vars r))) + (constructor + s + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) vals) + (expand-body exps (source-wrap e nw s mod) nr nw mod)))))))) + (lambda (e r w s mod) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) + (apply (lambda (id val e1 e2) (expand-let e r w s mod build-let id val (cons e1 e2))) tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp)) + (apply (lambda (f id val e1 e2) + (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2))) + tmp) + (syntax-violation 'let "bad let" (source-wrap e w s mod))))))))) + (expand-letrec + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) + (apply (lambda (id val e1 e2) + (let ((ids id)) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'letrec "duplicate bound variable" e) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) (r (extend-var-env labels new-vars r))) + (build-letrec + s + #f + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) val) + (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) + tmp) + (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) + (expand-letrec* + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) + (apply (lambda (id val e1 e2) + (let ((ids id)) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'letrec* "duplicate bound variable" e) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) (r (extend-var-env labels new-vars r))) + (build-letrec + s + #t + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) val) + (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) + tmp) + (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) + (expand-set! + (lambda (e r w s mod) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) + (if (and tmp (apply (lambda (id val) (id? id)) tmp)) + (apply (lambda (id val) + (call-with-values + (lambda () (resolve-identifier id w r mod #t)) + (lambda (type value id-mod) + (let ((key type)) + (cond + ((memv key '(lexical)) + (build-lexical-assignment s (syntax->datum id) value (expand val r w mod))) + ((memv key '(global)) + (build-global-assignment s value (expand val r w mod) id-mod)) + ((memv key '(macro)) + (if (procedure-property value 'variable-transformer) + (expand (expand-macro value e r w s #f mod) r empty-wrap mod) + (syntax-violation + 'set! + "not a variable transformer" + (wrap e w mod) + (wrap id w id-mod)))) + ((memv key '(displaced-lexical)) + (syntax-violation 'set! "identifier out of context" (wrap id w mod))) + (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any)))) + (if tmp + (apply (lambda (head tail val) + (call-with-values + (lambda () (syntax-type head r empty-wrap no-source #f mod #t)) + (lambda (type value ee* ee ww ss modmod) + (let ((key type)) + (if (memv key '(module-ref)) + (let ((val (expand val r w mod))) + (call-with-values + (lambda () (value (cons head tail) r w mod)) + (lambda (e r w s* mod) + (let* ((tmp-1 e) (tmp (list tmp-1))) + (if (and tmp (apply (lambda (e) (id? e)) tmp)) + (apply (lambda (e) + (build-global-assignment s (syntax->datum e) val mod)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))) + (build-call + s + (expand + (list (make-syntax 'setter '((top)) '(hygiene guile)) head) + r + w + mod) + (map (lambda (e) (expand e r w mod)) (append tail (list val))))))))) + tmp) + (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) + (expand-public-ref + (lambda (e r w mod) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any)))) + (if (and tmp (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp)) (apply (lambda (mod id) (values (syntax->datum id) r top-wrap #f - (syntax->datum (cons (make-syntax 'private '((top)) '(hygiene guile)) mod)))) + (syntax->datum (cons (make-syntax 'public '((top)) '(hygiene guile)) mod)))) + tmp) + (syntax-violation #f "source expression failed to match any pattern" tmp-1))))) + (expand-private-ref + (lambda (e r w mod) + (letrec* ((remodulate + (lambda (x mod) + (cond + ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod))) + ((syntax? x) + (make-syntax + (remodulate (syntax-expression x) mod) + (syntax-wrap x) + mod + (syntax-sourcev x))) + ((vector? x) + (let* ((n (vector-length x)) (v (make-vector n))) + (let loop ((i 0)) + (if (= i n) + (begin (if #f #f) v) + (begin (vector-set! v i (remodulate (vector-ref x i) mod)) (loop (#{1+}# i))))))) + (else x))))) + (let* ((tmp e) + (tmp-1 ($sc-dispatch + tmp + (list '_ (vector 'free-id (make-syntax 'primitive '((top)) '(hygiene guile))) 'any)))) + (if (and tmp-1 + (apply (lambda (id) + (and (id? id) + (equal? (cdr (or (and (syntax? id) (syntax-module id)) mod)) '(guile)))) + tmp-1)) + (apply (lambda (id) (values (syntax->datum id) r top-wrap #f '(primitive))) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any)))) + (if (and tmp-1 (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1)) + (apply (lambda (mod id) + (values + (syntax->datum id) + r + top-wrap + #f + (syntax->datum (cons (make-syntax 'private '((top)) '(hygiene guile)) mod)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch + tmp + (list '_ + (vector 'free-id (make-syntax '@@ '((top)) '(hygiene guile))) + 'each-any + 'any)))) + (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1)) + (apply (lambda (mod exp) + (let ((mod (syntax->datum + (cons (make-syntax 'private '((top)) '(hygiene guile)) mod)))) + (values (remodulate exp mod) r w (source-annotation exp) mod))) + tmp-1) + (syntax-violation #f "source expression failed to match any pattern" tmp)))))))))) + (expand-if + (lambda (e r w s mod) + (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) + (if tmp-1 + (apply (lambda (test then) + (build-conditional s (expand test r w mod) (expand then r w mod) (build-void no-source))) tmp-1) - (let ((tmp-1 ($sc-dispatch - tmp - (list '_ - (vector 'free-id (make-syntax '@@ '((top)) '(hygiene guile))) - 'each-any - 'any)))) - (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1)) - (apply (lambda (mod exp) - (let ((mod (syntax->datum - (cons (make-syntax 'private '((top)) '(hygiene guile)) mod)))) - (values (remodulate exp mod) r w (source-annotation exp) mod))) + (let ((tmp-1 ($sc-dispatch tmp '(_ any any any)))) + (if tmp-1 + (apply (lambda (test then else) + (build-conditional + s + (expand test r w mod) + (expand then r w mod) + (expand else r w mod))) tmp-1) - (syntax-violation #f "source expression failed to match any pattern" tmp)))))))))) - (global-extend - 'core - 'if - (lambda (e r w s mod) - (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) - (if tmp-1 - (apply (lambda (test then) - (build-conditional s (expand test r w mod) (expand then r w mod) (build-void no-source))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ any any any)))) - (if tmp-1 - (apply (lambda (test then else) - (build-conditional s (expand test r w mod) (expand then r w mod) (expand else r w mod))) - tmp-1) - (syntax-violation #f "source expression failed to match any pattern" tmp))))))) + (syntax-violation #f "source expression failed to match any pattern" tmp))))))) + (expand-syntax-case + (letrec* ((convert-pattern + (lambda (pattern keys ellipsis?) + (letrec* ((cvt* (lambda (p* n ids) + (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any)))) + (if tmp + (apply (lambda (x y) + (call-with-values + (lambda () (cvt* y n ids)) + (lambda (y ids) + (call-with-values + (lambda () (cvt x n ids)) + (lambda (x ids) (values (cons x y) ids)))))) + tmp) + (cvt p* n ids))))) + (v-reverse + (lambda (x) + (let loop ((r '()) (x x)) + (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x)))))) + (cvt (lambda (p n ids) + (if (id? p) + (cond + ((bound-id-member? p keys) (values (vector 'free-id p) ids)) + ((free-id=? p (make-syntax '_ '((top)) '(hygiene guile))) + (values '_ ids)) + (else (values 'any (cons (cons p n) ids)))) + (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1)) + (apply (lambda (x dots) + (call-with-values + (lambda () (cvt x (#{1+}# n) ids)) + (lambda (p ids) + (values + (if (eq? p 'any) 'each-any (vector 'each p)) + ids)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) + (if (and tmp-1 + (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1)) + (apply (lambda (x dots ys) + (call-with-values + (lambda () (cvt* ys n ids)) + (lambda (ys ids) + (call-with-values + (lambda () (cvt x (+ n 1) ids)) + (lambda (x ids) + (call-with-values + (lambda () (v-reverse ys)) + (lambda (ys e) + (values (vector 'each+ x ys e) ids)))))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if tmp-1 + (apply (lambda (x y) + (call-with-values + (lambda () (cvt y n ids)) + (lambda (y ids) + (call-with-values + (lambda () (cvt x n ids)) + (lambda (x ids) (values (cons x y) ids)))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (values '() ids)) tmp-1) + (let ((tmp-1 ($sc-dispatch + tmp + '#(vector each-any)))) + (if tmp-1 + (apply (lambda (x) + (call-with-values + (lambda () (cvt x n ids)) + (lambda (p ids) + (values (vector 'vector p) ids)))) + tmp-1) + (let ((x tmp)) + (values (vector 'atom (strip p)) ids)))))))))))))))) + (cvt pattern 0 '())))) + (build-dispatch-call + (lambda (pvars exp y r mod) + (let ((ids (map car pvars)) (levels (map cdr pvars))) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (build-primcall + no-source + 'apply + (list (build-simple-lambda + no-source + (map syntax->datum ids) + #f + new-vars + '() + (expand + exp + (extend-env + labels + (map (lambda (var level) (cons 'syntax (cons var level))) + new-vars + (map cdr pvars)) + r) + (make-binding-wrap ids labels empty-wrap) + mod)) + y)))))) + (gen-clause + (lambda (x keys clauses r pat fender exp mod) + (call-with-values + (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) + (lambda (p pvars) + (cond + ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) + (syntax-violation 'syntax-case "misplaced ellipsis" pat)) + ((not (distinct-bound-ids? (map car pvars))) + (syntax-violation 'syntax-case "duplicate pattern variable" pat)) + (else (let ((y (gen-var 'tmp))) + (build-call + no-source + (build-simple-lambda + no-source + (list 'tmp) + #f + (list y) + '() + (let ((y (build-lexical-reference no-source 'tmp y))) + (build-conditional + no-source + (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t)))) + (if tmp + (apply (lambda () y) tmp) + (build-conditional + no-source + y + (build-dispatch-call pvars fender y r mod) + (build-data no-source #f)))) + (build-dispatch-call pvars exp y r mod) + (gen-syntax-case x keys clauses r mod)))) + (list (if (eq? p 'any) + (build-primcall no-source 'list (list x)) + (build-primcall + no-source + '$sc-dispatch + (list x (build-data no-source p))))))))))))) + (gen-syntax-case + (lambda (x keys clauses r mod) + (if (null? clauses) + (build-primcall + no-source + 'syntax-violation + (list (build-data no-source #f) + (build-data no-source "source expression failed to match any pattern") + x)) + (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any)))) + (if tmp + (apply (lambda (pat exp) + (if (and (id? pat) + (and-map + (lambda (x) (not (free-id=? pat x))) + (cons (make-syntax '... '((top)) '(hygiene guile)) keys))) + (if (free-id=? pat (make-syntax '_ '((top)) '(hygiene guile))) + (expand exp r empty-wrap mod) + (let ((labels (list (gen-label))) (var (gen-var pat))) + (build-call + no-source + (build-simple-lambda + no-source + (list (syntax->datum pat)) + #f + (list var) + '() + (expand + exp + (extend-env labels (list (cons 'syntax (cons var 0))) r) + (make-binding-wrap (list pat) labels empty-wrap) + mod)) + (list x)))) + (gen-clause x keys (cdr clauses) r pat #t exp mod))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(any any any)))) + (if tmp + (apply (lambda (pat fender exp) + (gen-clause x keys (cdr clauses) r pat fender exp mod)) + tmp) + (syntax-violation 'syntax-case "invalid clause" (car clauses)))))))))) + (lambda (e r w s mod) + (let* ((e (source-wrap e w s mod)) (tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any)))) + (if tmp + (apply (lambda (val key m) + (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key) + (let ((x (gen-var 'tmp))) + (build-call + s + (build-simple-lambda + no-source + (list 'tmp) + #f + (list x) + '() + (gen-syntax-case (build-lexical-reference no-source 'tmp x) key m r mod)) + (list (expand val r empty-wrap mod)))) + (syntax-violation 'syntax-case "invalid literals list" e))) + tmp) + (syntax-violation #f "source expression failed to match any pattern" tmp-1))))))) + (global-extend 'local-syntax 'letrec-syntax #t) + (global-extend 'local-syntax 'let-syntax #f) + (global-extend 'core 'syntax-parameterize expand-syntax-parameterize) + (global-extend 'core 'quote expand-quote) + (global-extend 'core 'quote-syntax expand-quote-syntax) + (global-extend 'core 'syntax expand-syntax) + (global-extend 'core 'lambda expand-lambda) + (global-extend 'core 'lambda* expand-lambda*) + (global-extend 'core 'case-lambda expand-case-lambda) + (global-extend 'core 'case-lambda* expand-case-lambda*) + (global-extend 'core 'with-ellipsis expand-with-ellipsis) + (global-extend 'core 'let expand-let) + (global-extend 'core 'letrec expand-letrec) + (global-extend 'core 'letrec* expand-letrec*) + (global-extend 'core 'set! expand-set!) + (global-extend 'module-ref '@ expand-public-ref) + (global-extend 'module-ref '@@ expand-private-ref) + (global-extend 'core 'if expand-if) (global-extend 'begin 'begin '()) (global-extend 'define 'define '()) (global-extend 'define-syntax 'define-syntax '()) (global-extend 'define-syntax-parameter 'define-syntax-parameter '()) (global-extend 'eval-when 'eval-when '()) - (global-extend - 'core - 'syntax-case - (letrec* ((convert-pattern - (lambda (pattern keys ellipsis?) - (letrec* ((cvt* (lambda (p* n ids) - (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any)))) - (if tmp - (apply (lambda (x y) - (call-with-values - (lambda () (cvt* y n ids)) - (lambda (y ids) - (call-with-values - (lambda () (cvt x n ids)) - (lambda (x ids) (values (cons x y) ids)))))) - tmp) - (cvt p* n ids))))) - (v-reverse - (lambda (x) - (let loop ((r '()) (x x)) - (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x)))))) - (cvt (lambda (p n ids) - (if (id? p) - (cond - ((bound-id-member? p keys) (values (vector 'free-id p) ids)) - ((free-id=? p (make-syntax '_ '((top)) '(hygiene guile))) (values '_ ids)) - (else (values 'any (cons (cons p n) ids)))) - (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1)) - (apply (lambda (x dots) - (call-with-values - (lambda () (cvt x (#{1+}# n) ids)) - (lambda (p ids) - (values (if (eq? p 'any) 'each-any (vector 'each p)) ids)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) - (if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1)) - (apply (lambda (x dots ys) - (call-with-values - (lambda () (cvt* ys n ids)) - (lambda (ys ids) - (call-with-values - (lambda () (cvt x (+ n 1) ids)) - (lambda (x ids) - (call-with-values - (lambda () (v-reverse ys)) - (lambda (ys e) (values (vector 'each+ x ys e) ids)))))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if tmp-1 - (apply (lambda (x y) - (call-with-values - (lambda () (cvt y n ids)) - (lambda (y ids) - (call-with-values - (lambda () (cvt x n ids)) - (lambda (x ids) (values (cons x y) ids)))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (values '() ids)) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any)))) - (if tmp-1 - (apply (lambda (x) - (call-with-values - (lambda () (cvt x n ids)) - (lambda (p ids) - (values (vector 'vector p) ids)))) - tmp-1) - (let ((x tmp)) - (values (vector 'atom (strip p)) ids)))))))))))))))) - (cvt pattern 0 '())))) - (build-dispatch-call - (lambda (pvars exp y r mod) - (let ((ids (map car pvars)) (levels (map cdr pvars))) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (build-primcall - no-source - 'apply - (list (build-simple-lambda - no-source - (map syntax->datum ids) - #f - new-vars - '() - (expand - exp - (extend-env - labels - (map (lambda (var level) (cons 'syntax (cons var level))) new-vars (map cdr pvars)) - r) - (make-binding-wrap ids labels empty-wrap) - mod)) - y)))))) - (gen-clause - (lambda (x keys clauses r pat fender exp mod) - (call-with-values - (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) - (lambda (p pvars) - (cond - ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) - (syntax-violation 'syntax-case "misplaced ellipsis" pat)) - ((not (distinct-bound-ids? (map car pvars))) - (syntax-violation 'syntax-case "duplicate pattern variable" pat)) - (else (let ((y (gen-var 'tmp))) - (build-call - no-source - (build-simple-lambda - no-source - (list 'tmp) - #f - (list y) - '() - (let ((y (build-lexical-reference no-source 'tmp y))) - (build-conditional - no-source - (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t)))) - (if tmp - (apply (lambda () y) tmp) - (build-conditional - no-source - y - (build-dispatch-call pvars fender y r mod) - (build-data no-source #f)))) - (build-dispatch-call pvars exp y r mod) - (gen-syntax-case x keys clauses r mod)))) - (list (if (eq? p 'any) - (build-primcall no-source 'list (list x)) - (build-primcall no-source '$sc-dispatch (list x (build-data no-source p))))))))))))) - (gen-syntax-case - (lambda (x keys clauses r mod) - (if (null? clauses) - (build-primcall - no-source - 'syntax-violation - (list (build-data no-source #f) - (build-data no-source "source expression failed to match any pattern") - x)) - (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any)))) - (if tmp - (apply (lambda (pat exp) - (if (and (id? pat) - (and-map - (lambda (x) (not (free-id=? pat x))) - (cons (make-syntax '... '((top)) '(hygiene guile)) keys))) - (if (free-id=? pat (make-syntax '_ '((top)) '(hygiene guile))) - (expand exp r empty-wrap mod) - (let ((labels (list (gen-label))) (var (gen-var pat))) - (build-call - no-source - (build-simple-lambda - no-source - (list (syntax->datum pat)) - #f - (list var) - '() - (expand - exp - (extend-env labels (list (cons 'syntax (cons var 0))) r) - (make-binding-wrap (list pat) labels empty-wrap) - mod)) - (list x)))) - (gen-clause x keys (cdr clauses) r pat #t exp mod))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(any any any)))) - (if tmp - (apply (lambda (pat fender exp) - (gen-clause x keys (cdr clauses) r pat fender exp mod)) - tmp) - (syntax-violation 'syntax-case "invalid clause" (car clauses)))))))))) - (lambda (e r w s mod) - (let* ((e (source-wrap e w s mod)) (tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any)))) - (if tmp - (apply (lambda (val key m) - (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key) - (let ((x (gen-var 'tmp))) - (build-call - s - (build-simple-lambda - no-source - (list 'tmp) - #f - (list x) - '() - (gen-syntax-case (build-lexical-reference no-source 'tmp x) key m r mod)) - (list (expand val r empty-wrap mod)))) - (syntax-violation 'syntax-case "invalid literals list" e))) - tmp) - (syntax-violation #f "source expression failed to match any pattern" tmp-1)))))) + (global-extend 'core 'syntax-case expand-syntax-case) (set! macroexpand (lambda* (x #:optional (m 'e) (esew '(eval))) (letrec* ((unstrip @@ -2802,9 +2838,8 @@ #f k (list docstring) - (map (lambda (tmp-680b775fb37a463 tmp-680b775fb37a463-145f tmp-680b775fb37a463-145e) - (list (cons tmp-680b775fb37a463-145e tmp-680b775fb37a463-145f) - tmp-680b775fb37a463)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2816,9 +2851,11 @@ dots k '() - (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) - tmp-680b775fb37a463-2)) + (map (lambda (tmp-680b775fb37a463-149b + tmp-680b775fb37a463-149a + tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-149a) + tmp-680b775fb37a463-149b)) template pattern keyword))) @@ -2834,11 +2871,11 @@ dots k (list docstring) - (map (lambda (tmp-680b775fb37a463-2 - tmp-680b775fb37a463-1 - tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) - tmp-680b775fb37a463-2)) + (map (lambda (tmp-680b775fb37a463-14ba + tmp-680b775fb37a463-14b9 + tmp-680b775fb37a463-14b8) + (list (cons tmp-680b775fb37a463-14b8 tmp-680b775fb37a463-14b9) + tmp-680b775fb37a463-14ba)) template pattern keyword))) @@ -2993,9 +3030,9 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-154a) + (map (lambda (tmp-680b775fb37a463-156c) (list "value" - tmp-680b775fb37a463-154a)) + tmp-680b775fb37a463-156c)) p) (quasi q lev)) (quasicons @@ -3135,8 +3172,8 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-15ae) - (cons "vector" t-680b775fb37a463-15ae)) + (apply (lambda (t-680b775fb37a463-15d0) + (cons "vector" t-680b775fb37a463-15d0)) tmp) (syntax-violation #f @@ -3146,8 +3183,8 @@ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (if tmp-1 (apply (lambda (y) - (k (map (lambda (tmp-680b775fb37a463-15ba) - (list "quote" tmp-680b775fb37a463-15ba)) + (k (map (lambda (tmp-680b775fb37a463-15dc) + (list "quote" tmp-680b775fb37a463-15dc)) y))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) @@ -3158,8 +3195,8 @@ (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (let ((else tmp)) (let ((tmp x)) - (let ((t-680b775fb37a463-15c9 tmp)) - (list "list->vector" t-680b775fb37a463-15c9))))))))))))))))) + (let ((t-680b775fb37a463-15eb tmp)) + (list "list->vector" t-680b775fb37a463-15eb))))))))))))))))) (emit (lambda (x) (let ((tmp x)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) @@ -3171,9 +3208,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-15d8) + (apply (lambda (t-680b775fb37a463-15fa) (cons (make-syntax 'list '((top)) '(hygiene guile)) - t-680b775fb37a463-15d8)) + t-680b775fb37a463-15fa)) tmp) (syntax-violation #f @@ -3189,14 +3226,14 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-680b775fb37a463-15ec - t-680b775fb37a463-15eb) + (apply (lambda (t-680b775fb37a463-160e + t-680b775fb37a463-160d) (list (make-syntax 'cons '((top)) '(hygiene guile)) - t-680b775fb37a463-15ec - t-680b775fb37a463-15eb)) + t-680b775fb37a463-160e + t-680b775fb37a463-160d)) tmp) (syntax-violation #f @@ -3209,12 +3246,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-15f8) + (apply (lambda (t-680b775fb37a463-161a) (cons (make-syntax 'append '((top)) '(hygiene guile)) - t-680b775fb37a463-15f8)) + t-680b775fb37a463-161a)) tmp) (syntax-violation #f diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 110d46da5..147f2ff84 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1934,686 +1934,679 @@ ;; core transformers - (global-extend 'local-syntax 'letrec-syntax #t) - (global-extend 'local-syntax 'let-syntax #f) + (define (expand-syntax-parameterize e r w s mod) + (syntax-case e () + ((_ ((var val) ...) e1 e2 ...) + (valid-bound-ids? #'(var ...)) + (let ((names + (map (lambda (x) + (call-with-values + (lambda () (resolve-identifier x w r mod #f)) + (lambda (type value mod) + (case type + ((displaced-lexical) + (syntax-violation 'syntax-parameterize + "identifier out of context" + e + (source-wrap x w s mod))) + ((syntax-parameter) + value) + (else + (syntax-violation 'syntax-parameterize + "invalid syntax parameter" + e + (source-wrap x w s mod))))))) + #'(var ...))) + (bindings + (let ((trans-r (macros-only-env r))) + (map (lambda (x) + (make-binding + 'syntax-parameter + (eval-local-transformer (expand x trans-r w mod) mod))) + #'(val ...))))) + (expand-body #'(e1 e2 ...) + (source-wrap e w s mod) + (extend-env names bindings r) + w + mod))) + (_ (syntax-violation 'syntax-parameterize "bad syntax" + (source-wrap e w s mod))))) - (global-extend - 'core 'syntax-parameterize - (lambda (e r w s mod) - (syntax-case e () - ((_ ((var val) ...) e1 e2 ...) - (valid-bound-ids? #'(var ...)) - (let ((names - (map (lambda (x) - (call-with-values - (lambda () (resolve-identifier x w r mod #f)) - (lambda (type value mod) - (case type - ((displaced-lexical) - (syntax-violation 'syntax-parameterize - "identifier out of context" - e - (source-wrap x w s mod))) - ((syntax-parameter) - value) - (else - (syntax-violation 'syntax-parameterize - "invalid syntax parameter" - e - (source-wrap x w s mod))))))) - #'(var ...))) - (bindings - (let ((trans-r (macros-only-env r))) - (map (lambda (x) - (make-binding - 'syntax-parameter - (eval-local-transformer (expand x trans-r w mod) mod))) - #'(val ...))))) - (expand-body #'(e1 e2 ...) - (source-wrap e w s mod) - (extend-env names bindings r) - w - mod))) - (_ (syntax-violation 'syntax-parameterize "bad syntax" - (source-wrap e w s mod)))))) - - (global-extend 'core 'quote - (lambda (e r w s mod) - (syntax-case e () - ((_ e) (build-data s (strip #'e))) - (_ (syntax-violation 'quote "bad syntax" - (source-wrap e w s mod)))))) + (define (expand-quote e r w s mod) + (syntax-case e () + ((_ e) (build-data s (strip #'e))) + (_ (syntax-violation 'quote "bad syntax" + (source-wrap e w s mod))))) - (global-extend 'core 'quote-syntax - (lambda (e r w s mod) - (syntax-case (source-wrap e w s mod) () - ((_ e) (build-data s #'e)) - (e (syntax-violation 'quote "bad syntax" #'e))))) - - (global-extend - 'core 'syntax - (let () - (define (gen-syntax src e r maps ellipsis? mod) - (if (id? e) - (call-with-values (lambda () - (resolve-identifier e empty-wrap r mod #f)) - (lambda (type value mod) - (case type - ((syntax) - (call-with-values - (lambda () (gen-ref src (car value) (cdr value) maps)) - (lambda (var maps) - (values `(ref ,var) maps)))) - (else - (if (ellipsis? e r mod) - (syntax-violation 'syntax "misplaced ellipsis" src) - (values `(quote ,e) maps)))))) - (syntax-case e () - ((dots e) - (ellipsis? #'dots r mod) - (gen-syntax src #'e r maps (lambda (e r mod) #f) mod)) - ((x dots . y) - ;; this could be about a dozen lines of code, except that we - ;; choose to handle #'(x ... ...) forms - (ellipsis? #'dots r mod) - (let f ((y #'y) - (k (lambda (maps) - (call-with-values - (lambda () - (gen-syntax src #'x r - (cons '() maps) ellipsis? mod)) - (lambda (x maps) - (if (null? (car maps)) - (syntax-violation 'syntax "extra ellipsis" - src) - (values (gen-map x (car maps)) - (cdr maps)))))))) - (syntax-case y () - ((dots . y) - (ellipsis? #'dots r mod) - (f #'y - (lambda (maps) - (call-with-values - (lambda () (k (cons '() maps))) - (lambda (x maps) - (if (null? (car maps)) - (syntax-violation 'syntax "extra ellipsis" src) - (values (gen-mappend x (car maps)) - (cdr maps)))))))) - (_ (call-with-values - (lambda () (gen-syntax src y r maps ellipsis? mod)) - (lambda (y maps) + (define (expand-quote-syntax e r w s mod) + (syntax-case (source-wrap e w s mod) () + ((_ e) (build-data s #'e)) + (e (syntax-violation 'quote "bad syntax" #'e)))) + + (define expand-syntax + (let () + (define (gen-syntax src e r maps ellipsis? mod) + (if (id? e) + (call-with-values (lambda () + (resolve-identifier e empty-wrap r mod #f)) + (lambda (type value mod) + (case type + ((syntax) + (call-with-values + (lambda () (gen-ref src (car value) (cdr value) maps)) + (lambda (var maps) + (values `(ref ,var) maps)))) + (else + (if (ellipsis? e r mod) + (syntax-violation 'syntax "misplaced ellipsis" src) + (values `(quote ,e) maps)))))) + (syntax-case e () + ((dots e) + (ellipsis? #'dots r mod) + (gen-syntax src #'e r maps (lambda (e r mod) #f) mod)) + ((x dots . y) + ;; this could be about a dozen lines of code, except that we + ;; choose to handle #'(x ... ...) forms + (ellipsis? #'dots r mod) + (let f ((y #'y) + (k (lambda (maps) + (call-with-values + (lambda () + (gen-syntax src #'x r + (cons '() maps) ellipsis? mod)) + (lambda (x maps) + (if (null? (car maps)) + (syntax-violation 'syntax "extra ellipsis" + src) + (values (gen-map x (car maps)) + (cdr maps)))))))) + (syntax-case y () + ((dots . y) + (ellipsis? #'dots r mod) + (f #'y + (lambda (maps) (call-with-values - (lambda () (k maps)) + (lambda () (k (cons '() maps))) (lambda (x maps) - (values (gen-append x y) maps))))))))) - ((x . y) - (call-with-values - (lambda () (gen-syntax src #'x r maps ellipsis? mod)) - (lambda (x maps) - (call-with-values - (lambda () (gen-syntax src #'y r maps ellipsis? mod)) - (lambda (y maps) (values (gen-cons x y) maps)))))) - (#(e1 e2 ...) - (call-with-values - (lambda () - (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod)) - (lambda (e maps) (values (gen-vector e) maps)))) - (x (eq? (syntax->datum #'x) #nil) (values '(quote #nil) maps)) - (() (values '(quote ()) maps)) - (_ (values `(quote ,e) maps))))) - - (define (gen-ref src var level maps) - (if (= level 0) - (values var maps) - (if (null? maps) - (syntax-violation 'syntax "missing ellipsis" src) + (if (null? (car maps)) + (syntax-violation 'syntax "extra ellipsis" src) + (values (gen-mappend x (car maps)) + (cdr maps)))))))) + (_ (call-with-values + (lambda () (gen-syntax src y r maps ellipsis? mod)) + (lambda (y maps) + (call-with-values + (lambda () (k maps)) + (lambda (x maps) + (values (gen-append x y) maps))))))))) + ((x . y) (call-with-values - (lambda () (gen-ref src var (1- level) (cdr maps))) - (lambda (outer-var outer-maps) - (let ((b (assq outer-var (car maps)))) - (if b - (values (cdr b) maps) - (let ((inner-var (gen-var 'tmp))) - (values inner-var - (cons (cons (cons outer-var inner-var) - (car maps)) - outer-maps)))))))))) - - (define (gen-mappend e map-env) - `(apply (primitive append) ,(gen-map e map-env))) - - (define (gen-map e map-env) - (let ((formals (map cdr map-env)) - (actuals (map (lambda (x) `(ref ,(car x))) map-env))) - (cond - ((eq? (car e) 'ref) - ;; identity map equivalence: - ;; (map (lambda (x) x) y) == y - (car actuals)) - ((and-map - (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) - (cdr e)) - ;; eta map equivalence: - ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...) - `(map (primitive ,(car e)) - ,@(map (let ((r (map cons formals actuals))) - (lambda (x) (cdr (assq (cadr x) r)))) - (cdr e)))) - (else `(map (lambda ,formals ,e) ,@actuals))))) - - (define (gen-cons x y) - (case (car y) - ((quote) - (if (eq? (car x) 'quote) - `(quote (,(cadr x) . ,(cadr y))) - (if (eq? (cadr y) '()) - `(list ,x) - `(cons ,x ,y)))) - ((list) `(list ,x ,@(cdr y))) - (else `(cons ,x ,y)))) - - (define (gen-append x y) - (if (equal? y '(quote ())) - x - `(append ,x ,y))) - - (define (gen-vector x) - (cond - ((eq? (car x) 'list) `(vector ,@(cdr x))) - ((eq? (car x) 'quote) `(quote #(,@(cadr x)))) - (else `(list->vector ,x)))) - - - (define (regen x) - (case (car x) - ((ref) (build-lexical-reference no-source (cadr x) (cadr x))) - ((primitive) (build-primref no-source (cadr x))) - ((quote) (build-data no-source (cadr x))) - ((lambda) - (if (list? (cadr x)) - (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x))) - (error "how did we get here" x))) - (else (build-primcall no-source (car x) (map regen (cdr x)))))) - - (lambda (e r w s mod) - (let ((e (source-wrap e w s mod))) - (syntax-case e () - ((_ x) - (call-with-values - (lambda () (gen-syntax e #'x r '() ellipsis? mod)) - (lambda (e maps) (regen e)))) - (_ (syntax-violation 'syntax "bad `syntax' form" e))))))) - - (global-extend 'core 'lambda - (lambda (e r w s mod) - (syntax-case e () - ((_ args e1 e2 ...) - (call-with-values (lambda () (lambda-formals #'args)) - (lambda (req opt rest kw) - (let lp ((body #'(e1 e2 ...)) (meta '())) - (syntax-case body () - ((docstring e1 e2 ...) (string? (syntax->datum #'docstring)) - (lp #'(e1 e2 ...) - (append meta - `((documentation - . ,(syntax->datum #'docstring)))))) - ((#((k . v) ...) e1 e2 ...) - (lp #'(e1 e2 ...) - (append meta (syntax->datum #'((k . v) ...))))) - (_ (expand-simple-lambda e r w s mod req rest meta body))))))) - (_ (syntax-violation 'lambda "bad lambda" e))))) + (lambda () (gen-syntax src #'x r maps ellipsis? mod)) + (lambda (x maps) + (call-with-values + (lambda () (gen-syntax src #'y r maps ellipsis? mod)) + (lambda (y maps) (values (gen-cons x y) maps)))))) + (#(e1 e2 ...) + (call-with-values + (lambda () + (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod)) + (lambda (e maps) (values (gen-vector e) maps)))) + (x (eq? (syntax->datum #'x) #nil) (values '(quote #nil) maps)) + (() (values '(quote ()) maps)) + (_ (values `(quote ,e) maps))))) + + (define (gen-ref src var level maps) + (if (= level 0) + (values var maps) + (if (null? maps) + (syntax-violation 'syntax "missing ellipsis" src) + (call-with-values + (lambda () (gen-ref src var (1- level) (cdr maps))) + (lambda (outer-var outer-maps) + (let ((b (assq outer-var (car maps)))) + (if b + (values (cdr b) maps) + (let ((inner-var (gen-var 'tmp))) + (values inner-var + (cons (cons (cons outer-var inner-var) + (car maps)) + outer-maps)))))))))) + + (define (gen-mappend e map-env) + `(apply (primitive append) ,(gen-map e map-env))) + + (define (gen-map e map-env) + (let ((formals (map cdr map-env)) + (actuals (map (lambda (x) `(ref ,(car x))) map-env))) + (cond + ((eq? (car e) 'ref) + ;; identity map equivalence: + ;; (map (lambda (x) x) y) == y + (car actuals)) + ((and-map + (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) + (cdr e)) + ;; eta map equivalence: + ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...) + `(map (primitive ,(car e)) + ,@(map (let ((r (map cons formals actuals))) + (lambda (x) (cdr (assq (cadr x) r)))) + (cdr e)))) + (else `(map (lambda ,formals ,e) ,@actuals))))) + + (define (gen-cons x y) + (case (car y) + ((quote) + (if (eq? (car x) 'quote) + `(quote (,(cadr x) . ,(cadr y))) + (if (eq? (cadr y) '()) + `(list ,x) + `(cons ,x ,y)))) + ((list) `(list ,x ,@(cdr y))) + (else `(cons ,x ,y)))) + + (define (gen-append x y) + (if (equal? y '(quote ())) + x + `(append ,x ,y))) + + (define (gen-vector x) + (cond + ((eq? (car x) 'list) `(vector ,@(cdr x))) + ((eq? (car x) 'quote) `(quote #(,@(cadr x)))) + (else `(list->vector ,x)))) + + + (define (regen x) + (case (car x) + ((ref) (build-lexical-reference no-source (cadr x) (cadr x))) + ((primitive) (build-primref no-source (cadr x))) + ((quote) (build-data no-source (cadr x))) + ((lambda) + (if (list? (cadr x)) + (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x))) + (error "how did we get here" x))) + (else (build-primcall no-source (car x) (map regen (cdr x)))))) + + (lambda (e r w s mod) + (let ((e (source-wrap e w s mod))) + (syntax-case e () + ((_ x) + (call-with-values + (lambda () (gen-syntax e #'x r '() ellipsis? mod)) + (lambda (e maps) (regen e)))) + (_ (syntax-violation 'syntax "bad `syntax' form" e))))))) + + (define (expand-lambda e r w s mod) + (syntax-case e () + ((_ args e1 e2 ...) + (call-with-values (lambda () (lambda-formals #'args)) + (lambda (req opt rest kw) + (let lp ((body #'(e1 e2 ...)) (meta '())) + (syntax-case body () + ((docstring e1 e2 ...) (string? (syntax->datum #'docstring)) + (lp #'(e1 e2 ...) + (append meta + `((documentation + . ,(syntax->datum #'docstring)))))) + ((#((k . v) ...) e1 e2 ...) + (lp #'(e1 e2 ...) + (append meta (syntax->datum #'((k . v) ...))))) + (_ (expand-simple-lambda e r w s mod req rest meta body))))))) + (_ (syntax-violation 'lambda "bad lambda" e)))) - (global-extend 'core 'lambda* - (lambda (e r w s mod) - (syntax-case e () - ((_ args e1 e2 ...) - (call-with-values - (lambda () - (expand-lambda-case e r w s mod - lambda*-formals #'((args e1 e2 ...)))) - (lambda (meta lcase) - (build-case-lambda s meta lcase)))) - (_ (syntax-violation 'lambda "bad lambda*" e))))) + (define (expand-lambda* e r w s mod) + (syntax-case e () + ((_ args e1 e2 ...) + (call-with-values + (lambda () + (expand-lambda-case e r w s mod + lambda*-formals #'((args e1 e2 ...)))) + (lambda (meta lcase) + (build-case-lambda s meta lcase)))) + (_ (syntax-violation 'lambda "bad lambda*" e)))) + + (define (expand-case-lambda e r w s mod) + (define (build-it meta clauses) + (call-with-values + (lambda () + (expand-lambda-case e r w s mod + lambda-formals + clauses)) + (lambda (meta* lcase) + (build-case-lambda s (append meta meta*) lcase)))) + (syntax-case e () + ((_ (args e1 e2 ...) ...) + (build-it '() #'((args e1 e2 ...) ...))) + ((_ docstring (args e1 e2 ...) ...) + (string? (syntax->datum #'docstring)) + (build-it `((documentation + . ,(syntax->datum #'docstring))) + #'((args e1 e2 ...) ...))) + (_ (syntax-violation 'case-lambda "bad case-lambda" e)))) + + (define (expand-case-lambda* e r w s mod) + (define (build-it meta clauses) + (call-with-values + (lambda () + (expand-lambda-case e r w s mod + lambda*-formals + clauses)) + (lambda (meta* lcase) + (build-case-lambda s (append meta meta*) lcase)))) + (syntax-case e () + ((_ (args e1 e2 ...) ...) + (build-it '() #'((args e1 e2 ...) ...))) + ((_ docstring (args e1 e2 ...) ...) + (string? (syntax->datum #'docstring)) + (build-it `((documentation + . ,(syntax->datum #'docstring))) + #'((args e1 e2 ...) ...))) + (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))) - (global-extend 'core 'case-lambda - (lambda (e r w s mod) - (define (build-it meta clauses) - (call-with-values - (lambda () - (expand-lambda-case e r w s mod - lambda-formals - clauses)) - (lambda (meta* lcase) - (build-case-lambda s (append meta meta*) lcase)))) - (syntax-case e () - ((_ (args e1 e2 ...) ...) - (build-it '() #'((args e1 e2 ...) ...))) - ((_ docstring (args e1 e2 ...) ...) - (string? (syntax->datum #'docstring)) - (build-it `((documentation - . ,(syntax->datum #'docstring))) - #'((args e1 e2 ...) ...))) - (_ (syntax-violation 'case-lambda "bad case-lambda" e))))) - - (global-extend 'core 'case-lambda* - (lambda (e r w s mod) - (define (build-it meta clauses) - (call-with-values - (lambda () - (expand-lambda-case e r w s mod - lambda*-formals - clauses)) - (lambda (meta* lcase) - (build-case-lambda s (append meta meta*) lcase)))) - (syntax-case e () - ((_ (args e1 e2 ...) ...) - (build-it '() #'((args e1 e2 ...) ...))) - ((_ docstring (args e1 e2 ...) ...) - (string? (syntax->datum #'docstring)) - (build-it `((documentation - . ,(syntax->datum #'docstring))) - #'((args e1 e2 ...) ...))) - (_ (syntax-violation 'case-lambda "bad case-lambda*" e))))) - - (global-extend 'core 'with-ellipsis - (lambda (e r w s mod) - (syntax-case e () - ((_ dots e1 e2 ...) - (id? #'dots) - (let ((id (if (symbol? #'dots) - '#{ $sc-ellipsis }# - (make-syntax '#{ $sc-ellipsis }# - (syntax-wrap #'dots) - (syntax-module #'dots) - (syntax-sourcev #'dots))))) - (let ((ids (list id)) - (labels (list (gen-label))) - (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod))))) - (let ((nw (make-binding-wrap ids labels w)) - (nr (extend-env labels bindings r))) - (expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod))))) - (_ (syntax-violation 'with-ellipsis "bad syntax" - (source-wrap e w s mod)))))) - - (global-extend 'core 'let - (let () - (define (expand-let e r w s mod constructor ids vals exps) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'let "duplicate bound variable" e) - (let ((labels (gen-labels ids)) - (new-vars (map gen-var ids))) - (let ((nw (make-binding-wrap ids labels w)) - (nr (extend-var-env labels new-vars r))) - (constructor s - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) vals) - (expand-body exps (source-wrap e nw s mod) - nr nw mod)))))) - (lambda (e r w s mod) - (syntax-case e () - ((_ ((id val) ...) e1 e2 ...) - (and-map id? #'(id ...)) - (expand-let e r w s mod - build-let - #'(id ...) - #'(val ...) - #'(e1 e2 ...))) - ((_ f ((id val) ...) e1 e2 ...) - (and (id? #'f) (and-map id? #'(id ...))) - (expand-let e r w s mod - build-named-let - #'(f id ...) - #'(val ...) - #'(e1 e2 ...))) - (_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))) - - - (global-extend 'core 'letrec - (lambda (e r w s mod) - (syntax-case e () - ((_ ((id val) ...) e1 e2 ...) - (and-map id? #'(id ...)) - (let ((ids #'(id ...))) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'letrec "duplicate bound variable" e) - (let ((labels (gen-labels ids)) - (new-vars (map gen-var ids))) - (let ((w (make-binding-wrap ids labels w)) - (r (extend-var-env labels new-vars r))) - (build-letrec s #f - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) #'(val ...)) - (expand-body #'(e1 e2 ...) - (source-wrap e w s mod) r w mod))))))) - (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) - - - (global-extend 'core 'letrec* - (lambda (e r w s mod) - (syntax-case e () - ((_ ((id val) ...) e1 e2 ...) - (and-map id? #'(id ...)) - (let ((ids #'(id ...))) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'letrec* "duplicate bound variable" e) - (let ((labels (gen-labels ids)) - (new-vars (map gen-var ids))) - (let ((w (make-binding-wrap ids labels w)) - (r (extend-var-env labels new-vars r))) - (build-letrec s #t - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) #'(val ...)) - (expand-body #'(e1 e2 ...) - (source-wrap e w s mod) r w mod))))))) - (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) - - - (global-extend - 'core 'set! - (lambda (e r w s mod) - (syntax-case e () - ((_ id val) - (id? #'id) - (call-with-values - (lambda () (resolve-identifier #'id w r mod #t)) - (lambda (type value id-mod) - (case type - ((lexical) - (build-lexical-assignment s (syntax->datum #'id) value - (expand #'val r w mod))) - ((global) - (build-global-assignment s value (expand #'val r w mod) id-mod)) - ((macro) - (if (procedure-property value 'variable-transformer) - ;; As syntax-type does, call expand-macro with - ;; the mod of the expression. Hmm. - (expand (expand-macro value e r w s #f mod) r empty-wrap mod) - (syntax-violation 'set! "not a variable transformer" - (wrap e w mod) - (wrap #'id w id-mod)))) - ((displaced-lexical) - (syntax-violation 'set! "identifier out of context" - (wrap #'id w mod))) - (else - (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))) - ((_ (head tail ...) val) + (define (expand-with-ellipsis e r w s mod) + (syntax-case e () + ((_ dots e1 e2 ...) + (id? #'dots) + (let ((id (if (symbol? #'dots) + '#{ $sc-ellipsis }# + (make-syntax '#{ $sc-ellipsis }# + (syntax-wrap #'dots) + (syntax-module #'dots) + (syntax-sourcev #'dots))))) + (let ((ids (list id)) + (labels (list (gen-label))) + (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod))))) + (let ((nw (make-binding-wrap ids labels w)) + (nr (extend-env labels bindings r))) + (expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod))))) + (_ (syntax-violation 'with-ellipsis "bad syntax" + (source-wrap e w s mod))))) + + (define expand-let + (let () + (define (expand-let e r w s mod constructor ids vals exps) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'let "duplicate bound variable" e) + (let ((labels (gen-labels ids)) + (new-vars (map gen-var ids))) + (let ((nw (make-binding-wrap ids labels w)) + (nr (extend-var-env labels new-vars r))) + (constructor s + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) vals) + (expand-body exps (source-wrap e nw s mod) + nr nw mod)))))) + (lambda (e r w s mod) + (syntax-case e () + ((_ ((id val) ...) e1 e2 ...) + (and-map id? #'(id ...)) + (expand-let e r w s mod + build-let + #'(id ...) + #'(val ...) + #'(e1 e2 ...))) + ((_ f ((id val) ...) e1 e2 ...) + (and (id? #'f) (and-map id? #'(id ...))) + (expand-let e r w s mod + build-named-let + #'(f id ...) + #'(val ...) + #'(e1 e2 ...))) + (_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))) + + (define (expand-letrec e r w s mod) + (syntax-case e () + ((_ ((id val) ...) e1 e2 ...) + (and-map id? #'(id ...)) + (let ((ids #'(id ...))) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'letrec "duplicate bound variable" e) + (let ((labels (gen-labels ids)) + (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) + (r (extend-var-env labels new-vars r))) + (build-letrec s #f + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) #'(val ...)) + (expand-body #'(e1 e2 ...) + (source-wrap e w s mod) r w mod))))))) + (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))) + + (define (expand-letrec* e r w s mod) + (syntax-case e () + ((_ ((id val) ...) e1 e2 ...) + (and-map id? #'(id ...)) + (let ((ids #'(id ...))) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'letrec* "duplicate bound variable" e) + (let ((labels (gen-labels ids)) + (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) + (r (extend-var-env labels new-vars r))) + (build-letrec s #t + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) #'(val ...)) + (expand-body #'(e1 e2 ...) + (source-wrap e w s mod) r w mod))))))) + (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))) + + (define (expand-set! e r w s mod) + (syntax-case e () + ((_ id val) + (id? #'id) + (call-with-values + (lambda () (resolve-identifier #'id w r mod #t)) + (lambda (type value id-mod) + (case type + ((lexical) + (build-lexical-assignment s (syntax->datum #'id) value + (expand #'val r w mod))) + ((global) + (build-global-assignment s value (expand #'val r w mod) id-mod)) + ((macro) + (if (procedure-property value 'variable-transformer) + ;; As syntax-type does, call expand-macro with + ;; the mod of the expression. Hmm. + (expand (expand-macro value e r w s #f mod) r empty-wrap mod) + (syntax-violation 'set! "not a variable transformer" + (wrap e w mod) + (wrap #'id w id-mod)))) + ((displaced-lexical) + (syntax-violation 'set! "identifier out of context" + (wrap #'id w mod))) + (else + (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))) + ((_ (head tail ...) val) + (call-with-values + (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t)) + (lambda (type value ee* ee ww ss modmod) + (case type + ((module-ref) + (let ((val (expand #'val r w mod))) + (call-with-values (lambda () (value #'(head tail ...) r w mod)) + (lambda (e r w s* mod) + (syntax-case e () + (e (id? #'e) + (build-global-assignment s (syntax->datum #'e) + val mod))))))) + (else + (build-call s + (expand #'(setter head) r w mod) + (map (lambda (e) (expand e r w mod)) + #'(tail ... val)))))))) + (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))) + + (define (expand-public-ref e r w mod) + (syntax-case e () + ((_ (mod ...) id) + (and (and-map id? #'(mod ...)) (id? #'id)) + ;; Strip the wrap from the identifier and return top-wrap + ;; so that the identifier will not be captured by lexicals. + (values (syntax->datum #'id) r top-wrap #f + (syntax->datum + #'(public mod ...)))))) + + (define (expand-private-ref e r w mod) + (define (remodulate x mod) + (cond ((pair? x) + (cons (remodulate (car x) mod) + (remodulate (cdr x) mod))) + ((syntax? x) + (make-syntax + (remodulate (syntax-expression x) mod) + (syntax-wrap x) + ;; hither the remodulation + mod + (syntax-sourcev x))) + ((vector? x) + (let* ((n (vector-length x)) (v (make-vector n))) + (do ((i 0 (1+ i))) + ((= i n) v) + (vector-set! v i (remodulate (vector-ref x i) mod))))) + (else x))) + (syntax-case e (@@ primitive) + ((_ primitive id) + (and (id? #'id) + (equal? (cdr (or (and (syntax? #'id) + (syntax-module #'id)) + mod)) + '(guile))) + ;; Strip the wrap from the identifier and return top-wrap + ;; so that the identifier will not be captured by lexicals. + (values (syntax->datum #'id) r top-wrap #f '(primitive))) + ((_ (mod ...) id) + (and (and-map id? #'(mod ...)) (id? #'id)) + ;; Strip the wrap from the identifier and return top-wrap + ;; so that the identifier will not be captured by lexicals. + (values (syntax->datum #'id) r top-wrap #f + (syntax->datum + #'(private mod ...)))) + ((_ @@ (mod ...) exp) + (and-map id? #'(mod ...)) + ;; This is a special syntax used to support R6RS library forms. + ;; Unlike the syntax above, the last item is not restricted to + ;; be a single identifier, and the syntax objects are kept + ;; intact, with only their module changed. + (let ((mod (syntax->datum #'(private mod ...)))) + (values (remodulate #'exp mod) + r w (source-annotation #'exp) + mod))))) + + (define (expand-if e r w s mod) + (syntax-case e () + ((_ test then) + (build-conditional + s + (expand #'test r w mod) + (expand #'then r w mod) + (build-void no-source))) + ((_ test then else) + (build-conditional + s + (expand #'test r w mod) + (expand #'then r w mod) + (expand #'else r w mod))))) + + (define expand-syntax-case + (let () + (define (convert-pattern pattern keys ellipsis?) + ;; accepts pattern & keys + ;; returns $sc-dispatch pattern & ids + (define cvt* + (lambda (p* n ids) + (syntax-case p* () + ((x . y) + (call-with-values + (lambda () (cvt* #'y n ids)) + (lambda (y ids) + (call-with-values + (lambda () (cvt #'x n ids)) + (lambda (x ids) + (values (cons x y) ids)))))) + (_ (cvt p* n ids))))) + + (define (v-reverse x) + (let loop ((r '()) (x x)) + (if (not (pair? x)) + (values r x) + (loop (cons (car x) r) (cdr x))))) + + (define cvt + (lambda (p n ids) + (if (id? p) + (cond + ((bound-id-member? p keys) + (values (vector 'free-id p) ids)) + ((free-id=? p #'_) + (values '_ ids)) + (else + (values 'any (cons (cons p n) ids)))) + (syntax-case p () + ((x dots) + (ellipsis? (syntax dots)) + (call-with-values + (lambda () (cvt (syntax x) (1+ n) ids)) + (lambda (p ids) + (values (if (eq? p 'any) 'each-any (vector 'each p)) + ids)))) + ((x dots . ys) + (ellipsis? (syntax dots)) + (call-with-values + (lambda () (cvt* (syntax ys) n ids)) + (lambda (ys ids) + (call-with-values + (lambda () (cvt (syntax x) (+ n 1) ids)) + (lambda (x ids) + (call-with-values + (lambda () (v-reverse ys)) + (lambda (ys e) + (values `#(each+ ,x ,ys ,e) + ids)))))))) + ((x . y) + (call-with-values + (lambda () (cvt (syntax y) n ids)) + (lambda (y ids) + (call-with-values + (lambda () (cvt (syntax x) n ids)) + (lambda (x ids) + (values (cons x y) ids)))))) + (() (values '() ids)) + (#(x ...) + (call-with-values + (lambda () (cvt (syntax (x ...)) n ids)) + (lambda (p ids) (values (vector 'vector p) ids)))) + (x (values (vector 'atom (strip p)) ids)))))) + (cvt pattern 0 '())) + + (define (build-dispatch-call pvars exp y r mod) + (let ((ids (map car pvars)) (levels (map cdr pvars))) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (build-primcall + no-source + 'apply + (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '() + (expand exp + (extend-env + labels + (map (lambda (var level) + (make-binding 'syntax `(,var . ,level))) + new-vars + (map cdr pvars)) + r) + (make-binding-wrap ids labels empty-wrap) + mod)) + y))))) + + (define (gen-clause x keys clauses r pat fender exp mod) (call-with-values - (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t)) - (lambda (type value ee* ee ww ss modmod) - (case type - ((module-ref) - (let ((val (expand #'val r w mod))) - (call-with-values (lambda () (value #'(head tail ...) r w mod)) - (lambda (e r w s* mod) - (syntax-case e () - (e (id? #'e) - (build-global-assignment s (syntax->datum #'e) - val mod))))))) - (else - (build-call s - (expand #'(setter head) r w mod) - (map (lambda (e) (expand e r w mod)) - #'(tail ... val)))))))) - (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) - - (global-extend 'module-ref '@ - (lambda (e r w mod) - (syntax-case e () - ((_ (mod ...) id) - (and (and-map id? #'(mod ...)) (id? #'id)) - ;; Strip the wrap from the identifier and return top-wrap - ;; so that the identifier will not be captured by lexicals. - (values (syntax->datum #'id) r top-wrap #f - (syntax->datum - #'(public mod ...))))))) - - (global-extend 'module-ref '@@ - (lambda (e r w mod) - (define (remodulate x mod) - (cond ((pair? x) - (cons (remodulate (car x) mod) - (remodulate (cdr x) mod))) - ((syntax? x) - (make-syntax - (remodulate (syntax-expression x) mod) - (syntax-wrap x) - ;; hither the remodulation - mod - (syntax-sourcev x))) - ((vector? x) - (let* ((n (vector-length x)) (v (make-vector n))) - (do ((i 0 (1+ i))) - ((= i n) v) - (vector-set! v i (remodulate (vector-ref x i) mod))))) - (else x))) - (syntax-case e (@@ primitive) - ((_ primitive id) - (and (id? #'id) - (equal? (cdr (or (and (syntax? #'id) - (syntax-module #'id)) - mod)) - '(guile))) - ;; Strip the wrap from the identifier and return top-wrap - ;; so that the identifier will not be captured by lexicals. - (values (syntax->datum #'id) r top-wrap #f '(primitive))) - ((_ (mod ...) id) - (and (and-map id? #'(mod ...)) (id? #'id)) - ;; Strip the wrap from the identifier and return top-wrap - ;; so that the identifier will not be captured by lexicals. - (values (syntax->datum #'id) r top-wrap #f - (syntax->datum - #'(private mod ...)))) - ((_ @@ (mod ...) exp) - (and-map id? #'(mod ...)) - ;; This is a special syntax used to support R6RS library forms. - ;; Unlike the syntax above, the last item is not restricted to - ;; be a single identifier, and the syntax objects are kept - ;; intact, with only their module changed. - (let ((mod (syntax->datum #'(private mod ...)))) - (values (remodulate #'exp mod) - r w (source-annotation #'exp) - mod)))))) - - (global-extend 'core 'if - (lambda (e r w s mod) - (syntax-case e () - ((_ test then) - (build-conditional - s - (expand #'test r w mod) - (expand #'then r w mod) - (build-void no-source))) - ((_ test then else) - (build-conditional - s - (expand #'test r w mod) - (expand #'then r w mod) - (expand #'else r w mod)))))) + (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) + (lambda (p pvars) + (cond + ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) + (syntax-violation 'syntax-case "misplaced ellipsis" pat)) + ((not (distinct-bound-ids? (map car pvars))) + (syntax-violation 'syntax-case "duplicate pattern variable" pat)) + (else + (let ((y (gen-var 'tmp))) + ;; fat finger binding and references to temp variable y + (build-call no-source + (build-simple-lambda no-source (list 'tmp) #f (list y) '() + (let ((y (build-lexical-reference no-source 'tmp y))) + (build-conditional no-source + (syntax-case fender () + (#t y) + (_ (build-conditional no-source + y + (build-dispatch-call pvars fender y r mod) + (build-data no-source #f)))) + (build-dispatch-call pvars exp y r mod) + (gen-syntax-case x keys clauses r mod)))) + (list (if (eq? p 'any) + (build-primcall no-source 'list (list x)) + (build-primcall no-source '$sc-dispatch + (list x (build-data no-source p)))))))))))) + + (define (gen-syntax-case x keys clauses r mod) + (if (null? clauses) + (build-primcall no-source 'syntax-violation + (list (build-data no-source #f) + (build-data no-source + "source expression failed to match any pattern") + x)) + (syntax-case (car clauses) () + ((pat exp) + (if (and (id? #'pat) + (and-map (lambda (x) (not (free-id=? #'pat x))) + (cons #'(... ...) keys))) + (if (free-id=? #'pat #'_) + (expand #'exp r empty-wrap mod) + (let ((labels (list (gen-label))) + (var (gen-var #'pat))) + (build-call no-source + (build-simple-lambda + no-source (list (syntax->datum #'pat)) #f (list var) + '() + (expand #'exp + (extend-env labels + (list (make-binding 'syntax `(,var . 0))) + r) + (make-binding-wrap #'(pat) + labels empty-wrap) + mod)) + (list x)))) + (gen-clause x keys (cdr clauses) r + #'pat #t #'exp mod))) + ((pat fender exp) + (gen-clause x keys (cdr clauses) r + #'pat #'fender #'exp mod)) + (_ (syntax-violation 'syntax-case "invalid clause" + (car clauses)))))) + + (lambda (e r w s mod) + (let ((e (source-wrap e w s mod))) + (syntax-case e () + ((_ val (key ...) m ...) + (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) + #'(key ...)) + (let ((x (gen-var 'tmp))) + ;; fat finger binding and references to temp variable x + (build-call s + (build-simple-lambda no-source (list 'tmp) #f (list x) '() + (gen-syntax-case (build-lexical-reference no-source 'tmp x) + #'(key ...) #'(m ...) + r + mod)) + (list (expand #'val r empty-wrap mod)))) + (syntax-violation 'syntax-case "invalid literals list" e)))))))) + (global-extend 'local-syntax 'letrec-syntax #t) + (global-extend 'local-syntax 'let-syntax #f) + (global-extend 'core 'syntax-parameterize expand-syntax-parameterize) + (global-extend 'core 'quote expand-quote) + (global-extend 'core 'quote-syntax expand-quote-syntax) + (global-extend 'core 'syntax expand-syntax) + (global-extend 'core 'lambda expand-lambda) + (global-extend 'core 'lambda* expand-lambda*) + (global-extend 'core 'case-lambda expand-case-lambda) + (global-extend 'core 'case-lambda* expand-case-lambda*) + (global-extend 'core 'with-ellipsis expand-with-ellipsis) + (global-extend 'core 'let expand-let) + (global-extend 'core 'letrec expand-letrec) + (global-extend 'core 'letrec* expand-letrec*) + (global-extend 'core 'set! expand-set!) + (global-extend 'module-ref '@ expand-public-ref) + (global-extend 'module-ref '@@ expand-private-ref) + (global-extend 'core 'if expand-if) (global-extend 'begin 'begin '()) - (global-extend 'define 'define '()) - (global-extend 'define-syntax 'define-syntax '()) (global-extend 'define-syntax-parameter 'define-syntax-parameter '()) - (global-extend 'eval-when 'eval-when '()) - - (global-extend 'core 'syntax-case - (let () - (define (convert-pattern pattern keys ellipsis?) - ;; accepts pattern & keys - ;; returns $sc-dispatch pattern & ids - (define cvt* - (lambda (p* n ids) - (syntax-case p* () - ((x . y) - (call-with-values - (lambda () (cvt* #'y n ids)) - (lambda (y ids) - (call-with-values - (lambda () (cvt #'x n ids)) - (lambda (x ids) - (values (cons x y) ids)))))) - (_ (cvt p* n ids))))) - - (define (v-reverse x) - (let loop ((r '()) (x x)) - (if (not (pair? x)) - (values r x) - (loop (cons (car x) r) (cdr x))))) - - (define cvt - (lambda (p n ids) - (if (id? p) - (cond - ((bound-id-member? p keys) - (values (vector 'free-id p) ids)) - ((free-id=? p #'_) - (values '_ ids)) - (else - (values 'any (cons (cons p n) ids)))) - (syntax-case p () - ((x dots) - (ellipsis? (syntax dots)) - (call-with-values - (lambda () (cvt (syntax x) (1+ n) ids)) - (lambda (p ids) - (values (if (eq? p 'any) 'each-any (vector 'each p)) - ids)))) - ((x dots . ys) - (ellipsis? (syntax dots)) - (call-with-values - (lambda () (cvt* (syntax ys) n ids)) - (lambda (ys ids) - (call-with-values - (lambda () (cvt (syntax x) (+ n 1) ids)) - (lambda (x ids) - (call-with-values - (lambda () (v-reverse ys)) - (lambda (ys e) - (values `#(each+ ,x ,ys ,e) - ids)))))))) - ((x . y) - (call-with-values - (lambda () (cvt (syntax y) n ids)) - (lambda (y ids) - (call-with-values - (lambda () (cvt (syntax x) n ids)) - (lambda (x ids) - (values (cons x y) ids)))))) - (() (values '() ids)) - (#(x ...) - (call-with-values - (lambda () (cvt (syntax (x ...)) n ids)) - (lambda (p ids) (values (vector 'vector p) ids)))) - (x (values (vector 'atom (strip p)) ids)))))) - (cvt pattern 0 '())) - - (define (build-dispatch-call pvars exp y r mod) - (let ((ids (map car pvars)) (levels (map cdr pvars))) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (build-primcall - no-source - 'apply - (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '() - (expand exp - (extend-env - labels - (map (lambda (var level) - (make-binding 'syntax `(,var . ,level))) - new-vars - (map cdr pvars)) - r) - (make-binding-wrap ids labels empty-wrap) - mod)) - y))))) - - (define (gen-clause x keys clauses r pat fender exp mod) - (call-with-values - (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) - (lambda (p pvars) - (cond - ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) - (syntax-violation 'syntax-case "misplaced ellipsis" pat)) - ((not (distinct-bound-ids? (map car pvars))) - (syntax-violation 'syntax-case "duplicate pattern variable" pat)) - (else - (let ((y (gen-var 'tmp))) - ;; fat finger binding and references to temp variable y - (build-call no-source - (build-simple-lambda no-source (list 'tmp) #f (list y) '() - (let ((y (build-lexical-reference no-source 'tmp y))) - (build-conditional no-source - (syntax-case fender () - (#t y) - (_ (build-conditional no-source - y - (build-dispatch-call pvars fender y r mod) - (build-data no-source #f)))) - (build-dispatch-call pvars exp y r mod) - (gen-syntax-case x keys clauses r mod)))) - (list (if (eq? p 'any) - (build-primcall no-source 'list (list x)) - (build-primcall no-source '$sc-dispatch - (list x (build-data no-source p)))))))))))) - - (define (gen-syntax-case x keys clauses r mod) - (if (null? clauses) - (build-primcall no-source 'syntax-violation - (list (build-data no-source #f) - (build-data no-source - "source expression failed to match any pattern") - x)) - (syntax-case (car clauses) () - ((pat exp) - (if (and (id? #'pat) - (and-map (lambda (x) (not (free-id=? #'pat x))) - (cons #'(... ...) keys))) - (if (free-id=? #'pat #'_) - (expand #'exp r empty-wrap mod) - (let ((labels (list (gen-label))) - (var (gen-var #'pat))) - (build-call no-source - (build-simple-lambda - no-source (list (syntax->datum #'pat)) #f (list var) - '() - (expand #'exp - (extend-env labels - (list (make-binding 'syntax `(,var . 0))) - r) - (make-binding-wrap #'(pat) - labels empty-wrap) - mod)) - (list x)))) - (gen-clause x keys (cdr clauses) r - #'pat #t #'exp mod))) - ((pat fender exp) - (gen-clause x keys (cdr clauses) r - #'pat #'fender #'exp mod)) - (_ (syntax-violation 'syntax-case "invalid clause" - (car clauses)))))) - - (lambda (e r w s mod) - (let ((e (source-wrap e w s mod))) - (syntax-case e () - ((_ val (key ...) m ...) - (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) - #'(key ...)) - (let ((x (gen-var 'tmp))) - ;; fat finger binding and references to temp variable x - (build-call s - (build-simple-lambda no-source (list 'tmp) #f (list x) '() - (gen-syntax-case (build-lexical-reference no-source 'tmp x) - #'(key ...) #'(m ...) - r - mod)) - (list (expand #'val r empty-wrap mod)))) - (syntax-violation 'syntax-case "invalid literals list" e)))))))) + (global-extend 'core 'syntax-case expand-syntax-case) ;; The portable macroexpand seeds expand-top's mode m with 'e (for ;; evaluating) and esew (which stands for "eval syntax expanders |