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: Simplify id-var-name

Browse source 
* module/ice-9/psyntax.scm (id-var-name): No need for `search` to return
the marks.  Simplify to use scope instead of repeating, and use match.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2024-11-18 09:48:09 +01:00
parent 14414655d3
commit 54c8901adc
2 changed files with 255 additions and 159 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -261,6 +261,7 @@
(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)))))
(id? (lambda (x) (if (symbol? x) #t (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)))
(id-sym-name&marks (id-sym-name&marks
(lambda (x w) (lambda (x w)
(if (syntax? x) (if (syntax? x)
@ -346,52 +347,154 @@
(id-var-name (id-var-name
(lambda (id w mod) (lambda (id w mod)
(letrec* ((search (letrec* ((search
(lambda (sym subst marks mod) (lambda (sym subst marks)
(if (null? subst) (let* ((v subst)
(values #f marks) (fk (lambda ()
(let ((fst (car subst))) (let ((fk (lambda ()
(if (eq? fst 'shift) (let ((fk (lambda () (error "value failed to match" v))))
(search sym (cdr subst) (cdr marks) mod) (if (pair? v)
(let ((symnames (ribcage-symnames fst))) (let ((vx (car v)) (vy (cdr v)))
(if (vector? symnames) (if (and (vector? vx)
(search-vector-rib sym subst marks symnames fst mod) (eq? (vector-length vx)
(search-list-rib sym subst marks symnames fst mod)))))))) (length '('ribcage rsymnames rmarks rlabels))))
(search-list-rib (if (eq? (vector-ref vx 0) 'ribcage)
(lambda (sym subst marks symnames ribcage mod) (let* ((rsymnames (vector-ref vx (#{1+}# 0)))
(let f ((symnames symnames) (rmarks (vector-ref vx (#{1+}# (#{1+}# 0))))
(rlabels (ribcage-labels ribcage)) (rlabels
(rmarks (ribcage-marks ribcage))) (vector-ref
(cond vx
((null? symnames) (search sym (cdr subst) marks mod)) (#{1+}# (#{1+}# (#{1+}# 0)))))
((and (eq? (car symnames) sym) (same-marks? marks (car rmarks))) (subst vy))
(let ((n (car rlabels))) (letrec* ((search-list-rib
(if (pair? n) (lambda ()
(if (equal? mod (car n)) (let lp ((rsymnames rsymnames)
(values (cdr n) marks) (rmarks rmarks)
(f (cdr symnames) (cdr rlabels) (cdr rmarks))) (rlabels rlabels))
(values n marks)))) (let* ((v rsymnames)
(else (f (cdr symnames) (cdr rlabels) (cdr rmarks))))))) (fk (lambda ()
(search-vector-rib (let ((fk (lambda ()
(lambda (sym subst marks symnames ribcage mod) (error "value failed to match"
(let ((n (vector-length symnames))) v))))
(let f ((i 0)) (if (pair? v)
(cond (let ((vx (car v))
((= i n) (search sym (cdr subst) marks mod)) (vy (cdr v)))
((and (eq? (vector-ref symnames i) sym) (let* ((rsym vx)
(same-marks? marks (vector-ref (ribcage-marks ribcage) i))) (rsymnames
(let ((n (vector-ref (ribcage-labels ribcage) i))) vy)
(if (pair? n) (v rmarks)
(if (equal? mod (car n)) (values (cdr n) marks) (f (#{1+}# i))) (fk (lambda ()
(values n marks)))) (error "value failed to match"
(else (f (#{1+}# i))))))))) v))))
(if (pair? v)
(let ((vx (car v))
(vy (cdr v)))
(let* ((rmarks1
vx)
(rmarks
vy)
(v rlabels)
(fk (lambda ()
(error "value failed to match"
v))))
(if (pair? v)
(let ((vx (car v))
(vy (cdr v)))
(let* ((label vx)
(rlabels
vy))
(if (and (eq? sym
rsym)
(same-marks?
marks
rmarks1))
(let* ((v label)
(fk (lambda ()
(let ((fk (lambda ()
(error "value failed to match"
v))))
label))))
(if (pair? v)
(let ((vx (car v))
(vy (cdr v)))
(let* ((mod* vx)
(label vy))
(if (equal?
mod*
mod)
label
(lp rsymnames
rmarks
rlabels))))
(fk)))
(lp rsymnames
rmarks
rlabels))))
(fk))))
(fk))))
(fk))))))
(if (null? v)
(search sym subst marks)
(fk))))))
(search-vector-rib
(lambda ()
(let ((n (vector-length rsymnames)))
(let lp ((i 0))
(cond
((= i n)
(search sym subst marks))
((and (eq? (vector-ref
rsymnames
i)
sym)
(same-marks?
marks
(vector-ref rmarks i)))
(let* ((v (vector-ref
rlabels
i))
(fk (lambda ()
(let* ((fk (lambda ()
(error "value failed to match"
v)))
(label v))
label))))
(if (pair? v)
(let ((vx (car v))
(vy (cdr v)))
(let* ((mod* vx)
(label vy))
(if (equal?
mod*
mod)
label
(lp (#{1+}# i)))))
(fk))))
(else (lp (#{1+}# i)))))))))
(if (vector? rsymnames)
(search-vector-rib)
(search-list-rib))))
(fk))
(fk)))
(fk))))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(if (eq? vx 'shift)
(let* ((subst vy)
(v marks)
(fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let ((marks vy)) (search sym subst marks)))
(fk)))
(fk)))
(fk))))))
(if (null? v) #f (fk))))))
(cond (cond
((symbol? id) (or (search id (wrap-subst w) (wrap-marks w) mod) id)) ((symbol? id) (or (search id (wrap-subst w) (wrap-marks w)) 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 (wrap-marks w) (wrap-marks w1)))) (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
(call-with-values (or (search id (wrap-subst w) marks) (search id (wrap-subst w1) marks) id))))
(lambda () (search id (wrap-subst w) marks mod))
(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)
@ -480,14 +583,12 @@
(nj (id-var-name j empty-wrap 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 (if mod (resolve-module (cdr mod)) (current-module)) (id-sym-name id)))))
(if mod (resolve-module (cdr mod)) (current-module))
(let ((x id)) (if (syntax? x) (syntax-expression x) x))))))
(cond (cond
((syntax? ni) (free-id=? ni j)) ((syntax? ni) (free-id=? ni j))
((syntax? nj) (free-id=? i nj)) ((syntax? nj) (free-id=? i nj))
((symbol? ni) ((symbol? ni)
(and (eq? nj (let ((x j)) (if (syntax? x) (syntax-expression x) x))) (and (eq? nj (id-sym-name j))
(let ((bi (id-module-binding i mi))) (let ((bi (id-module-binding i mi)))
(if bi (eq? bi (id-module-binding j mj)) (and (not (id-module-binding j mj)) (eq? ni nj)))) (if bi (eq? bi (id-module-binding j mj)) (and (not (id-module-binding j mj)) (eq? ni nj))))
(eq? (id-module-binding i mi) (id-module-binding j mj)))) (eq? (id-module-binding i mi) (id-module-binding j mj))))
@ -920,11 +1021,11 @@
(source-wrap e w (wrap-subst w) mod) (source-wrap e w (wrap-subst w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-f2c transformer-environment) (let* ((t-680b775fb37a463-fa5 transformer-environment)
(t-680b775fb37a463-f2d (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-fa6 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-f2c t-680b775fb37a463-fa5
t-680b775fb37a463-f2d t-680b775fb37a463-fa6
(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)
@ -1454,11 +1555,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-119a (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463-1
tmp-680b775fb37a463) tmp-680b775fb37a463)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-119a))) (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1726,8 +1827,8 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-6be tmp-680b775fb37a463-6bd tmp-680b775fb37a463-6bc) (map (lambda (tmp-680b775fb37a463-6bf tmp-680b775fb37a463-6be tmp-680b775fb37a463-6bd)
(cons tmp-680b775fb37a463-6bc (cons tmp-680b775fb37a463-6bd tmp-680b775fb37a463-6be))) (cons tmp-680b775fb37a463-6bd (cons tmp-680b775fb37a463-6be tmp-680b775fb37a463-6bf)))
e2 e2
e1 e1
args))) args)))
@ -1737,9 +1838,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-6d4 tmp-680b775fb37a463-6d3 tmp-680b775fb37a463-6d2) (map (lambda (tmp-680b775fb37a463-6d5 tmp-680b775fb37a463-6d4 tmp-680b775fb37a463-6d3)
(cons tmp-680b775fb37a463-6d2 (cons tmp-680b775fb37a463-6d3
(cons tmp-680b775fb37a463-6d3 tmp-680b775fb37a463-6d4))) (cons tmp-680b775fb37a463-6d4 tmp-680b775fb37a463-6d5)))
e2 e2
e1 e1
args))) args)))
@ -1770,9 +1871,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-69e tmp-680b775fb37a463-69d tmp-680b775fb37a463-69c) (map (lambda (tmp-680b775fb37a463-69f tmp-680b775fb37a463-69e tmp-680b775fb37a463-69d)
(cons tmp-680b775fb37a463-69c (cons tmp-680b775fb37a463-69d
(cons tmp-680b775fb37a463-69d tmp-680b775fb37a463-69e))) (cons tmp-680b775fb37a463-69e tmp-680b775fb37a463-69f)))
e2 e2
e1 e1
args))) args)))
@ -2553,9 +2654,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-12b5 tmp-680b775fb37a463-12b4 tmp-680b775fb37a463-12b3) (map (lambda (tmp-680b775fb37a463-132e tmp-680b775fb37a463-132d tmp-680b775fb37a463-132c)
(list (cons tmp-680b775fb37a463-12b3 tmp-680b775fb37a463-12b4) (list (cons tmp-680b775fb37a463-132c tmp-680b775fb37a463-132d)
tmp-680b775fb37a463-12b5)) tmp-680b775fb37a463-132e))
template template
pattern pattern
keyword))) keyword)))
@ -2570,11 +2671,8 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-12ce (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-12cd (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2))
tmp-680b775fb37a463-12cc)
(list (cons tmp-680b775fb37a463-12cc tmp-680b775fb37a463-12cd)
tmp-680b775fb37a463-12ce))
template template
pattern pattern
keyword))) keyword)))
@ -2586,11 +2684,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-12e7 (map (lambda (tmp-680b775fb37a463
tmp-680b775fb37a463-12e6 tmp-680b775fb37a463-135f
tmp-680b775fb37a463-12e5) tmp-680b775fb37a463-135e)
(list (cons tmp-680b775fb37a463-12e5 tmp-680b775fb37a463-12e6) (list (cons tmp-680b775fb37a463-135e tmp-680b775fb37a463-135f)
tmp-680b775fb37a463-12e7)) tmp-680b775fb37a463))
template template
pattern pattern
keyword))) keyword)))
@ -2606,11 +2704,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-2 (map (lambda (tmp-680b775fb37a463-137f
tmp-680b775fb37a463-1 tmp-680b775fb37a463-137e
tmp-680b775fb37a463) tmp-680b775fb37a463-137d)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) (list (cons tmp-680b775fb37a463-137d tmp-680b775fb37a463-137e)
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-137f))
template template
pattern pattern
keyword))) keyword)))
@ -2738,9 +2836,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-13b3) (map (lambda (tmp-680b775fb37a463-142c)
(list "value" (list "value"
tmp-680b775fb37a463-13b3)) tmp-680b775fb37a463-142c))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2766,9 +2864,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-13b8) (map (lambda (tmp-680b775fb37a463)
(list "value" (list "value"
tmp-680b775fb37a463-13b8)) tmp-680b775fb37a463))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2804,8 +2902,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-13ce) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-13ce)) (list "value" tmp-680b775fb37a463))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2825,8 +2923,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-13d3) (map (lambda (tmp-680b775fb37a463-144c)
(list "value" tmp-680b775fb37a463-13d3)) (list "value" tmp-680b775fb37a463-144c))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -2908,8 +3006,7 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-141c) (apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463))
(cons "vector" t-680b775fb37a463-141c))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2919,7 +3016,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463)) (k (map (lambda (tmp-680b775fb37a463-14a1)
(list "quote" tmp-680b775fb37a463-14a1))
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))))
@ -2930,8 +3028,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463 tmp)) (let ((t-680b775fb37a463-14b0 tmp))
(list "list->vector" t-680b775fb37a463))))))))))))))))) (list "list->vector" t-680b775fb37a463-14b0)))))))))))))))))
(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))))
@ -2943,9 +3041,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-14bf)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-14bf))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2961,14 +3059,14 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-145a (apply (lambda (t-680b775fb37a463-14d3
t-680b775fb37a463) t-680b775fb37a463-14d2)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-145a t-680b775fb37a463-14d3
t-680b775fb37a463)) t-680b775fb37a463-14d2))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2981,12 +3079,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) (apply (lambda (t-680b775fb37a463-14df)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-14df))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2999,12 +3097,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) (apply (lambda (t-680b775fb37a463-14eb)
(cons (make-syntax (cons (make-syntax
'vector 'vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-14eb))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3015,12 +3113,12 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-147e tmp)) (let ((t-680b775fb37a463-14f7 tmp))
(list (make-syntax (list (make-syntax
'list->vector 'list->vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-147e)))) t-680b775fb37a463-14f7))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1 (if tmp-1

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

@ -343,7 +343,7 @@
(define-syntax-rule (arg-check pred? e who) (define-syntax-rule (arg-check pred? e who)
(let ((x e)) (let ((x e))
(if (not (pred? x)) (syntax-violation who "invalid argument" x)))) (unless (pred? x) (syntax-violation who "invalid argument" x))))
;; compile-time environments ;; compile-time environments
@ -467,11 +467,10 @@
((syntax? x) (symbol? (syntax-expression x))) ((syntax? x) (symbol? (syntax-expression x)))
(else #f))) (else #f)))
(define-syntax-rule (id-sym-name e) (define (id-sym-name x)
(let ((x e)) (if (syntax? x)
(if (syntax? x) (syntax-expression x)
(syntax-expression x) x))
x)))
(define (id-sym-name&marks x w) (define (id-sym-name&marks x w)
(if (syntax? x) (if (syntax? x)
@ -638,63 +637,62 @@
;; case, this routine returns either a symbol, a syntax object, or ;; case, this routine returns either a symbol, a syntax object, or
;; a string label. ;; a string label.
;; ;;
(define-syntax-rule (first e) (define (search sym subst marks)
;; Rely on Guile's multiple-values truncation. (match subst
e) (() #f)
(define search (('shift . subst)
(lambda (sym subst marks mod) (match marks
(if (null? subst) ((_ . marks)
(values #f marks) (search sym subst marks))))
(let ((fst (car subst))) ((#('ribcage rsymnames rmarks rlabels) . subst)
(if (eq? fst 'shift) (define (search-list-rib)
(search sym (cdr subst) (cdr marks) mod) (let lp ((rsymnames rsymnames)
(let ((symnames (ribcage-symnames fst))) (rmarks rmarks)
(if (vector? symnames) (rlabels rlabels))
(search-vector-rib sym subst marks symnames fst mod) (match rsymnames
(search-list-rib sym subst marks symnames fst mod)))))))) (() (search sym subst marks))
(define search-list-rib ((rsym . rsymnames)
(lambda (sym subst marks symnames ribcage mod) (match rmarks
(let f ((symnames symnames) ((rmarks1 . rmarks)
(rlabels (ribcage-labels ribcage)) (match rlabels
(rmarks (ribcage-marks ribcage))) ((label . rlabels)
(cond (if (and (eq? sym rsym) (same-marks? marks rmarks1))
((null? symnames) (search sym (cdr subst) marks mod)) (match label
((and (eq? (car symnames) sym) (same-marks? marks (car rmarks))) ((mod* . label)
(let ((n (car rlabels))) (if (equal? mod* mod)
(if (pair? n) label
(if (equal? mod (car n)) (lp rsymnames rmarks rlabels)))
(values (cdr n) marks) (_ label))
(f (cdr symnames) (cdr rlabels) (cdr rmarks))) (lp rsymnames rmarks rlabels))))))))))
(values n marks)))) (define (search-vector-rib)
(else (f (cdr symnames) (cdr rlabels) (cdr rmarks))))))) (let ((n (vector-length rsymnames)))
(define search-vector-rib (let lp ((i 0))
(lambda (sym subst marks symnames ribcage mod) (cond
(let ((n (vector-length symnames))) ((= i n) (search sym subst marks))
(let f ((i 0)) ((and (eq? (vector-ref rsymnames i) sym)
(cond (same-marks? marks (vector-ref rmarks i)))
((= i n) (search sym (cdr subst) marks mod)) (match (vector-ref rlabels i)
((and (eq? (vector-ref symnames i) sym) ((mod* . label)
(same-marks? marks (vector-ref (ribcage-marks ribcage) i))) (if (equal? mod* mod)
(let ((n (vector-ref (ribcage-labels ribcage) i))) label
(if (pair? n) (lp (1+ i))))
(if (equal? mod (car n)) (label
(values (cdr n) marks) label)))
(f (1+ i))) (else (lp (1+ i)))))))
(values n marks)))) (if (vector? rsymnames)
(else (f (1+ i)))))))) (search-vector-rib)
(search-list-rib)))))
(cond (cond
((symbol? id) ((symbol? id)
(or (first (search id (wrap-subst w) (wrap-marks w) mod)) id)) (or (search id (wrap-subst w) (wrap-marks w)) id))
((syntax? id) ((syntax? id)
(let ((id (syntax-expression id)) (let ((id (syntax-expression id))
(w1 (syntax-wrap id)) (w1 (syntax-wrap id))
(mod (or (syntax-module id) mod))) (mod (or (syntax-module id) mod)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1)))) (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
(call-with-values (lambda () (search id (wrap-subst w) marks mod)) (or (search id (wrap-subst w) marks)
(lambda (new-id marks) (search id (wrap-subst w1) marks)
(or new-id id))))
(first (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))))
;; A helper procedure for syntax-locally-bound-identifiers, which ;; A helper procedure for syntax-locally-bound-identifiers, which