mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 21:40:33 +02:00
Beginnings of psyntax switch to new syntax objects
* 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
parent
64c5cc58fc
commit
eb84c2f2da
2 changed files with 2659 additions and 2630 deletions
|
|
@ -1,6 +1,11 @@
|
|||
(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
|
||||
(if #f #f)
|
||||
|
||||
(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
|
||||
(lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src)))
|
||||
|
|
@ -233,23 +238,24 @@
|
|||
(begin
|
||||
(for-each maybe-name-value! ids val-exps)
|
||||
(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
|
||||
(lambda (expression wrap module)
|
||||
(vector 'syntax-object expression wrap module)))
|
||||
(syntax-object?
|
||||
(lambda (x)
|
||||
(and (vector? x)
|
||||
(= (vector-length x) 4)
|
||||
(eq? (vector-ref x 0) 'syntax-object))))
|
||||
(syntax-object-expression (lambda (x) (vector-ref x 1)))
|
||||
(syntax-object-wrap (lambda (x) (vector-ref x 2)))
|
||||
(syntax-object-module (lambda (x) (vector-ref x 3)))
|
||||
(set-syntax-object-expression!
|
||||
(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)))
|
||||
(syntax-object-expression
|
||||
(lambda (obj)
|
||||
(if (syntax? obj) (syntax-expression obj) (vector-ref obj 1))))
|
||||
(syntax-object-wrap
|
||||
(lambda (obj)
|
||||
(if (syntax? obj) (syntax-wrap obj) (vector-ref obj 2))))
|
||||
(syntax-object-module
|
||||
(lambda (obj)
|
||||
(if (syntax? obj) (syntax-module obj) (vector-ref obj 3))))
|
||||
(source-annotation
|
||||
(lambda (x)
|
||||
(let ((props (source-properties
|
||||
|
|
@ -627,7 +633,8 @@
|
|||
(top-level-eval-hook e mod)
|
||||
(if (memq 'load esew) (list (lambda () e)) '())))
|
||||
((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 '())))
|
||||
((memv key '(c&e))
|
||||
(let ((e (expand-install-global var type (expand e r w mod))))
|
||||
|
|
@ -992,11 +999,11 @@
|
|||
(source-wrap e w (cdr w) mod)
|
||||
x))
|
||||
(else (decorate-source x s))))))
|
||||
(let* ((t-680b775fb37a463-7fe transformer-environment)
|
||||
(t-680b775fb37a463-7ff (lambda (k) (k e r w s rib mod))))
|
||||
(let* ((t-680b775fb37a463-7f9 transformer-environment)
|
||||
(t-680b775fb37a463-7fa (lambda (k) (k e r w s rib mod))))
|
||||
(with-fluid*
|
||||
t-680b775fb37a463-7fe
|
||||
t-680b775fb37a463-7ff
|
||||
t-680b775fb37a463-7f9
|
||||
t-680b775fb37a463-7fa
|
||||
(lambda ()
|
||||
(rebuild-macro-output
|
||||
(p (source-wrap e (anti-mark w) s mod))
|
||||
|
|
@ -1306,7 +1313,8 @@
|
|||
(let ((tmp-1 ($sc-dispatch tmp '(any . any))))
|
||||
(if (and tmp-1
|
||||
(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))
|
||||
(apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey))))
|
||||
tmp-1)
|
||||
|
|
@ -1531,11 +1539,11 @@
|
|||
s
|
||||
mod
|
||||
get-formals
|
||||
(map (lambda (tmp-680b775fb37a463-aef
|
||||
tmp-680b775fb37a463-aee
|
||||
tmp-680b775fb37a463-aed)
|
||||
(cons tmp-680b775fb37a463-aed
|
||||
(cons tmp-680b775fb37a463-aee tmp-680b775fb37a463-aef)))
|
||||
(map (lambda (tmp-680b775fb37a463-aea
|
||||
tmp-680b775fb37a463-ae9
|
||||
tmp-680b775fb37a463-ae8)
|
||||
(cons tmp-680b775fb37a463-ae8
|
||||
(cons tmp-680b775fb37a463-ae9 tmp-680b775fb37a463-aea)))
|
||||
e2*
|
||||
e1*
|
||||
args*)))
|
||||
|
|
@ -1835,11 +1843,11 @@
|
|||
(apply (lambda (args e1 e2)
|
||||
(build-it
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-cbc
|
||||
tmp-680b775fb37a463-cbb
|
||||
tmp-680b775fb37a463-cba)
|
||||
(cons tmp-680b775fb37a463-cba
|
||||
(cons tmp-680b775fb37a463-cbb tmp-680b775fb37a463-cbc)))
|
||||
(map (lambda (tmp-680b775fb37a463-cb7
|
||||
tmp-680b775fb37a463-cb6
|
||||
tmp-680b775fb37a463-cb5)
|
||||
(cons tmp-680b775fb37a463-cb5
|
||||
(cons tmp-680b775fb37a463-cb6 tmp-680b775fb37a463-cb7)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1851,11 +1859,11 @@
|
|||
(apply (lambda (docstring args e1 e2)
|
||||
(build-it
|
||||
(list (cons 'documentation (syntax->datum docstring)))
|
||||
(map (lambda (tmp-680b775fb37a463-cd2
|
||||
tmp-680b775fb37a463-cd1
|
||||
tmp-680b775fb37a463-cd0)
|
||||
(cons tmp-680b775fb37a463-cd0
|
||||
(cons tmp-680b775fb37a463-cd1 tmp-680b775fb37a463-cd2)))
|
||||
(map (lambda (tmp-680b775fb37a463-ccd
|
||||
tmp-680b775fb37a463-ccc
|
||||
tmp-680b775fb37a463-ccb)
|
||||
(cons tmp-680b775fb37a463-ccb
|
||||
(cons tmp-680b775fb37a463-ccc tmp-680b775fb37a463-ccd)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1878,11 +1886,11 @@
|
|||
(apply (lambda (args e1 e2)
|
||||
(build-it
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-cf2
|
||||
tmp-680b775fb37a463-cf1
|
||||
tmp-680b775fb37a463-cf0)
|
||||
(cons tmp-680b775fb37a463-cf0
|
||||
(cons tmp-680b775fb37a463-cf1 tmp-680b775fb37a463-cf2)))
|
||||
(map (lambda (tmp-680b775fb37a463-ced
|
||||
tmp-680b775fb37a463-cec
|
||||
tmp-680b775fb37a463-ceb)
|
||||
(cons tmp-680b775fb37a463-ceb
|
||||
(cons tmp-680b775fb37a463-cec tmp-680b775fb37a463-ced)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1894,11 +1902,11 @@
|
|||
(apply (lambda (docstring args e1 e2)
|
||||
(build-it
|
||||
(list (cons 'documentation (syntax->datum docstring)))
|
||||
(map (lambda (tmp-680b775fb37a463-d08
|
||||
tmp-680b775fb37a463-d07
|
||||
tmp-680b775fb37a463-d06)
|
||||
(cons tmp-680b775fb37a463-d06
|
||||
(cons tmp-680b775fb37a463-d07 tmp-680b775fb37a463-d08)))
|
||||
(map (lambda (tmp-680b775fb37a463-d03
|
||||
tmp-680b775fb37a463-d02
|
||||
tmp-680b775fb37a463-d01)
|
||||
(cons tmp-680b775fb37a463-d01
|
||||
(cons tmp-680b775fb37a463-d02 tmp-680b775fb37a463-d03)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -2633,7 +2641,7 @@
|
|||
(syntax-object-wrap e)
|
||||
'()
|
||||
(syntax-object-module e)))
|
||||
(else (match* e p '(()) '() #f)))))))
|
||||
(else (match* e p '(()) '() #f))))))))
|
||||
|
||||
(define with-syntax
|
||||
(make-syntax-transformer
|
||||
|
|
@ -2806,11 +2814,9 @@
|
|||
#f
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-115b
|
||||
tmp-680b775fb37a463-115a
|
||||
tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-115a)
|
||||
tmp-680b775fb37a463-115b))
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
|
||||
tmp-680b775fb37a463-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2826,9 +2832,11 @@
|
|||
#f
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
|
||||
tmp-680b775fb37a463-2))
|
||||
(map (lambda (tmp-680b775fb37a463-116f
|
||||
tmp-680b775fb37a463-116e
|
||||
tmp-680b775fb37a463-116d)
|
||||
(list (cons tmp-680b775fb37a463-116d tmp-680b775fb37a463-116e)
|
||||
tmp-680b775fb37a463-116f))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2843,11 +2851,9 @@
|
|||
dots
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-118d
|
||||
tmp-680b775fb37a463-118c
|
||||
tmp-680b775fb37a463-118b)
|
||||
(list (cons tmp-680b775fb37a463-118b tmp-680b775fb37a463-118c)
|
||||
tmp-680b775fb37a463-118d))
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
|
||||
tmp-680b775fb37a463-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2863,11 +2869,11 @@
|
|||
dots
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-680b775fb37a463-11ac
|
||||
tmp-680b775fb37a463-11ab
|
||||
tmp-680b775fb37a463-11aa)
|
||||
(list (cons tmp-680b775fb37a463-11aa tmp-680b775fb37a463-11ab)
|
||||
tmp-680b775fb37a463-11ac))
|
||||
(map (lambda (tmp-680b775fb37a463-11a7
|
||||
tmp-680b775fb37a463-11a6
|
||||
tmp-680b775fb37a463-11a5)
|
||||
(list (cons tmp-680b775fb37a463-11a5 tmp-680b775fb37a463-11a6)
|
||||
tmp-680b775fb37a463-11a7))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -3007,8 +3013,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist*
|
||||
(map (lambda (tmp-680b775fb37a463)
|
||||
(list "value" tmp-680b775fb37a463))
|
||||
(map (lambda (tmp-680b775fb37a463-120f)
|
||||
(list "value" tmp-680b775fb37a463-120f))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3063,8 +3069,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist*
|
||||
(map (lambda (tmp-680b775fb37a463-122f)
|
||||
(list "value" tmp-680b775fb37a463-122f))
|
||||
(map (lambda (tmp-680b775fb37a463-122a)
|
||||
(list "value" tmp-680b775fb37a463-122a))
|
||||
p)
|
||||
(vquasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3082,7 +3088,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasiappend
|
||||
(map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463))
|
||||
(map (lambda (tmp-680b775fb37a463-122f)
|
||||
(list "value" tmp-680b775fb37a463-122f))
|
||||
p)
|
||||
(vquasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3171,8 +3178,7 @@
|
|||
(let ((tmp-1 ls))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-127d)
|
||||
(cons "vector" t-680b775fb37a463-127d))
|
||||
(apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3207,9 +3213,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12a7)
|
||||
(apply (lambda (t-680b775fb37a463-12a2)
|
||||
(cons '#(syntax-object list ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12a7))
|
||||
t-680b775fb37a463-12a2))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3225,10 +3231,10 @@
|
|||
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(any any))))
|
||||
(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))
|
||||
t-680b775fb37a463-12bb
|
||||
t-680b775fb37a463-12ba))
|
||||
t-680b775fb37a463-12b6
|
||||
t-680b775fb37a463-12b5))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3241,9 +3247,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12c7)
|
||||
(apply (lambda (t-680b775fb37a463-12c2)
|
||||
(cons '#(syntax-object append ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12c7))
|
||||
t-680b775fb37a463-12c2))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3256,9 +3262,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-12d3)
|
||||
(apply (lambda (t-680b775fb37a463-12ce)
|
||||
(cons '#(syntax-object vector ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12d3))
|
||||
t-680b775fb37a463-12ce))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3269,9 +3275,9 @@
|
|||
(if tmp-1
|
||||
(apply (lambda (x)
|
||||
(let ((tmp (emit x)))
|
||||
(let ((t-680b775fb37a463-12df tmp))
|
||||
(let ((t-680b775fb37a463-12da tmp))
|
||||
(list '#(syntax-object list->vector ((top)) (hygiene guile))
|
||||
t-680b775fb37a463-12df))))
|
||||
t-680b775fb37a463-12da))))
|
||||
tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
|
||||
(if tmp-1
|
||||
|
|
|
|||
|
|
@ -165,7 +165,12 @@
|
|||
(eval-when (compile)
|
||||
(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
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
|
|
@ -466,7 +471,25 @@
|
|||
;; 'gensym' so that the generated identifier is reproducible.
|
||||
(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))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue