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

psyntax: Use new `match' instead of cdadring

Browse source 
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/psyntax.scm: Use `match' more.  Also use more first-order
definitions.  NFC.
This commit is contained in:
Andy Wingo 2024-11-15 15:35:10 +01:00
parent 0295409483
commit 2daea40200
2 changed files with 280 additions and 190 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -193,24 +193,75 @@
(let ((props (source-properties datum))) (let ((props (source-properties datum)))
(and (pair? props) (vector (assq-ref props 'filename) (assq-ref props 'line) (assq-ref props 'column)))))) (and (pair? props) (vector (assq-ref props 'filename) (assq-ref props 'line) (assq-ref props 'column))))))
(source-annotation (lambda (x) (if (syntax? x) (syntax-sourcev x) (datum-sourcev x)))) (source-annotation (lambda (x) (if (syntax? x) (syntax-sourcev x) (datum-sourcev x))))
(binding-type (lambda (x) (car x)))
(binding-value (lambda (x) (cdr x)))
(null-env '())
(extend-env (extend-env
(lambda (labels bindings r) (lambda (labels bindings r)
(if (null? labels) (let* ((v labels)
r (fk (lambda ()
(extend-env (cdr labels) (cdr bindings) (cons (cons (car labels) (car bindings)) r))))) (let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((label vx)
(labels vy)
(v bindings)
(fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((binding vx) (bindings vy))
(extend-env labels bindings (acons label binding r))))
(fk))))
(fk))))))
(if (null? v) r (fk)))))
(extend-var-env (extend-var-env
(lambda (labels vars r) (lambda (labels vars r)
(if (null? labels) (let* ((v labels)
r (fk (lambda ()
(extend-var-env (cdr labels) (cdr vars) (cons (cons (car labels) (cons 'lexical (car vars))) r))))) (let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((label vx)
(labels vy)
(v vars)
(fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((var vx) (vars vy))
(extend-var-env labels vars (acons label (cons 'lexical var) r))))
(fk))))
(fk))))))
(if (null? v) r (fk)))))
(macros-only-env (macros-only-env
(lambda (r) (lambda (r)
(if (null? r) (let* ((v r)
'() (fk (lambda ()
(let ((a (car r))) (let ((fk (lambda () (error "value failed to match" v))))
(if (memq (cadr a) '(macro syntax-parameter ellipsis)) (if (pair? v)
(cons a (macros-only-env (cdr r))) (let ((vx (car v)) (vy (cdr v)))
(macros-only-env (cdr r))))))) (let* ((a vx)
(r vy)
(v a)
(fk (lambda ()
(let ((fk (lambda () (error "value failed to match" v))))
(macros-only-env r)))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let ((k vx))
(if (pair? vy)
(let ((vx (car vy)) (vy (cdr vy)))
(let ((tk (lambda () (cons a (macros-only-env r)))))
(if (eq? vx 'macro)
(tk)
(let ((tk (lambda () (tk))))
(if (eq? vx 'syntax-parameter)
(tk)
(let ((tk (lambda () (tk))))
(if (eq? vx 'ellipsis) (tk) (fk))))))))
(fk))))
(fk))))
(fk))))))
(if (null? v) '() (fk)))))
(global-extend (global-extend
(lambda (type sym val) (module-define! (current-module) sym (make-syntax-transformer sym type val)))) (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))))) (nonsymbol-id? (lambda (x) (and (syntax? x) (symbol? (syntax-expression x)))))
@ -218,15 +269,26 @@
(id-sym-name&marks (id-sym-name&marks
(lambda (x w) (lambda (x w)
(if (syntax? x) (if (syntax? x)
(values (syntax-expression x) (join-marks (car w) (car (syntax-wrap x)))) (values (syntax-expression x) (join-marks (wrap-marks w) (wrap-marks (syntax-wrap x))))
(values x (car w))))) (values x (wrap-marks w)))))
(make-wrap (lambda (marks subst) (cons marks subst)))
(wrap-marks (lambda (wrap) (car wrap)))
(wrap-subst (lambda (wrap) (cdr wrap)))
(gen-unique (gen-unique
(lambda* (#:optional (module (current-module))) (lambda* (#:optional (module (current-module)))
(if module (if module
(vector (module-name module) (module-generate-unique-id! module)) (vector (module-name module) (module-generate-unique-id! module))
(vector '(guile) (gensym "id"))))) (vector '(guile) (gensym "id")))))
(gen-label (lambda () (gen-unique))) (gen-label (lambda () (gen-unique)))
(gen-labels (lambda (ls) (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls)))))) (gen-labels
(lambda (ls)
(let* ((v ls)
(fk (lambda ()
(let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v))) (let ((ls vy)) (cons (gen-label) (gen-labels ls))))
(fk))))))
(if (null? v) '() (fk)))))
(make-ribcage (lambda (symnames marks labels) (vector 'ribcage symnames marks labels))) (make-ribcage (lambda (symnames marks labels) (vector 'ribcage symnames marks labels)))
(ribcage-symnames (lambda (ribcage) (vector-ref ribcage 1))) (ribcage-symnames (lambda (ribcage) (vector-ref ribcage 1)))
(ribcage-marks (lambda (ribcage) (vector-ref ribcage 2))) (ribcage-marks (lambda (ribcage) (vector-ref ribcage 2)))
@ -234,37 +296,54 @@
(set-ribcage-symnames! (lambda (ribcage x) (vector-set! ribcage 1 x))) (set-ribcage-symnames! (lambda (ribcage x) (vector-set! ribcage 1 x)))
(set-ribcage-marks! (lambda (ribcage x) (vector-set! ribcage 2 x))) (set-ribcage-marks! (lambda (ribcage x) (vector-set! ribcage 2 x)))
(set-ribcage-labels! (lambda (ribcage x) (vector-set! ribcage 3 x))) (set-ribcage-labels! (lambda (ribcage x) (vector-set! ribcage 3 x)))
(anti-mark (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w))))) (empty-wrap '(()))
(top-wrap '((top)))
(the-anti-mark #f)
(anti-mark (lambda (w) (make-wrap (cons the-anti-mark (wrap-marks w)) (cons 'shift (wrap-subst w)))))
(new-mark (lambda () (gen-unique))) (new-mark (lambda () (gen-unique)))
(extend-ribcage! (extend-ribcage!
(lambda (ribcage id label) (lambda (ribcage id label)
(set-ribcage-symnames! ribcage (cons (syntax-expression id) (ribcage-symnames ribcage))) (set-ribcage-symnames! ribcage (cons (syntax-expression id) (ribcage-symnames ribcage)))
(set-ribcage-marks! ribcage (cons (car (syntax-wrap id)) (ribcage-marks ribcage))) (set-ribcage-marks! ribcage (cons (wrap-marks (syntax-wrap id)) (ribcage-marks ribcage)))
(set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage))))) (set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage)))))
(make-binding-wrap (make-binding-wrap
(lambda (ids labels w) (lambda (ids labels w)
(if (null? ids) (let* ((v ids)
w (fk (lambda ()
(cons (car w) (let ((fk (lambda () (error "value failed to match" v))))
(cons (let* ((labelvec (list->vector labels)) (n (vector-length labelvec))) (if (pair? v)
(let ((symnamevec (make-vector n)) (marksvec (make-vector n))) (let ((vx (car v)) (vy (cdr v)))
(let f ((ids ids) (i 0)) (make-wrap
(if (not (null? ids)) (wrap-marks w)
(call-with-values (cons (let* ((labelvec (list->vector labels))
(lambda () (id-sym-name&marks (car ids) w)) (n (vector-length labelvec))
(lambda (symname marks) (symnamevec (make-vector n))
(vector-set! symnamevec i symname) (marksvec (make-vector n)))
(vector-set! marksvec i marks) (let f ((ids ids) (i 0))
(f (cdr ids) (#{1+}# i)))))) (let* ((v ids)
(make-ribcage symnamevec marksvec labelvec))) (fk (lambda ()
(cdr w)))))) (let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((id vx) (ids vy))
(call-with-values
(lambda () (id-sym-name&marks id w))
(lambda (symname marks)
(vector-set! symnamevec i symname)
(vector-set! marksvec i marks)
(f ids (#{1+}# i))))))
(fk))))))
(if (null? v) (make-ribcage symnamevec marksvec labelvec) (fk)))))
(wrap-subst w))))
(fk))))))
(if (null? v) w (fk)))))
(smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2)))) (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2))))
(join-wraps (join-wraps
(lambda (w1 w2) (lambda (w1 w2)
(let ((m1 (car w1)) (s1 (cdr w1))) (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
(if (null? m1) (if (null? m1)
(if (null? s1) w2 (cons (car w2) (smart-append s1 (cdr w2)))) (if (null? s1) w2 (make-wrap (wrap-marks w2) (smart-append s1 (wrap-subst w2))))
(cons (smart-append m1 (car w2)) (smart-append s1 (cdr w2))))))) (make-wrap (smart-append m1 (wrap-marks w2)) (smart-append s1 (wrap-subst w2)))))))
(join-marks (lambda (m1 m2) (smart-append m1 m2))) (join-marks (lambda (m1 m2) (smart-append m1 m2)))
(same-marks? (same-marks?
(lambda (x y) (lambda (x y)
@ -311,13 +390,13 @@
(values n marks)))) (values n marks))))
(else (f (#{1+}# i))))))))) (else (f (#{1+}# i)))))))))
(cond (cond
((symbol? id) (or (search id (cdr w) (car w) mod) id)) ((symbol? id) (or (search id (wrap-subst w) (wrap-marks w) mod) id))
((syntax? id) ((syntax? id)
(let ((id (syntax-expression id)) (w1 (syntax-wrap id)) (mod (or (syntax-module id) mod))) (let ((id (syntax-expression id)) (w1 (syntax-wrap id)) (mod (or (syntax-module id) mod)))
(let ((marks (join-marks (car w) (car w1)))) (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
(call-with-values (call-with-values
(lambda () (search id (cdr w) marks mod)) (lambda () (search id (wrap-subst w) marks mod))
(lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id)))))) (lambda (new-id marks) (or new-id (search id (wrap-subst w1) marks mod) id))))))
(else (syntax-violation 'id-var-name "invalid id" id)))))) (else (syntax-violation 'id-var-name "invalid id" id))))))
(locally-bound-identifiers (locally-bound-identifiers
(lambda (w mod) (lambda (w mod)
@ -338,7 +417,7 @@
(scan (cdr subst) results) (scan (cdr subst) results)
(f (cdr symnames) (f (cdr symnames)
(cdr marks) (cdr marks)
(cons (wrap (car symnames) (anti-mark (cons (car marks) subst)) mod) results)))))) (cons (wrap (car symnames) (anti-mark (make-wrap (car marks) subst)) mod) results))))))
(scan-vector-rib (scan-vector-rib
(lambda (subst symnames marks results) (lambda (subst symnames marks results)
(let ((n (vector-length symnames))) (let ((n (vector-length symnames)))
@ -347,10 +426,10 @@
(scan (cdr subst) results) (scan (cdr subst) results)
(f (#{1+}# i) (f (#{1+}# i)
(cons (wrap (vector-ref symnames i) (cons (wrap (vector-ref symnames i)
(anti-mark (cons (vector-ref marks i) subst)) (anti-mark (make-wrap (vector-ref marks i) subst))
mod) mod)
results)))))))) results))))))))
(scan (cdr w) '())))) (scan (wrap-subst w) '()))))
(resolve-identifier (resolve-identifier
(lambda (id w r mod resolve-syntax-parameters?) (lambda (id w r mod resolve-syntax-parameters?)
(letrec* ((resolve-global (letrec* ((resolve-global
@ -367,7 +446,7 @@
(if (eq? type 'syntax-parameter) (if (eq? type 'syntax-parameter)
(if resolve-syntax-parameters? (if resolve-syntax-parameters?
(let ((lexical (assq-ref r v))) (let ((lexical (assq-ref r v)))
(values 'macro (if lexical (cdr lexical) trans) mod)) (values 'macro (if lexical (binding-value lexical) trans) mod))
(values type v mod)) (values type v mod))
(values type trans mod))) (values type trans mod)))
(values 'global var mod))))) (values 'global var mod)))))
@ -375,7 +454,7 @@
(lambda (label mod) (lambda (label mod)
(let ((b (assq-ref r label))) (let ((b (assq-ref r label)))
(if b (if b
(let ((type (car b)) (value (cdr b))) (let ((type (binding-type b)) (value (binding-value b)))
(if (eq? type 'syntax-parameter) (if (eq? type 'syntax-parameter)
(if resolve-syntax-parameters? (if resolve-syntax-parameters?
(values 'macro value mod) (values 'macro value mod)
@ -402,8 +481,8 @@
(lambda (i j) (lambda (i j)
(let* ((mi (and (syntax? i) (syntax-module i))) (let* ((mi (and (syntax? i) (syntax-module i)))
(mj (and (syntax? j) (syntax-module j))) (mj (and (syntax? j) (syntax-module j)))
(ni (id-var-name i '(()) mi)) (ni (id-var-name i empty-wrap mi))
(nj (id-var-name j '(()) mj))) (nj (id-var-name j empty-wrap mj)))
(letrec* ((id-module-binding (letrec* ((id-module-binding
(lambda (id mod) (lambda (id mod)
(module-variable (module-variable
@ -422,7 +501,7 @@
(lambda (i j) (lambda (i j)
(if (and (syntax? i) (syntax? j)) (if (and (syntax? i) (syntax? j))
(and (eq? (syntax-expression i) (syntax-expression j)) (and (eq? (syntax-expression i) (syntax-expression j))
(same-marks? (car (syntax-wrap i)) (car (syntax-wrap j)))) (same-marks? (wrap-marks (syntax-wrap i)) (wrap-marks (syntax-wrap j))))
(eq? i j)))) (eq? i j))))
(valid-bound-ids? (valid-bound-ids?
(lambda (ids) (lambda (ids)
@ -441,7 +520,7 @@
(source-wrap (source-wrap
(lambda (x w s defmod) (lambda (x w s defmod)
(cond (cond
((and (null? (car w)) (null? (cdr w)) (not defmod) (not s)) x) ((and (null? (wrap-marks w)) (null? (wrap-subst w)) (not defmod) (not s)) x)
((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod)) ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod))
((null? x) x) ((null? x) x)
(else (make-syntax x w defmod s))))) (else (make-syntax x w defmod s)))))
@ -457,12 +536,13 @@
(lambda (body r w s m esew mod) (lambda (body r w s m esew mod)
(let* ((r (cons '("placeholder" placeholder) r)) (let* ((r (cons '("placeholder" placeholder) r))
(ribcage (make-ribcage '() '() '())) (ribcage (make-ribcage '() '() '()))
(w (cons (car w) (cons ribcage (cdr w))))) (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
(letrec* ((record-definition! (letrec* ((record-definition!
(lambda (id var) (lambda (id var)
(let ((mod (cons 'hygiene (module-name (current-module))))) (let ((mod (cons 'hygiene (module-name (current-module)))))
(extend-ribcage! ribcage id (cons (or (syntax-module id) mod) (wrap var '((top)) mod)))))) (extend-ribcage! ribcage id (cons (or (syntax-module id) mod) (wrap var top-wrap mod))))))
(macro-introduced-identifier? (lambda (id) (not (equal? (car (syntax-wrap id)) '(top))))) (macro-introduced-identifier?
(lambda (id) (not (equal? (wrap-marks (syntax-wrap id)) '(top)))))
(ensure-fresh-name (ensure-fresh-name
(lambda (var) (lambda (var)
(letrec* ((ribcage-has-var? (letrec* ((ribcage-has-var?
@ -515,7 +595,7 @@
(top-level-eval x mod) (top-level-eval x mod)
(lambda () x)) (lambda () x))
(call-with-values (call-with-values
(lambda () (resolve-identifier id '(()) r mod #t)) (lambda () (resolve-identifier id empty-wrap r mod #t))
(lambda (type* value* mod*) (lambda (type* value* mod*)
(if (eq? type* 'macro) (if (eq? type* 'macro)
(top-level-eval (top-level-eval
@ -646,7 +726,7 @@
((memv key '(macro)) ((memv key '(macro))
(if for-car? (if for-car?
(values type value e e w s mod) (values type value e e w s mod)
(syntax-type (expand-macro value e r w s rib mod) r '(()) s rib mod #f))) (syntax-type (expand-macro value e r w s rib mod) r empty-wrap s rib mod #f)))
((memv key '(global)) (values type value e value w s mod*)) ((memv key '(global)) (values type value e value w s mod*))
(else (values type value e e w s mod))))))) (else (values type value e e w s mod)))))))
((pair? e) ((pair? e)
@ -662,7 +742,7 @@
(values 'primitive-call fval e e w s mod) (values 'primitive-call fval e e w s mod)
(values 'global-call (make-syntax fval w fmod fs) e e w s mod))) (values 'global-call (make-syntax fval w fmod fs) e e w s mod)))
((memv key '(macro)) ((memv key '(macro))
(syntax-type (expand-macro fval e r w s rib mod) r '(()) s rib mod for-car?)) (syntax-type (expand-macro fval e r w s rib mod) r empty-wrap s rib mod for-car?))
((memv key '(module-ref)) ((memv key '(module-ref))
(call-with-values (call-with-values
(lambda () (fval e r w mod)) (lambda () (fval e r w mod))
@ -688,10 +768,10 @@
(source-wrap (source-wrap
(cons (make-syntax 'lambda '((top)) '(hygiene guile)) (cons (make-syntax 'lambda '((top)) '(hygiene guile))
(wrap (cons args (cons e1 e2)) w mod)) (wrap (cons args (cons e1 e2)) w mod))
'(()) empty-wrap
s s
#f) #f)
'(()) empty-wrap
s s
mod)) mod))
tmp-1) tmp-1)
@ -703,7 +783,7 @@
(wrap name w mod) (wrap name w mod)
(wrap e w mod) (wrap e w mod)
(list (make-syntax 'if '((top)) '(hygiene guile)) #f #f) (list (make-syntax 'if '((top)) '(hygiene guile)) #f #f)
'(()) empty-wrap
s s
mod)) mod))
tmp-1) tmp-1)
@ -813,7 +893,7 @@
(syntax-violation #f "source expression failed to match any pattern" tmp-1))))) (syntax-violation #f "source expression failed to match any pattern" tmp-1)))))
(expand-macro (expand-macro
(lambda (p e r w s rib mod) (lambda (p e r w s rib mod)
(letrec* ((decorate-source (lambda (x) (source-wrap x '(()) s #f))) (letrec* ((decorate-source (lambda (x) (source-wrap x empty-wrap s #f)))
(map* (lambda (f x) (map* (lambda (f x)
(cond ((null? x) x) ((pair? x) (cons (f (car x)) (map* f (cdr x)))) (else (f x))))) (cond ((null? x) x) ((pair? x) (cons (f (car x)) (map* f (cdr x)))) (else (f x)))))
(rebuild-macro-output (rebuild-macro-output
@ -822,12 +902,12 @@
((pair? x) (decorate-source (map* (lambda (x) (rebuild-macro-output x m)) x))) ((pair? x) (decorate-source (map* (lambda (x) (rebuild-macro-output x m)) x)))
((syntax? x) ((syntax? x)
(let ((w (syntax-wrap x))) (let ((w (syntax-wrap x)))
(let ((ms (car w)) (ss (cdr w))) (let ((ms (wrap-marks w)) (ss (wrap-subst w)))
(if (and (pair? ms) (eq? (car ms) #f)) (if (and (pair? ms) (eq? (car ms) the-anti-mark))
(wrap-syntax x (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))) mod) (wrap-syntax x (make-wrap (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))) mod)
(wrap-syntax (wrap-syntax
x x
(cons (cons m ms) (if rib (cons rib (cons 'shift ss)) (cons 'shift ss))) (make-wrap (cons m ms) (if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))
mod))))) mod)))))
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (v (make-vector n))) (let* ((n (vector-length x)) (v (make-vector n)))
@ -842,20 +922,20 @@
(syntax-violation (syntax-violation
#f #f
"encountered raw symbol in macro output" "encountered raw symbol in macro output"
(source-wrap e w (cdr w) mod) (source-wrap e w (wrap-subst w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-f01 transformer-environment) (let* ((t-680b775fb37a463-f33 transformer-environment)
(t-680b775fb37a463-f02 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-f34 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-f01 t-680b775fb37a463-f33
t-680b775fb37a463-f02 t-680b775fb37a463-f34
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
(expand-body (expand-body
(lambda (body outer-form r w mod) (lambda (body outer-form r w mod)
(let* ((r (cons '("placeholder" placeholder) r)) (let* ((r (cons '("placeholder" placeholder) r))
(ribcage (make-ribcage '() '() '())) (ribcage (make-ribcage '() '() '()))
(w (cons (car w) (cons ribcage (cdr w))))) (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
(let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
(ids '()) (ids '())
(labels '()) (labels '())
@ -890,7 +970,7 @@
(parse body ids labels (cons #f var-ids) (cons #f vars) (cons expand-tail-expr vals) bindings #f)) (parse body ids labels (cons #f var-ids) (cons #f vars) (cons expand-tail-expr vals) bindings #f))
(else (let ((e (cdar body)) (er (caar body)) (body (cdr body))) (else (let ((e (cdar body)) (er (caar body)) (body (cdr body)))
(call-with-values (call-with-values
(lambda () (syntax-type e er '(()) (source-annotation e) ribcage mod #f)) (lambda () (syntax-type e er empty-wrap (source-annotation e) ribcage mod #f))
(lambda (type value form e w s mod) (lambda (type value form e w s mod)
(let ((key type)) (let ((key type))
(cond (cond
@ -904,7 +984,7 @@
(cons id var-ids) (cons id var-ids)
(cons var vars) (cons var vars)
(cons (let ((wrapped (source-wrap e w s mod))) (cons (let ((wrapped (source-wrap e w s mod)))
(lambda () (expand wrapped er '(()) mod))) (lambda () (expand wrapped er empty-wrap mod)))
vals) vals)
(cons (cons 'lexical var) bindings) (cons (cons 'lexical var) bindings)
#f)))) #f))))
@ -975,7 +1055,7 @@
vars vars
vals vals
bindings bindings
(lambda () (expand wrapped er '(()) mod)))))))))))))))) (lambda () (expand wrapped er empty-wrap mod))))))))))))))))
(expand-local-syntax (expand-local-syntax
(lambda (rec? e r w s mod k) (lambda (rec? e r w s mod k)
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
@ -1010,7 +1090,7 @@
(lambda () (lambda ()
(resolve-identifier (resolve-identifier
(make-syntax '#{ $sc-ellipsis }# (syntax-wrap e) (or (syntax-module e) mod) #f) (make-syntax '#{ $sc-ellipsis }# (syntax-wrap e) (or (syntax-module e) mod) #f)
'(()) empty-wrap
r r
mod mod
#f)) #f))
@ -1379,11 +1459,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-117d (map (lambda (tmp-680b775fb37a463-11a1
tmp-680b775fb37a463-117c tmp-680b775fb37a463-11a0
tmp-680b775fb37a463-117b) tmp-680b775fb37a463-119f)
(cons tmp-680b775fb37a463-117b (cons tmp-680b775fb37a463-119f
(cons tmp-680b775fb37a463-117c tmp-680b775fb37a463-117d))) (cons tmp-680b775fb37a463-11a0 tmp-680b775fb37a463-11a1)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1408,7 +1488,7 @@
(gen-var (lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) (gen-lexical id)))) (gen-var (lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) (gen-lexical id))))
(lambda-var-list (lambda-var-list
(lambda (vars) (lambda (vars)
(let lvl ((vars vars) (ls '()) (w '(()))) (let lvl ((vars vars) (ls '()) (w empty-wrap))
(cond (cond
((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w)) ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
((id? vars) (cons (wrap vars w #f) ls)) ((id? vars) (cons (wrap vars w #f) ls))
@ -1472,7 +1552,7 @@
(lambda (src e r maps ellipsis? mod) (lambda (src e r maps ellipsis? mod)
(if (id? e) (if (id? e)
(call-with-values (call-with-values
(lambda () (resolve-identifier e '(()) r mod #f)) (lambda () (resolve-identifier e empty-wrap r mod #f))
(lambda (type value mod) (lambda (type value mod)
(let ((key type)) (let ((key type))
(cond (cond
@ -1651,8 +1731,8 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-6be tmp-680b775fb37a463-6bd tmp-680b775fb37a463-6bc)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463-6bc (cons tmp-680b775fb37a463-6bd tmp-680b775fb37a463-6be)))
e2 e2
e1 e1
args))) args)))
@ -1662,9 +1742,9 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-74d tmp-680b775fb37a463-74c tmp-680b775fb37a463-74b) (map (lambda (tmp-680b775fb37a463-6d4 tmp-680b775fb37a463-6d3 tmp-680b775fb37a463-6d2)
(cons tmp-680b775fb37a463-74b (cons tmp-680b775fb37a463-6d2
(cons tmp-680b775fb37a463-74c tmp-680b775fb37a463-74d))) (cons tmp-680b775fb37a463-6d3 tmp-680b775fb37a463-6d4)))
e2 e2
e1 e1
args))) args)))
@ -1684,8 +1764,8 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-6ff) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(cons tmp-680b775fb37a463-6ff (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1))) (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2 e2
e1 e1
args))) args)))
@ -1695,8 +1775,9 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-69e tmp-680b775fb37a463-69d tmp-680b775fb37a463-69c)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463-69c
(cons tmp-680b775fb37a463-69d tmp-680b775fb37a463-69e)))
e2 e2
e1 e1
args))) args)))
@ -1807,7 +1888,7 @@
((memv key '(global)) (build-global-assignment s value (expand val r w mod) id-mod)) ((memv key '(global)) (build-global-assignment s value (expand val r w mod) id-mod))
((memv key '(macro)) ((memv key '(macro))
(if (procedure-property value 'variable-transformer) (if (procedure-property value 'variable-transformer)
(expand (expand-macro value e r w s #f mod) r '(()) mod) (expand (expand-macro value e r w s #f mod) r empty-wrap mod)
(syntax-violation (syntax-violation
'set! 'set!
"not a variable transformer" "not a variable transformer"
@ -1821,7 +1902,7 @@
(if tmp (if tmp
(apply (lambda (head tail val) (apply (lambda (head tail val)
(call-with-values (call-with-values
(lambda () (syntax-type head r '(()) #f #f mod #t)) (lambda () (syntax-type head r empty-wrap #f #f mod #t))
(lambda (type value ee* ee ww ss modmod) (lambda (type value ee* ee ww ss modmod)
(let ((key type)) (let ((key type))
(if (memv key '(module-ref)) (if (memv key '(module-ref))
@ -1854,7 +1935,7 @@
(values (values
(syntax->datum id) (syntax->datum id)
r r
'((top)) top-wrap
#f #f
(syntax->datum (cons (make-syntax 'public '((top)) '(hygiene guile)) mod)))) (syntax->datum (cons (make-syntax 'public '((top)) '(hygiene guile)) mod))))
tmp) tmp)
@ -1884,14 +1965,14 @@
(apply (lambda (id) (apply (lambda (id)
(and (id? id) (equal? (cdr (or (and (syntax? id) (syntax-module id)) mod)) '(guile)))) (and (id? id) (equal? (cdr (or (and (syntax? id) (syntax-module id)) mod)) '(guile))))
tmp-1)) tmp-1))
(apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive))) 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)))) (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)) (if (and tmp-1 (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1))
(apply (lambda (mod id) (apply (lambda (mod id)
(values (values
(syntax->datum id) (syntax->datum id)
r r
'((top)) top-wrap
#f #f
(syntax->datum (cons (make-syntax 'private '((top)) '(hygiene guile)) mod)))) (syntax->datum (cons (make-syntax 'private '((top)) '(hygiene guile)) mod))))
tmp-1) tmp-1)
@ -2019,7 +2100,7 @@
labels labels
(map (lambda (var level) (cons 'syntax (cons var level))) new-vars (map cdr pvars)) (map (lambda (var level) (cons 'syntax (cons var level))) new-vars (map cdr pvars))
r) r)
(make-binding-wrap ids labels '(())) (make-binding-wrap ids labels empty-wrap)
mod)) mod))
y)))))) y))))))
(gen-clause (gen-clause
@ -2072,7 +2153,7 @@
(lambda (x) (not (free-id=? pat x))) (lambda (x) (not (free-id=? pat x)))
(cons (make-syntax '... '((top)) '(hygiene guile)) keys))) (cons (make-syntax '... '((top)) '(hygiene guile)) keys)))
(if (free-id=? pat (make-syntax '_ '((top)) '(hygiene guile))) (if (free-id=? pat (make-syntax '_ '((top)) '(hygiene guile)))
(expand exp r '(()) mod) (expand exp r empty-wrap mod)
(let ((labels (list (gen-label))) (var (gen-var pat))) (let ((labels (list (gen-label))) (var (gen-var pat)))
(build-call (build-call
#f #f
@ -2085,7 +2166,7 @@
(expand (expand
exp exp
(extend-env labels (list (cons 'syntax (cons var 0))) r) (extend-env labels (list (cons 'syntax (cons var 0))) r)
(make-binding-wrap (list pat) labels '(())) (make-binding-wrap (list pat) labels empty-wrap)
mod)) mod))
(list x)))) (list x))))
(gen-clause x keys (cdr clauses) r pat #t exp mod))) (gen-clause x keys (cdr clauses) r pat #t exp mod)))
@ -2111,7 +2192,7 @@
(list x) (list x)
'() '()
(gen-syntax-case (build-lexical-reference 'value #f 'tmp x) key m r mod)) (gen-syntax-case (build-lexical-reference 'value #f 'tmp x) key m r mod))
(list (expand val r '(()) mod)))) (list (expand val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e))) (syntax-violation 'syntax-case "invalid literals list" e)))
tmp) tmp)
(syntax-violation #f "source expression failed to match any pattern" tmp-1)))))) (syntax-violation #f "source expression failed to match any pattern" tmp-1))))))
@ -2132,8 +2213,8 @@
(else (annotate x))))))) (else (annotate x)))))))
(expand-top-sequence (expand-top-sequence
(list (unstrip x)) (list (unstrip x))
'() null-env
'((top)) top-wrap
#f #f
m m
esew esew
@ -2147,7 +2228,7 @@
(vector (assq-ref alist 'filename) (assq-ref alist 'line) (assq-ref alist 'column)))))) (vector (assq-ref alist 'filename) (assq-ref alist 'line) (assq-ref alist 'column))))))
(make-syntax (make-syntax
datum datum
(if id (syntax-wrap id) '(())) (if id (syntax-wrap id) empty-wrap)
(and id (syntax-module id)) (and id (syntax-module id))
(cond (cond
((not source) (props->sourcev (source-properties datum))) ((not source) (props->sourcev (source-properties datum)))
@ -2159,7 +2240,7 @@
(lambda (ls) (lambda (ls)
(let ((x ls)) (if (not (list? x)) (syntax-violation 'generate-temporaries "invalid argument" x))) (let ((x ls)) (if (not (list? x)) (syntax-violation 'generate-temporaries "invalid argument" x)))
(let ((mod (cons 'hygiene (module-name (current-module))))) (let ((mod (cons 'hygiene (module-name (current-module)))))
(map (lambda (x) (wrap (gen-var 't) '((top)) mod)) ls)))) (map (lambda (x) (wrap (gen-var 't) top-wrap mod)) ls))))
(set! free-identifier=? (set! free-identifier=?
(lambda (x y) (lambda (x y)
(let ((x x)) (if (not (nonsymbol-id? x)) (syntax-violation 'free-identifier=? "invalid argument" x))) (let ((x x)) (if (not (nonsymbol-id? x)) (syntax-violation 'free-identifier=? "invalid argument" x)))
@ -2194,10 +2275,10 @@
(lambda (e r w s rib mod) (lambda (e r w s rib mod)
(letrec* ((strip-anti-mark (letrec* ((strip-anti-mark
(lambda (w) (lambda (w)
(let ((ms (car w)) (s (cdr w))) (let ((ms (wrap-marks w)) (s (wrap-subst w)))
(if (and (pair? ms) (eq? (car ms) #f)) (if (and (pair? ms) (eq? (car ms) the-anti-mark))
(cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
(cons ms (if rib (cons rib s) s))))))) (make-wrap ms (if rib (cons rib s) s)))))))
(call-with-values (call-with-values
(lambda () (lambda ()
(resolve-identifier (resolve-identifier
@ -2318,7 +2399,7 @@
((eq? p 'any) (list e)) ((eq? p 'any) (list e))
((eq? p '_) '()) ((eq? p '_) '())
((syntax? e) (match* (syntax-expression e) p (syntax-wrap e) '() (syntax-module e))) ((syntax? e) (match* (syntax-expression e) p (syntax-wrap e) '() (syntax-module e)))
(else (match* e p '(()) '() #f)))))))) (else (match* e p empty-wrap '() #f))))))))
(define with-syntax (define with-syntax
(let ((make-syntax make-syntax)) (let ((make-syntax make-syntax))
@ -2477,8 +2558,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-12bc tmp-680b775fb37a463-12bb tmp-680b775fb37a463-12ba)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2)) (list (cons tmp-680b775fb37a463-12ba tmp-680b775fb37a463-12bb)
tmp-680b775fb37a463-12bc))
template template
pattern pattern
keyword))) keyword)))
@ -2493,11 +2575,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-12b2 (map (lambda (tmp-680b775fb37a463-12d5
tmp-680b775fb37a463-12b1 tmp-680b775fb37a463-12d4
tmp-680b775fb37a463-12b0) tmp-680b775fb37a463-12d3)
(list (cons tmp-680b775fb37a463-12b0 tmp-680b775fb37a463-12b1) (list (cons tmp-680b775fb37a463-12d3 tmp-680b775fb37a463-12d4)
tmp-680b775fb37a463-12b2)) tmp-680b775fb37a463-12d5))
template template
pattern pattern
keyword))) keyword)))
@ -2509,11 +2591,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-12cb (map (lambda (tmp-680b775fb37a463-12ee
tmp-680b775fb37a463-12ca tmp-680b775fb37a463-12ed
tmp-680b775fb37a463-12c9) tmp-680b775fb37a463-12ec)
(list (cons tmp-680b775fb37a463-12c9 tmp-680b775fb37a463-12ca) (list (cons tmp-680b775fb37a463-12ec tmp-680b775fb37a463-12ed)
tmp-680b775fb37a463-12cb)) tmp-680b775fb37a463-12ee))
template template
pattern pattern
keyword))) keyword)))
@ -2529,11 +2611,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-12ea (map (lambda (tmp-680b775fb37a463-130d
tmp-680b775fb37a463-12e9 tmp-680b775fb37a463-130c
tmp-680b775fb37a463-12e8) tmp-680b775fb37a463-130b)
(list (cons tmp-680b775fb37a463-12e8 tmp-680b775fb37a463-12e9) (list (cons tmp-680b775fb37a463-130b tmp-680b775fb37a463-130c)
tmp-680b775fb37a463-12ea)) tmp-680b775fb37a463-130d))
template template
pattern pattern
keyword))) keyword)))
@ -2661,8 +2743,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-13ba)
(list "value" tmp-680b775fb37a463)) (list "value"
tmp-680b775fb37a463-13ba))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2688,9 +2771,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-139c) (map (lambda (tmp-680b775fb37a463-13bf)
(list "value" (list "value"
tmp-680b775fb37a463-139c)) tmp-680b775fb37a463-13bf))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2726,8 +2809,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-13b2) (map (lambda (tmp-680b775fb37a463-13d5)
(list "value" tmp-680b775fb37a463-13b2)) (list "value" tmp-680b775fb37a463-13d5))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2747,8 +2830,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-13b7) (map (lambda (tmp-680b775fb37a463-13da)
(list "value" tmp-680b775fb37a463-13b7)) (list "value" tmp-680b775fb37a463-13da))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2840,8 +2923,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463-140c) (k (map (lambda (tmp-680b775fb37a463-142f)
(list "quote" tmp-680b775fb37a463-140c)) (list "quote" tmp-680b775fb37a463-142f))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@ -2852,8 +2935,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463-141b tmp)) (let ((t-680b775fb37a463-143e tmp))
(list "list->vector" t-680b775fb37a463-141b))))))))))))))))) (list "list->vector" t-680b775fb37a463-143e)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -2865,9 +2948,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-142a) (apply (lambda (t-680b775fb37a463-144d)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-142a)) t-680b775fb37a463-144d))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2883,14 +2966,13 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-143e (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463)
t-680b775fb37a463-143d)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-143e t-680b775fb37a463-1
t-680b775fb37a463-143d)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2903,12 +2985,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-144a) (apply (lambda (t-680b775fb37a463-146d)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-144a)) t-680b775fb37a463-146d))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f

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

@ -411,36 +411,40 @@
((_ type value) (cons type value)) ((_ type value) (cons type value))
((_ 'type) '(type)) ((_ 'type) '(type))
((_ type) (cons type '())))) ((_ type) (cons type '()))))
(define-syntax-rule (binding-type x) (define (binding-type x) (car x))
(car x)) (define (binding-value x) (cdr x))
(define-syntax-rule (binding-value x) (define null-env '())
(cdr x))
(define-syntax null-env (identifier-syntax '()))
(define (extend-env labels bindings r) (define (extend-env labels bindings r)
(if (null? labels) (match labels
r (() r)
(extend-env (cdr labels) (cdr bindings) ((label . labels)
(cons (cons (car labels) (car bindings)) r)))) (match bindings
((binding . bindings)
(extend-env labels bindings (acons label binding r)))))))
(define (extend-var-env labels vars r) (define (extend-var-env labels vars r)
;; variant of extend-env that forms "lexical" binding ;; variant of extend-env that forms "lexical" binding
(if (null? labels) (match labels
r (() r)
(extend-var-env (cdr labels) (cdr vars) ((label . labels)
(cons (cons (car labels) (make-binding 'lexical (car vars))) r)))) (match vars
((var . vars)
(extend-var-env labels vars
(acons label (make-binding 'lexical var) r)))))))
;; we use a "macros only" environment in expansion of local macro ;; we use a "macros only" environment in expansion of local macro
;; definitions so that their definitions can use local macros without ;; definitions so that their definitions can use local macros without
;; attempting to use other lexical identifiers. ;; attempting to use other lexical identifiers.
(define (macros-only-env r) (define (macros-only-env r)
(if (null? r) (match r
'() (() '())
(let ((a (car r))) ((a . r)
(if (memq (cadr a) '(macro syntax-parameter ellipsis)) (match a
(cons a (macros-only-env (cdr r))) ((k . ((or 'macro 'syntax-parameter 'ellipsis) . _))
(macros-only-env (cdr r)))))) (cons a (macros-only-env r)))
(_
(macros-only-env r))))))
(define (global-extend type sym val) (define (global-extend type sym val)
(module-define! (current-module) (module-define! (current-module)
@ -483,9 +487,9 @@
;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...)) ;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...)) ;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
(define-syntax make-wrap (identifier-syntax cons)) (define (make-wrap marks subst) (cons marks subst))
(define-syntax wrap-marks (identifier-syntax car)) (define (wrap-marks wrap) (car wrap))
(define-syntax wrap-subst (identifier-syntax cdr)) (define (wrap-subst wrap) (cdr wrap))
(define* (gen-unique #:optional (module (current-module))) (define* (gen-unique #:optional (module (current-module)))
;; Generate a unique value, used as a mark to identify a scope, or ;; Generate a unique value, used as a mark to identify a scope, or
@ -512,9 +516,9 @@
(gen-unique)) (gen-unique))
(define (gen-labels ls) (define (gen-labels ls)
(if (null? ls) (match ls
'() (() '())
(cons (gen-label) (gen-labels (cdr ls))))) ((_ . ls) (cons (gen-label) (gen-labels ls)))))
(define (make-ribcage symnames marks labels) (define (make-ribcage symnames marks labels)
(vector 'ribcage symnames marks labels)) (vector 'ribcage symnames marks labels))
@ -525,14 +529,14 @@
(define (set-ribcage-marks! ribcage x) (vector-set! ribcage 2 x)) (define (set-ribcage-marks! ribcage x) (vector-set! ribcage 2 x))
(define (set-ribcage-labels! ribcage x) (vector-set! ribcage 3 x)) (define (set-ribcage-labels! ribcage x) (vector-set! ribcage 3 x))
(define-syntax empty-wrap (identifier-syntax '(()))) (define empty-wrap '(()))
(define-syntax top-wrap (identifier-syntax '((top)))) (define top-wrap '((top)))
;; Marks must be comparable with "eq?" and distinct from pairs and ;; Marks must be comparable with "eq?" and distinct from pairs and
;; the symbol top. We do not use integers so that marks will remain ;; the symbol top. We do not use integers so that marks will remain
;; unique even across file compiles. ;; unique even across file compiles.
(define-syntax the-anti-mark (identifier-syntax #f)) (define the-anti-mark #f)
(define (anti-mark w) (define (anti-mark w)
(make-wrap (cons the-anti-mark (wrap-marks w)) (make-wrap (cons the-anti-mark (wrap-marks w))
@ -559,24 +563,28 @@
;; make-binding-wrap creates vector-based ribcages ;; make-binding-wrap creates vector-based ribcages
(define (make-binding-wrap ids labels w) (define (make-binding-wrap ids labels w)
(if (null? ids) (match ids
w (() w)
(make-wrap ((_ . _)
(wrap-marks w) (make-wrap
(cons (wrap-marks w)
(let ((labelvec (list->vector labels))) (cons
(let ((n (vector-length labelvec))) (let* ((labelvec (list->vector labels))
(let ((symnamevec (make-vector n)) (marksvec (make-vector n))) (n (vector-length labelvec))
(let f ((ids ids) (i 0)) (symnamevec (make-vector n))
(if (not (null? ids)) (marksvec (make-vector n)))
(call-with-values (let f ((ids ids) (i 0))
(lambda () (id-sym-name&marks (car ids) w)) (match ids
(lambda (symname marks) (()
(vector-set! symnamevec i symname) (make-ribcage symnamevec marksvec labelvec))
(vector-set! marksvec i marks) ((id . ids)
(f (cdr ids) (1+ i)))))) (call-with-values
(make-ribcage symnamevec marksvec labelvec)))) (lambda () (id-sym-name&marks id w))
(wrap-subst w))))) (lambda (symname marks)
(vector-set! symnamevec i symname)
(vector-set! marksvec i marks)
(f ids (1+ i))))))))
(wrap-subst w))))))
(define (smart-append m1 m2) (define (smart-append m1 m2)
(if (null? m2) (if (null? m2)