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: Inline the single use of define-structure

Browse source 
* module/ice-9/psyntax.scm (define-structure): Remove, inline into use.
No predicate needed.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2024-11-15 13:56:04 +01:00
parent 8c78234e80
commit 3b230745fe
2 changed files with 60 additions and 106 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -177,13 +177,12 @@
(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) (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls))))))
(make-ribcage (lambda (symnames marks labels) (vector 'ribcage symnames marks labels))) (make-ribcage (lambda (symnames marks labels) (vector 'ribcage symnames marks labels)))
(ribcage? (lambda (x) (and (vector? x) (= (vector-length x) 4) (eq? (vector-ref x 0) 'ribcage)))) (ribcage-symnames (lambda (ribcage) (vector-ref ribcage 1)))
(ribcage-symnames (lambda (x) (vector-ref x 1))) (ribcage-marks (lambda (ribcage) (vector-ref ribcage 2)))
(ribcage-marks (lambda (x) (vector-ref x 2))) (ribcage-labels (lambda (ribcage) (vector-ref ribcage 3)))
(ribcage-labels (lambda (x) (vector-ref x 3))) (set-ribcage-symnames! (lambda (ribcage x) (vector-set! ribcage 1 x)))
(set-ribcage-symnames! (lambda (x update) (vector-set! x 1 update))) (set-ribcage-marks! (lambda (ribcage x) (vector-set! ribcage 2 x)))
(set-ribcage-marks! (lambda (x update) (vector-set! x 2 update))) (set-ribcage-labels! (lambda (ribcage x) (vector-set! ribcage 3 x)))
(set-ribcage-labels! (lambda (x update) (vector-set! x 3 update)))
(anti-mark (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w))))) (anti-mark (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w)))))
(new-mark (lambda () (gen-unique))) (new-mark (lambda () (gen-unique)))
(extend-ribcage! (extend-ribcage!
@ -795,11 +794,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-db0 transformer-environment) (let* ((t-680b775fb37a463-d6f transformer-environment)
(t-680b775fb37a463-db1 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-d70 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-db0 t-680b775fb37a463-d6f
t-680b775fb37a463-db1 t-680b775fb37a463-d70
(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)
@ -1329,11 +1328,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-102c (map (lambda (tmp-680b775fb37a463-feb
tmp-680b775fb37a463-102b tmp-680b775fb37a463-fea
tmp-680b775fb37a463-102a) tmp-680b775fb37a463-fe9)
(cons tmp-680b775fb37a463-102a (cons tmp-680b775fb37a463-fe9
(cons tmp-680b775fb37a463-102b tmp-680b775fb37a463-102c))) (cons tmp-680b775fb37a463-fea tmp-680b775fb37a463-feb)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1601,8 +1600,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-63b tmp-680b775fb37a463-63a tmp-680b775fb37a463)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-63a tmp-680b775fb37a463-63b)))
e2 e2
e1 e1
args))) args)))
@ -1612,9 +1611,8 @@
(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-68d tmp-680b775fb37a463-68c tmp-680b775fb37a463-68b) (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-64f)
(cons tmp-680b775fb37a463-68b (cons tmp-680b775fb37a463-64f (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
(cons tmp-680b775fb37a463-68c tmp-680b775fb37a463-68d)))
e2 e2
e1 e1
args))) args)))
@ -1634,8 +1632,8 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-63f) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(cons tmp-680b775fb37a463-63f (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1))) (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2 e2
e1 e1
args))) args)))
@ -1645,8 +1643,8 @@
(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-61b tmp-680b775fb37a463-61a tmp-680b775fb37a463)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-61a tmp-680b775fb37a463-61b)))
e2 e2
e1 e1
args))) args)))
@ -2443,8 +2441,9 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-115f) (map (lambda (tmp-680b775fb37a463 tmp-680b775fb37a463-111f tmp-680b775fb37a463-111e)
(list (cons tmp-680b775fb37a463-115f tmp-680b775fb37a463) tmp-680b775fb37a463-1)) (list (cons tmp-680b775fb37a463-111e tmp-680b775fb37a463-111f)
tmp-680b775fb37a463))
template template
pattern pattern
keyword))) keyword)))
@ -2456,9 +2455,9 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-117a tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-117a)) tmp-680b775fb37a463-2))
template template
pattern pattern
keyword))) keyword)))
@ -2633,9 +2632,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-124b) (map (lambda (tmp-680b775fb37a463-120a)
(list "value" (list "value"
tmp-680b775fb37a463-124b)) tmp-680b775fb37a463-120a))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2775,8 +2774,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-12af) (apply (lambda (t-680b775fb37a463-126e)
(cons "vector" t-680b775fb37a463-12af)) (cons "vector" t-680b775fb37a463-126e))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2786,8 +2785,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-12bb) (k (map (lambda (tmp-680b775fb37a463-127a)
(list "quote" tmp-680b775fb37a463-12bb)) (list "quote" tmp-680b775fb37a463-127a))
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))))
@ -2798,8 +2797,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-12ca tmp)) (let ((t-680b775fb37a463 tmp))
(list "list->vector" t-680b775fb37a463-12ca))))))))))))))))) (list "list->vector" t-680b775fb37a463)))))))))))))))))
(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))))
@ -2811,9 +2810,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-12d9) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12d9)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2829,14 +2828,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-12ed (apply (lambda (t-680b775fb37a463-12ac
t-680b775fb37a463-12ec) t-680b775fb37a463-12ab)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-12ed t-680b775fb37a463-12ac
t-680b775fb37a463-12ec)) t-680b775fb37a463-12ab))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2849,12 +2848,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-12f9) (apply (lambda (t-680b775fb37a463-12b8)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-12f9)) t-680b775fb37a463-12b8))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2867,12 +2866,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-12c4)
(cons (make-syntax (cons (make-syntax
'vector 'vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-12c4))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2883,12 +2882,12 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463 tmp)) (let ((t-680b775fb37a463-12d0 tmp))
(list (make-syntax (list (make-syntax
'list->vector 'list->vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463)))) t-680b775fb37a463-12d0))))
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

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

