mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Beginnings of psyntax switch to new syntax objects

Browse source 
* module/ice-9/psyntax.scm: Baby steps towards support of a new
  representation of syntax objects.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2017-03-27 20:38:55 +02:00
parent 64c5cc58fc
commit eb84c2f2da
2 changed files with 2659 additions and 2630 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,7 +1,12 @@
(eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
(if #f #f) (if #f #f)
(letrec* (let ((syntax? (module-ref (current-module) 'syntax?))
(make-syntax (module-ref (current-module) 'make-syntax))
(syntax-expression (module-ref (current-module) 'syntax-expression))
(syntax-wrap (module-ref (current-module) 'syntax-wrap))
(syntax-module (module-ref (current-module) 'syntax-module)))
(letrec*
((make-void ((make-void
(lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src))) (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src)))
(make-const (make-const
@ -233,23 +238,24 @@
(begin (begin
(for-each maybe-name-value! ids val-exps) (for-each maybe-name-value! ids val-exps)
(make-letrec src in-order? ids vars val-exps body-exp))))) (make-letrec src in-order? ids vars val-exps body-exp)))))
(syntax-object?
(lambda (x)
(or (syntax? x)
(and (vector? x)
(= (vector-length x) 4)
(eqv? (vector-ref x 0) 'syntax-object)))))
(make-syntax-object (make-syntax-object
(lambda (expression wrap module) (lambda (expression wrap module)
(vector 'syntax-object expression wrap module))) (vector 'syntax-object expression wrap module)))
(syntax-object? (syntax-object-expression
(lambda (x) (lambda (obj)
(and (vector? x) (if (syntax? obj) (syntax-expression obj) (vector-ref obj 1))))
(= (vector-length x) 4) (syntax-object-wrap
(eq? (vector-ref x 0) 'syntax-object)))) (lambda (obj)
(syntax-object-expression (lambda (x) (vector-ref x 1))) (if (syntax? obj) (syntax-wrap obj) (vector-ref obj 2))))
(syntax-object-wrap (lambda (x) (vector-ref x 2))) (syntax-object-module
(syntax-object-module (lambda (x) (vector-ref x 3))) (lambda (obj)
(set-syntax-object-expression! (if (syntax? obj) (syntax-module obj) (vector-ref obj 3))))
(lambda (x update) (vector-set! x 1 update)))
(set-syntax-object-wrap!
(lambda (x update) (vector-set! x 2 update)))
(set-syntax-object-module!
(lambda (x update) (vector-set! x 3 update)))
(source-annotation (source-annotation
(lambda (x) (lambda (x)
(let ((props (source-properties (let ((props (source-properties
@ -627,7 +633,8 @@
(top-level-eval-hook e mod) (top-level-eval-hook e mod)
(if (memq 'load esew) (list (lambda () e)) '()))) (if (memq 'load esew) (list (lambda () e)) '())))
((memq 'load esew) ((memq 'load esew)
(list (lambda () (expand-install-global var type (expand e r w mod))))) (list (lambda ()
(expand-install-global var type (expand e r w mod)))))
(else '()))) (else '())))
((memv key '(c&e)) ((memv key '(c&e))
(let ((e (expand-install-global var type (expand e r w mod)))) (let ((e (expand-install-global var type (expand e r w mod))))
@ -992,11 +999,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-7fe transformer-environment) (let* ((t-680b775fb37a463-7f9 transformer-environment)
(t-680b775fb37a463-7ff (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-7fa (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-7fe t-680b775fb37a463-7f9
t-680b775fb37a463-7ff t-680b775fb37a463-7fa
(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))
@ -1306,7 +1313,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(any . any)))) (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
(if (and tmp-1 (if (and tmp-1
(apply (lambda (aok r) (apply (lambda (aok r)
(and (eq? (syntax->datum aok) #:allow-other-keys) (id? r))) (and (eq? (syntax->datum aok) #:allow-other-keys)
(id? r)))
tmp-1)) tmp-1))
(apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey)))) (apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey))))
tmp-1) tmp-1)
@ -1531,11 +1539,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-aef (map (lambda (tmp-680b775fb37a463-aea
tmp-680b775fb37a463-aee tmp-680b775fb37a463-ae9
tmp-680b775fb37a463-aed) tmp-680b775fb37a463-ae8)
(cons tmp-680b775fb37a463-aed (cons tmp-680b775fb37a463-ae8
(cons tmp-680b775fb37a463-aee tmp-680b775fb37a463-aef))) (cons tmp-680b775fb37a463-ae9 tmp-680b775fb37a463-aea)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1835,11 +1843,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-cbc (map (lambda (tmp-680b775fb37a463-cb7
tmp-680b775fb37a463-cbb tmp-680b775fb37a463-cb6
tmp-680b775fb37a463-cba) tmp-680b775fb37a463-cb5)
(cons tmp-680b775fb37a463-cba (cons tmp-680b775fb37a463-cb5
(cons tmp-680b775fb37a463-cbb tmp-680b775fb37a463-cbc))) (cons tmp-680b775fb37a463-cb6 tmp-680b775fb37a463-cb7)))
e2 e2
e1 e1
args))) args)))
@ -1851,11 +1859,11 @@
(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-cd2 (map (lambda (tmp-680b775fb37a463-ccd
tmp-680b775fb37a463-cd1 tmp-680b775fb37a463-ccc
tmp-680b775fb37a463-cd0) tmp-680b775fb37a463-ccb)
(cons tmp-680b775fb37a463-cd0 (cons tmp-680b775fb37a463-ccb
(cons tmp-680b775fb37a463-cd1 tmp-680b775fb37a463-cd2))) (cons tmp-680b775fb37a463-ccc tmp-680b775fb37a463-ccd)))
e2 e2
e1 e1
args))) args)))
@ -1878,11 +1886,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-cf2 (map (lambda (tmp-680b775fb37a463-ced
tmp-680b775fb37a463-cf1 tmp-680b775fb37a463-cec
tmp-680b775fb37a463-cf0) tmp-680b775fb37a463-ceb)
(cons tmp-680b775fb37a463-cf0 (cons tmp-680b775fb37a463-ceb
(cons tmp-680b775fb37a463-cf1 tmp-680b775fb37a463-cf2))) (cons tmp-680b775fb37a463-cec tmp-680b775fb37a463-ced)))
e2 e2
e1 e1
args))) args)))
@ -1894,11 +1902,11 @@
(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-d08 (map (lambda (tmp-680b775fb37a463-d03
tmp-680b775fb37a463-d07 tmp-680b775fb37a463-d02
tmp-680b775fb37a463-d06) tmp-680b775fb37a463-d01)
(cons tmp-680b775fb37a463-d06 (cons tmp-680b775fb37a463-d01
(cons tmp-680b775fb37a463-d07 tmp-680b775fb37a463-d08))) (cons tmp-680b775fb37a463-d02 tmp-680b775fb37a463-d03)))
e2 e2
e1 e1
args))) args)))
@ -2633,7 +2641,7 @@
(syntax-object-wrap e) (syntax-object-wrap e)
'() '()
(syntax-object-module e))) (syntax-object-module e)))
(else (match* e p '(()) '() #f))))))) (else (match* e p '(()) '() #f))))))))
(define with-syntax (define with-syntax
(make-syntax-transformer (make-syntax-transformer
@ -2806,11 +2814,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-115b (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-115a (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463) tmp-680b775fb37a463-2))
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-115a)
tmp-680b775fb37a463-115b))
template template
pattern pattern
keyword))) keyword)))
@ -2826,9 +2832,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-116f
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-116e
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-116d)
(list (cons tmp-680b775fb37a463-116d tmp-680b775fb37a463-116e)
tmp-680b775fb37a463-116f))
template template
pattern pattern
keyword))) keyword)))
@ -2843,11 +2851,9 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-118d (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-118c (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-118b) tmp-680b775fb37a463-2))
(list (cons tmp-680b775fb37a463-118b tmp-680b775fb37a463-118c)
tmp-680b775fb37a463-118d))
template template
pattern pattern
keyword))) keyword)))
@ -2863,11 +2869,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11ac (map (lambda (tmp-680b775fb37a463-11a7
tmp-680b775fb37a463-11ab tmp-680b775fb37a463-11a6
tmp-680b775fb37a463-11aa) tmp-680b775fb37a463-11a5)
(list (cons tmp-680b775fb37a463-11aa tmp-680b775fb37a463-11ab) (list (cons tmp-680b775fb37a463-11a5 tmp-680b775fb37a463-11a6)
tmp-680b775fb37a463-11ac)) tmp-680b775fb37a463-11a7))
template template
pattern pattern
keyword))) keyword)))
@ -3007,8 +3013,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-120f)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-120f))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3063,8 +3069,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-122f) (map (lambda (tmp-680b775fb37a463-122a)
(list "value" tmp-680b775fb37a463-122f)) (list "value" tmp-680b775fb37a463-122a))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3082,7 +3088,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463)) (map (lambda (tmp-680b775fb37a463-122f)
(list "value" tmp-680b775fb37a463-122f))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3171,8 +3178,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-127d) (apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463))
(cons "vector" t-680b775fb37a463-127d))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3207,9 +3213,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-12a7) (apply (lambda (t-680b775fb37a463-12a2)
(cons '#(syntax-object list ((top)) (hygiene guile)) (cons '#(syntax-object list ((top)) (hygiene guile))
t-680b775fb37a463-12a7)) t-680b775fb37a463-12a2))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3225,10 +3231,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-12bb t-680b775fb37a463-12ba) (apply (lambda (t-680b775fb37a463-12b6 t-680b775fb37a463-12b5)
(list '#(syntax-object cons ((top)) (hygiene guile)) (list '#(syntax-object cons ((top)) (hygiene guile))
t-680b775fb37a463-12bb t-680b775fb37a463-12b6
t-680b775fb37a463-12ba)) t-680b775fb37a463-12b5))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3241,9 +3247,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-12c7) (apply (lambda (t-680b775fb37a463-12c2)
(cons '#(syntax-object append ((top)) (hygiene guile)) (cons '#(syntax-object append ((top)) (hygiene guile))
t-680b775fb37a463-12c7)) t-680b775fb37a463-12c2))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3256,9 +3262,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-12d3) (apply (lambda (t-680b775fb37a463-12ce)
(cons '#(syntax-object vector ((top)) (hygiene guile)) (cons '#(syntax-object vector ((top)) (hygiene guile))
t-680b775fb37a463-12d3)) t-680b775fb37a463-12ce))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3269,9 +3275,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-12df tmp)) (let ((t-680b775fb37a463-12da tmp))
(list '#(syntax-object list->vector ((top)) (hygiene guile)) (list '#(syntax-object list->vector ((top)) (hygiene guile))
t-680b775fb37a463-12df)))) t-680b775fb37a463-12da))))
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

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

