diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 9c4b22e74..875a0af07 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -105,6 +105,8 @@ (fk))))) (top-level-eval (lambda (x mod) (primitive-eval x))) (local-eval (lambda (x mod) (primitive-eval x))) + (global-extend + (lambda (type sym val) (module-define! (current-module) sym (make-syntax-transformer sym type val)))) (sourcev-filename (lambda (s) (vector-ref s 0))) (sourcev-line (lambda (s) (vector-ref s 1))) (sourcev-column (lambda (s) (vector-ref s 2))) @@ -306,8 +308,6 @@ (fk)))) (fk)))))) (if (null? v) '() (fk))))) - (global-extend - (lambda (type sym val) (module-define! (current-module) sym (make-syntax-transformer sym type val)))) (nonsymbol-id? (lambda (x) (and (syntax? x) (symbol? (syntax-expression x))))) (id? (lambda (x) (if (symbol? x) #t (and (syntax? x) (symbol? (syntax-expression x)))))) (id-sym-name (lambda (x) (if (syntax? x) (syntax-expression x) x))) @@ -1196,11 +1196,11 @@ (source-wrap e w (wrap-subst w) mod) x)) (else (decorate-source x)))))) - (let* ((t-680b775fb37a463-c86 transformer-environment) - (t-680b775fb37a463-c87 (lambda (k) (k e r w s rib mod)))) + (let* ((t-680b775fb37a463-cbb transformer-environment) + (t-680b775fb37a463-cbc (lambda (k) (k e r w s rib mod)))) (with-fluid* - t-680b775fb37a463-c86 - t-680b775fb37a463-c87 + t-680b775fb37a463-cbb + t-680b775fb37a463-cbc (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (expand-body (lambda (body outer-form r w mod) @@ -1731,11 +1731,11 @@ s mod get-formals - (map (lambda (tmp-680b775fb37a463-f0f - tmp-680b775fb37a463-f0e - tmp-680b775fb37a463-f0d) - (cons tmp-680b775fb37a463-f0d - (cons tmp-680b775fb37a463-f0e tmp-680b775fb37a463-f0f))) + (map (lambda (tmp-680b775fb37a463-f44 + tmp-680b775fb37a463-f43 + tmp-680b775fb37a463-f42) + (cons tmp-680b775fb37a463-f42 + (cons tmp-680b775fb37a463-f43 tmp-680b775fb37a463-f44))) e2* e1* args*))) @@ -2008,8 +2008,11 @@ (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))) + (map (lambda (tmp-680b775fb37a463-11a9 + tmp-680b775fb37a463-11a8 + tmp-680b775fb37a463-11a7) + (cons tmp-680b775fb37a463-11a7 + (cons tmp-680b775fb37a463-11a8 tmp-680b775fb37a463-11a9))) e2 e1 args))) @@ -2019,9 +2022,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-118a tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (cons tmp-680b775fb37a463 - (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-118a))) + (map (lambda (tmp-680b775fb37a463-11bf + tmp-680b775fb37a463-11be + tmp-680b775fb37a463-11bd) + (cons tmp-680b775fb37a463-11bd + (cons tmp-680b775fb37a463-11be tmp-680b775fb37a463-11bf))) e2 e1 args))) @@ -2039,11 +2044,11 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-11aa - tmp-680b775fb37a463-11a9 - tmp-680b775fb37a463-11a8) - (cons tmp-680b775fb37a463-11a8 - (cons tmp-680b775fb37a463-11a9 tmp-680b775fb37a463-11aa))) + (map (lambda (tmp-680b775fb37a463-11df + tmp-680b775fb37a463-11de + tmp-680b775fb37a463-11dd) + (cons tmp-680b775fb37a463-11dd + (cons tmp-680b775fb37a463-11de tmp-680b775fb37a463-11df))) e2 e1 args))) @@ -2053,11 +2058,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-11c0 - tmp-680b775fb37a463-11bf - tmp-680b775fb37a463-11be) - (cons tmp-680b775fb37a463-11be - (cons tmp-680b775fb37a463-11bf tmp-680b775fb37a463-11c0))) + (map (lambda (tmp-680b775fb37a463-11f5 + tmp-680b775fb37a463-11f4 + tmp-680b775fb37a463-11f3) + (cons tmp-680b775fb37a463-11f3 + (cons tmp-680b775fb37a463-11f4 tmp-680b775fb37a463-11f5))) e2 e1 args))) @@ -2620,90 +2625,103 @@ (define! '%syntax-module %syntax-module) (define! 'syntax-local-binding syntax-local-binding) (define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers)) - (letrec* ((match-each - (lambda (e p w mod) - (cond - ((pair? e) - (let ((first (match (car e) p w '() mod))) - (and first (let ((rest (match-each (cdr e) p w mod))) (and rest (cons first rest)))))) - ((null? e) '()) - ((syntax? e) - (match-each (syntax-expression e) p (join-wraps w (syntax-wrap e)) (or (syntax-module e) mod))) - (else #f)))) - (match-each+ - (lambda (e x-pat y-pat z-pat w r mod) - (let f ((e e) (w w)) - (cond - ((pair? e) - (call-with-values - (lambda () (f (cdr e) w)) - (lambda (xr* y-pat r) - (if r - (if (null? y-pat) - (let ((xr (match (car e) x-pat w '() mod))) - (if xr (values (cons xr xr*) y-pat r) (values #f #f #f))) - (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod))) - (values #f #f #f))))) - ((syntax? e) (f (syntax-expression e) (join-wraps w (syntax-wrap e)))) - (else (values '() y-pat (match e z-pat w r mod))))))) - (match-each-any - (lambda (e w mod) - (cond - ((pair? e) (let ((l (match-each-any (cdr e) w mod))) (and l (cons (wrap (car e) w mod) l)))) - ((null? e) '()) - ((syntax? e) (match-each-any (syntax-expression e) (join-wraps w (syntax-wrap e)) mod)) - (else #f)))) - (match-empty - (lambda (p r) - (cond - ((null? p) r) - ((eq? p '_) r) - ((eq? p 'any) (cons '() r)) - ((pair? p) (match-empty (car p) (match-empty (cdr p) r))) - ((eq? p 'each-any) (cons '() r)) - (else (let ((key (vector-ref p 0))) + (set! $sc-dispatch + (lambda (e p) + (letrec* ((match-each + (lambda (e p w mod) + (cond + ((pair? e) + (let ((first (match (car e) p w '() mod))) + (and first (let ((rest (match-each (cdr e) p w mod))) (and rest (cons first rest)))))) + ((null? e) '()) + ((syntax? e) + (match-each + (syntax-expression e) + p + (join-wraps w (syntax-wrap e)) + (or (syntax-module e) mod))) + (else #f)))) + (match-each+ + (lambda (e x-pat y-pat z-pat w r mod) + (let f ((e e) (w w)) (cond - ((memv key '(each)) (match-empty (vector-ref p 1) r)) - ((memv key '(each+)) - (match-empty - (vector-ref p 1) - (match-empty (reverse (vector-ref p 2)) (match-empty (vector-ref p 3) r)))) - ((memv key '(free-id atom)) r) - ((memv key '(vector)) (match-empty (vector-ref p 1) r)))))))) - (combine (lambda (r* r) (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r))))) - (match* - (lambda (e p w r mod) - (cond - ((null? p) (and (null? e) r)) - ((pair? p) (and (pair? e) (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod))) - ((eq? p 'each-any) (let ((l (match-each-any e w mod))) (and l (cons l r)))) - (else (let ((key (vector-ref p 0))) - (cond - ((memv key '(each)) - (if (null? e) - (match-empty (vector-ref p 1) r) - (let ((l (match-each e (vector-ref p 1) w mod))) - (and l - (let collect ((l l)) - (if (null? (car l)) r (cons (map car l) (collect (map cdr l))))))))) - ((memv key '(each+)) + ((pair? e) (call-with-values - (lambda () (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod)) + (lambda () (f (cdr e) w)) (lambda (xr* y-pat r) - (and r (null? y-pat) (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r)))))) - ((memv key '(free-id)) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) - ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e)) r)) - ((memv key '(vector)) (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod))))))))) - (match (lambda (e p w r mod) - (cond - ((not r) #f) - ((eq? p '_) r) - ((eq? p 'any) (cons (wrap e w mod) r)) - ((syntax? e) - (match* (syntax-expression e) p (join-wraps w (syntax-wrap e)) r (or (syntax-module e) mod))) - (else (match* e p w r mod)))))) - (set! $sc-dispatch - (lambda (e p) + (if r + (if (null? y-pat) + (let ((xr (match (car e) x-pat w '() mod))) + (if xr (values (cons xr xr*) y-pat r) (values #f #f #f))) + (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod))) + (values #f #f #f))))) + ((syntax? e) (f (syntax-expression e) (join-wraps w (syntax-wrap e)))) + (else (values '() y-pat (match e z-pat w r mod))))))) + (match-each-any + (lambda (e w mod) + (cond + ((pair? e) (let ((l (match-each-any (cdr e) w mod))) (and l (cons (wrap (car e) w mod) l)))) + ((null? e) '()) + ((syntax? e) (match-each-any (syntax-expression e) (join-wraps w (syntax-wrap e)) mod)) + (else #f)))) + (match-empty + (lambda (p r) + (cond + ((null? p) r) + ((eq? p '_) r) + ((eq? p 'any) (cons '() r)) + ((pair? p) (match-empty (car p) (match-empty (cdr p) r))) + ((eq? p 'each-any) (cons '() r)) + (else (let ((key (vector-ref p 0))) + (cond + ((memv key '(each)) (match-empty (vector-ref p 1) r)) + ((memv key '(each+)) + (match-empty + (vector-ref p 1) + (match-empty (reverse (vector-ref p 2)) (match-empty (vector-ref p 3) r)))) + ((memv key '(free-id atom)) r) + ((memv key '(vector)) (match-empty (vector-ref p 1) r)))))))) + (combine (lambda (r* r) (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r))))) + (match* + (lambda (e p w r mod) + (cond + ((null? p) (and (null? e) r)) + ((pair? p) (and (pair? e) (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod))) + ((eq? p 'each-any) (let ((l (match-each-any e w mod))) (and l (cons l r)))) + (else (let ((key (vector-ref p 0))) + (cond + ((memv key '(each)) + (if (null? e) + (match-empty (vector-ref p 1) r) + (let ((l (match-each e (vector-ref p 1) w mod))) + (and l + (let collect ((l l)) + (if (null? (car l)) r (cons (map car l) (collect (map cdr l))))))))) + ((memv key '(each+)) + (call-with-values + (lambda () + (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod)) + (lambda (xr* y-pat r) + (and r + (null? y-pat) + (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r)))))) + ((memv key '(free-id)) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) + ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e)) r)) + ((memv key '(vector)) + (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod))))))))) + (match (lambda (e p w r mod) + (cond + ((not r) #f) + ((eq? p '_) r) + ((eq? p 'any) (cons (wrap e w mod) r)) + ((syntax? e) + (match* + (syntax-expression e) + p + (join-wraps w (syntax-wrap e)) + r + (or (syntax-module e) mod))) + (else (match* e p w r mod)))))) (cond ((eq? p 'any) (list e)) ((eq? p '_) '()) @@ -2867,9 +2885,9 @@ #f k '() - (map (lambda (tmp-680b775fb37a463-149e tmp-680b775fb37a463-149d tmp-680b775fb37a463-149c) - (list (cons tmp-680b775fb37a463-149c tmp-680b775fb37a463-149d) - tmp-680b775fb37a463-149e)) + (map (lambda (tmp-680b775fb37a463-14d3 tmp-680b775fb37a463-14d2 tmp-680b775fb37a463-14d1) + (list (cons tmp-680b775fb37a463-14d1 tmp-680b775fb37a463-14d2) + tmp-680b775fb37a463-14d3)) template pattern keyword))) @@ -2884,11 +2902,11 @@ #f k (list docstring) - (map (lambda (tmp-680b775fb37a463-14b7 - tmp-680b775fb37a463-14b6 - tmp-680b775fb37a463-14b5) - (list (cons tmp-680b775fb37a463-14b5 tmp-680b775fb37a463-14b6) - tmp-680b775fb37a463-14b7)) + (map (lambda (tmp-680b775fb37a463-14ec + tmp-680b775fb37a463-14eb + tmp-680b775fb37a463-14ea) + (list (cons tmp-680b775fb37a463-14ea tmp-680b775fb37a463-14eb) + tmp-680b775fb37a463-14ec)) template pattern keyword))) @@ -2900,11 +2918,9 @@ dots k '() - (map (lambda (tmp-680b775fb37a463-14d0 - tmp-680b775fb37a463-14cf - tmp-680b775fb37a463-14ce) - (list (cons tmp-680b775fb37a463-14ce tmp-680b775fb37a463-14cf) - tmp-680b775fb37a463-14d0)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2920,11 +2936,11 @@ dots k (list docstring) - (map (lambda (tmp-680b775fb37a463-14ef - tmp-680b775fb37a463-14ee - tmp-680b775fb37a463-14ed) - (list (cons tmp-680b775fb37a463-14ed tmp-680b775fb37a463-14ee) - tmp-680b775fb37a463-14ef)) + (map (lambda (tmp-680b775fb37a463-2 + tmp-680b775fb37a463-1 + tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -3052,9 +3068,9 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-159c) + (map (lambda (tmp-680b775fb37a463-15d1) (list "value" - tmp-680b775fb37a463-159c)) + tmp-680b775fb37a463-15d1)) p) (quasi q lev)) (quasicons @@ -3080,9 +3096,9 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-15a1) + (map (lambda (tmp-680b775fb37a463-15d6) (list "value" - tmp-680b775fb37a463-15a1)) + tmp-680b775fb37a463-15d6)) p) (quasi q lev)) (quasicons @@ -3118,8 +3134,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-15b7) - (list "value" tmp-680b775fb37a463-15b7)) + (map (lambda (tmp-680b775fb37a463-15ec) + (list "value" tmp-680b775fb37a463-15ec)) p) (vquasi q lev)) (quasicons @@ -3139,8 +3155,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-15bc) - (list "value" tmp-680b775fb37a463-15bc)) + (map (lambda (tmp-680b775fb37a463-15f1) + (list "value" tmp-680b775fb37a463-15f1)) p) (vquasi q lev)) (quasicons @@ -3222,7 +3238,8 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463)) + (apply (lambda (t-680b775fb37a463-163a) + (cons "vector" t-680b775fb37a463-163a)) tmp) (syntax-violation #f @@ -3256,9 +3273,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-162f) + (apply (lambda (t-680b775fb37a463) (cons (make-syntax 'list '((top)) '(hygiene guile)) - t-680b775fb37a463-162f)) + t-680b775fb37a463)) tmp) (syntax-violation #f @@ -3293,12 +3310,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-164f) + (apply (lambda (t-680b775fb37a463) (cons (make-syntax 'append '((top)) '(hygiene guile)) - t-680b775fb37a463-164f)) + t-680b775fb37a463)) tmp) (syntax-violation #f @@ -3311,12 +3328,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-165b) + (apply (lambda (t-680b775fb37a463) (cons (make-syntax 'vector '((top)) '(hygiene guile)) - t-680b775fb37a463-165b)) + t-680b775fb37a463)) tmp) (syntax-violation #f @@ -3327,12 +3344,12 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t-680b775fb37a463 tmp)) + (let ((t-680b775fb37a463-169c tmp)) (list (make-syntax 'list->vector '((top)) '(hygiene guile)) - t-680b775fb37a463)))) + t-680b775fb37a463-169c)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (if tmp-1 diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index d2c10fd06..2911e96ea 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -2588,6 +2588,14 @@ (global-extend 'eval-when 'eval-when '()) (global-extend 'core 'syntax-case expand-syntax-case) + (define-syntax define/override + (syntax-rules () + ((_ (id . args) . body) (define/override id (lambda args . body))) + ((_ id exp) (set! id exp)))) + (define-syntax define*/override + (syntax-rules () + ((_ (id . args) . body) (define/override id (lambda* args . body))))) + ;; The portable macroexpand seeds expand-top's mode m with 'e (for ;; evaluating) and esew (which stands for "eval syntax expanders ;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e @@ -2597,89 +2605,81 @@ ;; syntactic definitions are evaluated immediately after they are ;; expanded, and the expanded definitions are also residualized into ;; the object file if we are compiling a file. - (set! macroexpand - (lambda* (x #:optional (m 'e) (esew '(eval))) - (define (unstrip x) - (define (annotate result) - (let ((props (source-properties x))) - (if (pair? props) - (datum->syntax #f result #:source props) - result))) - (cond - ((pair? x) - (annotate (cons (unstrip (car x)) (unstrip (cdr x))))) - ((vector? x) - (let ((v (make-vector (vector-length x)))) - (annotate (list->vector (map unstrip (vector->list x)))))) - ((syntax? x) x) - (else (annotate x)))) - (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew - (cons 'hygiene (module-name (current-module)))))) + (define*/override (macroexpand x #:optional (m 'e) (esew '(eval))) + (define (unstrip x) + (define (annotate result) + (let ((props (source-properties x))) + (if (pair? props) + (datum->syntax #f result #:source props) + result))) + (cond + ((pair? x) + (annotate (cons (unstrip (car x)) (unstrip (cdr x))))) + ((vector? x) + (let ((v (make-vector (vector-length x)))) + (annotate (list->vector (map unstrip (vector->list x)))))) + ((syntax? x) x) + (else (annotate x)))) + (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew + (cons 'hygiene (module-name (current-module))))) - (set! identifier? - (lambda (x) - (nonsymbol-id? x))) + (define/override (identifier? x) + (nonsymbol-id? x)) - (set! datum->syntax - (lambda* (id datum #:key source) - (define (props->sourcev alist) - (and (pair? alist) - (vector (assq-ref alist 'filename) - (assq-ref alist 'line) - (assq-ref alist 'column)))) - (make-syntax datum - (if id - (syntax-wrap id) - empty-wrap) - (if id - (syntax-module id) - #f) - (cond - ((not source) - (props->sourcev (source-properties datum))) - ((and (list? source) (and-map pair? source)) - (props->sourcev source)) - ((and (vector? source) (= 3 (vector-length source))) - source) - (else (syntax-sourcev source)))))) + (define*/override (datum->syntax id datum #:key source) + (define (props->sourcev alist) + (and (pair? alist) + (vector (assq-ref alist 'filename) + (assq-ref alist 'line) + (assq-ref alist 'column)))) + (make-syntax datum + (if id + (syntax-wrap id) + empty-wrap) + (if id + (syntax-module id) + #f) + (cond + ((not source) + (props->sourcev (source-properties datum))) + ((and (list? source) (and-map pair? source)) + (props->sourcev source)) + ((and (vector? source) (= 3 (vector-length source))) + source) + (else (syntax-sourcev source))))) - (set! syntax->datum - ;; accepts any object, since syntax objects may consist partially - ;; or entirely of unwrapped, nonsymbolic data - (lambda (x) - (strip x))) + (define/override (syntax->datum x) + ;; accepts any object, since syntax objects may consist partially + ;; or entirely of unwrapped, nonsymbolic data + (strip x)) - (set! generate-temporaries - (lambda (ls) - (arg-check list? ls 'generate-temporaries) - (let ((mod (cons 'hygiene (module-name (current-module))))) - (map (lambda (x) - (wrap (gen-var 't) top-wrap mod)) - ls)))) + (define/override (generate-temporaries ls) + (arg-check list? ls 'generate-temporaries) + (let ((mod (cons 'hygiene (module-name (current-module))))) + (map (lambda (x) + (wrap (gen-var 't) top-wrap mod)) + ls))) - (set! free-identifier=? - (lambda (x y) - (arg-check nonsymbol-id? x 'free-identifier=?) - (arg-check nonsymbol-id? y 'free-identifier=?) - (free-id=? x y))) + (define/override (free-identifier=? x y) + (arg-check nonsymbol-id? x 'free-identifier=?) + (arg-check nonsymbol-id? y 'free-identifier=?) + (free-id=? x y)) - (set! bound-identifier=? - (lambda (x y) - (arg-check nonsymbol-id? x 'bound-identifier=?) - (arg-check nonsymbol-id? y 'bound-identifier=?) - (bound-id=? x y))) + (define/override (bound-identifier=? x y) + (arg-check nonsymbol-id? x 'bound-identifier=?) + (arg-check nonsymbol-id? y 'bound-identifier=?) + (bound-id=? x y)) - (set! syntax-violation - (lambda* (who message form #:optional subform) - (arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) - who 'syntax-violation) - (arg-check string? message 'syntax-violation) - (throw 'syntax-error who message - (sourcev->alist - (or (source-annotation subform) - (source-annotation form))) - (strip form) - (strip subform)))) + (define*/override (syntax-violation who message form #:optional subform) + (arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) + who 'syntax-violation) + (arg-check string? message 'syntax-violation) + (throw 'syntax-error who message + (sourcev->alist + (or (source-annotation subform) + (source-annotation form))) + (strip form) + (strip subform))) (let () (define (%syntax-module id) @@ -2737,30 +2737,27 @@ (define! 'syntax-local-binding syntax-local-binding) (define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers)) - ;; $sc-dispatch expects an expression and a pattern. If the expression - ;; matches the pattern a list of the matching expressions for each - ;; "any" is returned. Otherwise, #f is returned. (This use of #f will - ;; not work on r4rs implementations that violate the ieee requirement - ;; that #f and () be distinct.) + (define/override ($sc-dispatch e p) + ;; $sc-dispatch expects an expression and a pattern. If the expression + ;; matches the pattern a list of the matching expressions for each + ;; "any" is returned. Otherwise, #f is returned. - ;; The expression is matched with the pattern as follows: + ;; The expression is matched with the pattern as follows: - ;; pattern: matches: - ;; () empty list - ;; any anything - ;; (1 . 2) (1 . 2) - ;; each-any (any*) - ;; #(free-id ) with free-identifier=? - ;; #(each ) (*) - ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3) - ;; #(vector ) (list->vector ) - ;; #(atom ) with "equal?" + ;; pattern: matches: + ;; () empty list + ;; any anything + ;; (1 . 2) (1 . 2) + ;; each-any (any*) + ;; #(free-id ) with free-identifier=? + ;; #(each ) (*) + ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3) + ;; #(vector ) (list->vector ) + ;; #(atom ) with "equal?" - ;; Vector cops out to pair under assumption that vectors are rare. If - ;; not, should convert to: - ;; #(vector *) #(*) - - (let () + ;; Vector cops out to pair under assumption that vectors are rare. If + ;; not, should convert to: + ;; #(vector *) #(*) (define (match-each e p w mod) (cond @@ -2884,15 +2881,13 @@ (or (syntax-module e) mod))) (else (match* e p w r mod)))) - (set! $sc-dispatch - (lambda (e p) - (cond - ((eq? p 'any) (list e)) - ((eq? p '_) '()) - ((syntax? e) - (match* (syntax-expression e) - p (syntax-wrap e) '() (syntax-module e))) - (else (match* e p empty-wrap '() #f))))))) + (cond + ((eq? p 'any) (list e)) + ((eq? p '_) '()) + ((syntax? e) + (match* (syntax-expression e) + p (syntax-wrap e) '() (syntax-module e))) + (else (match* e p empty-wrap '() #f))))) (define-syntax with-syntax