@ -123,57 +123,6 @@
fields))) fields)))
(lp (1+ n)))))))))) (lp (1+ n))))))))))
(define-syntax define-structure
(lambda (x)
(define construct-name
(lambda (template-identifier . args)
(datum->syntax
template-identifier
(string->symbol
(apply string-append
(map (lambda (x)
(if (string? x)
x
(symbol->string (syntax->datum x))))
args))))))
(syntax-case x ()
((_ (name id1 ...))
(and-map identifier? #'(name id1 ...))
(with-syntax
((constructor (construct-name #'name "make-" #'name))
(predicate (construct-name #'name #'name "?"))
((access ...)
(map (lambda (x) (construct-name x #'name "-" x))
#'(id1 ...)))
((assign ...)
(map (lambda (x)
(construct-name x "set-" #'name "-" x "!"))
#'(id1 ...)))
(structure-length
(+ (length #'(id1 ...)) 1))
((index ...)
(let f ((i 1) (ids #'(id1 ...)))
(if (null? ids)
'()
(cons i (f (+ i 1) (cdr ids)))))))
#'(begin
(define constructor
(lambda (id1 ...)
(vector 'name id1 ... )))
(define predicate
(lambda (x)
(and (vector? x)
(= (vector-length x) structure-length)
(eq? (vector-ref x 0) 'name))))
(define access
(lambda (x)
(vector-ref x index)))
...
(define assign
(lambda (x update)
(vector-set! x index update)))
...))))))
(let () (let ()
(define-expansion-constructors) (define-expansion-constructors)
(define-expansion-accessors lambda src meta body) (define-expansion-accessors lambda src meta body)
@ -545,13 +494,19 @@
(define (gen-label) (define (gen-label)
(gen-unique)) (gen-unique))
(define gen-labels (define (gen-labels ls)
(lambda (ls) (if (null? ls)
(if (null? ls) '()
'() (cons (gen-label) (gen-labels (cdr ls)))))
(cons (gen-label) (gen-labels (cdr ls))))))
(define-structure (ribcage symnames marks labels)) (define (make-ribcage symnames marks labels)
(vector 'ribcage symnames marks labels))
(define (ribcage-symnames ribcage) (vector-ref ribcage 1))
(define (ribcage-marks ribcage) (vector-ref ribcage 2))
(define (ribcage-labels ribcage) (vector-ref ribcage 3))
(define (set-ribcage-symnames! ribcage x) (vector-set! ribcage 1 x))
(define (set-ribcage-marks! ribcage x) (vector-set! ribcage 2 x))
(define (set-ribcage-labels! ribcage x) (vector-set! ribcage 3 x))
(define-syntax empty-wrap (identifier-syntax '(()))) (define-syntax empty-wrap (identifier-syntax '(())))
(define-syntax top-wrap (identifier-syntax '((top)))) (define-syntax top-wrap (identifier-syntax '((top))))