@ -165,7 +165,12 @@
(eval-when (compile) (eval-when (compile)
(set-current-module (resolve-module '(guile)))) (set-current-module (resolve-module '(guile))))
(let () (let ((syntax? (module-ref (current-module) 'syntax?))
(make-syntax (module-ref (current-module) 'make-syntax))
(syntax-expression (module-ref (current-module) 'syntax-expression))
(syntax-wrap (module-ref (current-module) 'syntax-wrap))
(syntax-module (module-ref (current-module) 'syntax-module)))
(define-syntax define-expansion-constructors (define-syntax define-expansion-constructors
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
@ -466,7 +471,25 @@
;; 'gensym' so that the generated identifier is reproducible. ;; 'gensym' so that the generated identifier is reproducible.
(module-gensym (symbol->string id))) (module-gensym (symbol->string id)))
(define-structure (syntax-object expression wrap module)) (define (syntax-object? x)
(or (syntax? x)
(and (vector? x)
(= (vector-length x) 4)
(eqv? (vector-ref x 0) 'syntax-object))))
(define (make-syntax-object expression wrap module)
(vector 'syntax-object expression wrap module))
(define (syntax-object-expression obj)
(if (syntax? obj)
(syntax-expression obj)
(vector-ref obj 1)))
(define (syntax-object-wrap obj)
(if (syntax? obj)
(syntax-wrap obj)
(vector-ref obj 2)))
(define (syntax-object-module obj)
(if (syntax? obj)
(syntax-module obj)
(vector-ref obj 3)))
(define-syntax no-source (identifier-syntax #f)) (define-syntax no-source (identifier-syntax #f))