mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 08:50:23 +02:00
Code Activity

Avoid quadratic behavior in id-var-name

Browse source 
* module/ice-9/psyntax.scm (id-var-name): Avoid list-ref.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2022-01-13 09:26:25 +01:00
parent 1148eb5051
commit 52e310a2ac
2 changed files with 67 additions and 60 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -410,17 +410,18 @@
(search-list-rib sym subst marks symnames fst mod)))))))) (search-list-rib sym subst marks symnames fst mod))))))))
(search-list-rib (search-list-rib
(lambda (sym subst marks symnames ribcage mod) (lambda (sym subst marks symnames ribcage mod)
(let f ((symnames symnames) (i 0)) (let f ((symnames symnames)
(rlabels (ribcage-labels ribcage))
(rmarks (ribcage-marks ribcage)))
(cond ((null? symnames) (search sym (cdr subst) marks mod)) (cond ((null? symnames) (search sym (cdr subst) marks mod))
((and (eq? (car symnames) sym) ((and (eq? (car symnames) sym) (same-marks? marks (car rmarks)))
(same-marks? marks (list-ref (ribcage-marks ribcage) i))) (let ((n (car rlabels)))
(let ((n (list-ref (ribcage-labels ribcage) i)))
(if (pair? n) (if (pair? n)
(if (equal? mod (car n)) (if (equal? mod (car n))
(values (cdr n) marks) (values (cdr n) marks)
(f (cdr symnames) (+ i 1))) (f (cdr symnames) (cdr rlabels) (cdr rmarks)))
(values n marks)))) (values n marks))))
(else (f (cdr symnames) (+ i 1))))))) (else (f (cdr symnames) (cdr rlabels) (cdr rmarks)))))))
(search-vector-rib (search-vector-rib
(lambda (sym subst marks symnames ribcage mod) (lambda (sym subst marks symnames ribcage mod)
(let ((n (vector-length symnames))) (let ((n (vector-length symnames)))
@ -1043,11 +1044,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x s)))))) (else (decorate-source x s))))))
(let* ((t-680b775fb37a463-dd8 transformer-environment) (let* ((t-680b775fb37a463-ddd transformer-environment)
(t-680b775fb37a463-dd9 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-dde (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-dd8 t-680b775fb37a463-ddd
t-680b775fb37a463-dd9 t-680b775fb37a463-dde
(lambda () (lambda ()
(rebuild-macro-output (rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod)) (p (source-wrap e (anti-mark w) s mod))
@ -1616,11 +1617,9 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-104d (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-104c (cons tmp-680b775fb37a463
tmp-680b775fb37a463-104b) (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
(cons tmp-680b775fb37a463-104b
(cons tmp-680b775fb37a463-104c tmp-680b775fb37a463-104d)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1786,10 +1785,13 @@
(lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod)) (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod))
(lambda (e maps) (values (gen-vector e) maps)))) (lambda (e maps) (values (gen-vector e) maps))))
tmp-1) 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 '()))) (let ((tmp ($sc-dispatch tmp '())))
(if tmp (if tmp
(apply (lambda () (values ''() maps)) tmp) (apply (lambda () (values ''() maps)) tmp)
(values (list 'quote e) maps)))))))))))))) (values (list 'quote e) maps))))))))))))))))
(gen-ref (gen-ref
(lambda (src var level maps) (lambda (src var level maps)
(cond ((= level 0) (values var maps)) (cond ((= level 0) (values var maps))
@ -2898,9 +2900,11 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-116d
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-116c
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-116b)
(list (cons tmp-680b775fb37a463-116b tmp-680b775fb37a463-116c)
tmp-680b775fb37a463-116d))
template template
pattern pattern
keyword))) keyword)))
@ -2916,9 +2920,9 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-117f) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463-117f tmp-680b775fb37a463) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-1)) tmp-680b775fb37a463-2))
template template
pattern pattern
keyword))) keyword)))
@ -2933,9 +2937,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-119a tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-119f
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-119e
tmp-680b775fb37a463-119a)) tmp-680b775fb37a463-119d)
(list (cons tmp-680b775fb37a463-119d tmp-680b775fb37a463-119e)
tmp-680b775fb37a463-119f))
template template
pattern pattern
keyword))) keyword)))
@ -2951,11 +2957,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11b9 (map (lambda (tmp-680b775fb37a463-11be
tmp-680b775fb37a463-11b8 tmp-680b775fb37a463-11bd
tmp-680b775fb37a463-11b7) tmp-680b775fb37a463-11bc)
(list (cons tmp-680b775fb37a463-11b7 tmp-680b775fb37a463-11b8) (list (cons tmp-680b775fb37a463-11bc tmp-680b775fb37a463-11bd)
tmp-680b775fb37a463-11b9)) tmp-680b775fb37a463-11be))
template template
pattern pattern
keyword))) keyword)))
@ -3103,8 +3109,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-126e)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-126e))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3127,8 +3133,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-126e) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-126e)) (list "value" tmp-680b775fb37a463))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3181,8 +3187,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-128e)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-128e))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3272,8 +3278,8 @@
(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-12d2) (apply (lambda (t-680b775fb37a463-12d7)
(cons "vector" t-680b775fb37a463-12d2)) (cons "vector" t-680b775fb37a463-12d7))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3283,8 +3289,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-12de) (k (map (lambda (tmp-680b775fb37a463-12e3)
(list "quote" tmp-680b775fb37a463-12de)) (list "quote" tmp-680b775fb37a463-12e3))
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))))
@ -3295,8 +3301,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-12ed tmp)) (let ((t-680b775fb37a463-12f2 tmp))
(list "list->vector" t-680b775fb37a463-12ed))))))))))))))))) (list "list->vector" t-680b775fb37a463-12f2)))))))))))))))))
(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))))
@ -3309,9 +3315,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-12fc) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12fc)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3327,10 +3333,10 @@
(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 t-680b775fb37a463-130f) (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463 t-680b775fb37a463-1
t-680b775fb37a463-130f)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3343,9 +3349,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-131c) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-131c)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3358,9 +3364,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-132d)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-132d))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f

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

@ -744,18 +744,19 @@
(search-list-rib sym subst marks symnames fst mod)))))))) (search-list-rib sym subst marks symnames fst mod))))))))
(define search-list-rib (define search-list-rib
(lambda (sym subst marks symnames ribcage mod) (lambda (sym subst marks symnames ribcage mod)
(let f ((symnames symnames) (i 0)) (let f ((symnames symnames)
(rlabels (ribcage-labels ribcage))
(rmarks (ribcage-marks ribcage)))
(cond (cond
((null? symnames) (search sym (cdr subst) marks mod)) ((null? symnames) (search sym (cdr subst) marks mod))
((and (eq? (car symnames) sym) ((and (eq? (car symnames) sym) (same-marks? marks (car rmarks)))
(same-marks? marks (list-ref (ribcage-marks ribcage) i))) (let ((n (car rlabels)))
(let ((n (list-ref (ribcage-labels ribcage) i)))
(if (pair? n) (if (pair? n)
(if (equal? mod (car n)) (if (equal? mod (car n))
(values (cdr n) marks) (values (cdr n) marks)
(f (cdr symnames) (fx+ i 1))) (f (cdr symnames) (cdr rlabels) (cdr rmarks)))
(values n marks)))) (values n marks))))
(else (f (cdr symnames) (fx+ i 1))))))) (else (f (cdr symnames) (cdr rlabels) (cdr rmarks)))))))
(define search-vector-rib (define search-vector-rib
(lambda (sym subst marks symnames ribcage mod) (lambda (sym subst marks symnames ribcage mod)
(let ((n (vector-length symnames))) (let ((n (vector-length symnames)))