(if (null? r)
'()
(let ((a (car r)))
- (if (memq (cadr a) '(macro syntax-parameter))
+ (if (memq (cadr a) '(macro syntax-parameter ellipsis))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
(global-extend
(values (car b) (cdr b) mod)))))
(let ((n (id-var-name id w mod)))
(cond ((syntax-object? n)
- (resolve-identifier n w r mod resolve-syntax-parameters?))
+ (if (not (eq? n id))
+ (resolve-identifier n w r mod resolve-syntax-parameters?)
+ (resolve-identifier
+ (syntax-object-expression n)
+ (syntax-object-wrap n)
+ r
+ (syntax-object-module n)
+ resolve-syntax-parameters?)))
((symbol? n)
(resolve-global
n
(let ((x (build-global-definition s var (expand e r w mod))))
(top-level-eval-hook x mod)
(lambda () x))
- (lambda () (build-global-definition s var (expand e r w mod)))))))
+ (call-with-values
+ (lambda () (resolve-identifier id '(()) r mod #t))
+ (lambda (type* value* mod*)
+ (if (eq? type* 'macro)
+ (top-level-eval-hook
+ (build-global-definition s var (build-void s))
+ mod))
+ (lambda () (build-global-definition s var (expand e r w mod)))))))))
((memv key '(define-syntax-form define-syntax-parameter-form))
(let* ((id (wrap value w mod))
(label (gen-label))
(syntax-violation #f "nonprocedure transformer" p)))))
(expand-void (lambda () (build-void #f)))
(ellipsis?
- (lambda (x)
- (and (nonsymbol-id? x)
- (free-id=? x '#(syntax-object ... ((top)) (hygiene guile))))))
+ (lambda (e r mod)
+ (and (nonsymbol-id? e)
+ (call-with-values
+ (lambda ()
+ (resolve-identifier
+ (make-syntax-object
+ '#{ $sc-ellipsis }#
+ (syntax-object-wrap e)
+ (syntax-object-module e))
+ '(())
+ r
+ mod
+ #f))
+ (lambda (type value mod)
+ (if (eq? type 'ellipsis)
+ (bound-id=? e value)
+ (free-id=? e '#(syntax-object ... ((top)) (hygiene guile)))))))))
(lambda-formals
(lambda (orig-args)
(letrec*
(call-with-values
(lambda () (gen-ref src (car value) (cdr value) maps))
(lambda (var maps) (values (list 'ref var) maps))))
- ((ellipsis? e) (syntax-violation 'syntax "misplaced ellipsis" src))
+ ((ellipsis? e r mod)
+ (syntax-violation 'syntax "misplaced ellipsis" src))
(else (values (list 'quote e) maps))))))
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
- (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots)) tmp-1))
- (apply (lambda (dots e) (gen-syntax src e r maps (lambda (x) #f) mod))
+ (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1))
+ (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
- (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots)) tmp-1))
+ (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1))
(apply (lambda (x dots y)
(let f ((y y)
(k (lambda (maps)
(syntax-violation 'syntax "extra ellipsis" src)
(values (gen-map x (car maps)) (cdr maps))))))))
(let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any))))
- (if (and tmp (apply (lambda (dots y) (ellipsis? dots)) tmp))
+ (if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp))
(apply (lambda (dots y)
(f y
(lambda (maps)
args)))
tmp)
(syntax-violation 'case-lambda "bad case-lambda*" e))))))))
+ (global-extend
+ 'core
+ 'with-ellipsis
+ (lambda (e r w s mod)
+ (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
+ (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp))
+ (apply (lambda (dots e1 e2)
+ (let ((id (if (symbol? dots)
+ '#{ $sc-ellipsis }#
+ (make-syntax-object
+ '#{ $sc-ellipsis }#
+ (syntax-object-wrap dots)
+ (syntax-object-module dots)))))
+ (let ((ids (list id))
+ (labels (list (gen-label)))
+ (bindings (list (cons 'ellipsis (source-wrap dots w s mod)))))
+ (let ((nw (make-binding-wrap ids labels w))
+ (nr (extend-env labels bindings r)))
+ (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod)))))
+ tmp)
+ (syntax-violation
+ 'with-ellipsis
+ "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend
'core
'let
'syntax-case
(letrec*
((convert-pattern
- (lambda (pattern keys)
+ (lambda (pattern keys ellipsis?)
(letrec*
((cvt* (lambda (p* n ids)
- (if (not (pair? p*))
- (cvt p* n ids)
- (call-with-values
- (lambda () (cvt* (cdr p*) n ids))
- (lambda (y ids)
- (call-with-values
- (lambda () (cvt (car p*) n ids))
- (lambda (x ids) (values (cons x y) ids))))))))
+ (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any))))
+ (if tmp
+ (apply (lambda (x y)
+ (call-with-values
+ (lambda () (cvt* y n ids))
+ (lambda (y ids)
+ (call-with-values
+ (lambda () (cvt x n ids))
+ (lambda (x ids) (values (cons x y) ids))))))
+ tmp)
+ (cvt p* n ids)))))
(v-reverse
(lambda (x)
(let loop ((r '()) (x x))
(gen-clause
(lambda (x keys clauses r pat fender exp mod)
(call-with-values
- (lambda () (convert-pattern pat keys))
+ (lambda ()
+ (convert-pattern pat keys (lambda (e) (ellipsis? e r mod))))
(lambda (p pvars)
- (cond ((not (distinct-bound-ids? (map car pvars)))
- (syntax-violation 'syntax-case "duplicate pattern variable" pat))
- ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
+ (cond ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars))
(syntax-violation 'syntax-case "misplaced ellipsis" pat))
+ ((not (distinct-bound-ids? (map car pvars)))
+ (syntax-violation 'syntax-case "duplicate pattern variable" pat))
(else
(let ((y (gen-var 'tmp)))
(build-call
(tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any))))
(if tmp
(apply (lambda (val key m)
- (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) key)
+ (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key)
(let ((x (gen-var 'tmp)))
(build-call
s
(if (equal? mod '(primitive))
(values 'primitive value)
(values 'global (cons value (cdr mod)))))
+ ((memv key '(ellipsis))
+ (values
+ 'ellipsis
+ (make-syntax-object
+ (syntax-object-expression value)
+ (anti-mark (syntax-object-wrap value))
+ (syntax-object-module value))))
(else (values 'other #f)))))))))))
(syntax-locally-bound-identifiers
(lambda (id)
"source expression failed to match any pattern"
tmp)))))))))))
-(define syntax-rules
+(define syntax-error
(make-syntax-transformer
- 'syntax-rules
+ 'syntax-error
'macro
- (lambda (xx)
- (let ((tmp-1 xx))
- (let ((tmp ($sc-dispatch tmp-1 '(_ each-any . #(each ((any . any) any))))))
- (if tmp
- (apply (lambda (k keyword pattern template)
- (list '#(syntax-object lambda ((top)) (hygiene guile))
- '(#(syntax-object x ((top)) (hygiene guile)))
- (vector
- '(#(syntax-object macro-type ((top)) (hygiene guile))
- .
- #(syntax-object
- syntax-rules
- ((top)
- #(ribcage
- #(syntax-rules)
- #((top))
- #(((hygiene guile)
- .
- #(syntax-object syntax-rules ((top)) (hygiene guile))))))
- (hygiene guile)))
- (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
- (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
- (cons '#(syntax-object x ((top)) (hygiene guile))
- (cons k
- (map (lambda (tmp-1 tmp)
- (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
- (list '#(syntax-object syntax ((top)) (hygiene guile))
- tmp-1)))
- template
- pattern))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
+ (if (if tmp
+ (apply (lambda (keyword operands message arg)
+ (string? (syntax->datum message)))
+ tmp)
+ #f)
+ (apply (lambda (keyword operands message arg)
+ (syntax-violation
+ (syntax->datum keyword)
+ (string-join
+ (cons (syntax->datum message)
+ (map (lambda (x) (object->string (syntax->datum x))) arg)))
+ (if (syntax->datum keyword) (cons keyword operands) #f)))
tmp)
- (let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any . any) any))))))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any . each-any))))
(if (if tmp
- (apply (lambda (k docstring keyword pattern template)
- (string? (syntax->datum docstring)))
- tmp)
+ (apply (lambda (message arg) (string? (syntax->datum message))) tmp)
#f)
- (apply (lambda (k docstring keyword pattern template)
- (list '#(syntax-object lambda ((top)) (hygiene guile))
- '(#(syntax-object x ((top)) (hygiene guile)))
- docstring
- (vector
- '(#(syntax-object macro-type ((top)) (hygiene guile))
- .
- #(syntax-object
- syntax-rules
- ((top)
- #(ribcage
- #(syntax-rules)
- #((top))
- #(((hygiene guile)
- .
- #(syntax-object syntax-rules ((top)) (hygiene guile))))))
- (hygiene guile)))
- (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
- (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
- (cons '#(syntax-object x ((top)) (hygiene guile))
- (cons k
- (map (lambda (tmp-1 tmp)
- (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
- (list '#(syntax-object syntax ((top)) (hygiene guile))
- tmp-1)))
- template
- pattern))))))
+ (apply (lambda (message arg)
+ (cons '#(syntax-object
+ syntax-error
+ ((top)
+ #(ribcage
+ #(syntax-error)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object syntax-error ((top)) (hygiene guile))))))
+ (hygiene guile))
+ (cons '(#f) (cons message arg))))
tmp)
(syntax-violation
#f
"source expression failed to match any pattern"
tmp-1)))))))))
+(define syntax-rules
+ (make-syntax-transformer
+ 'syntax-rules
+ 'macro
+ (lambda (xx)
+ (letrec*
+ ((expand-clause
+ (lambda (clause)
+ (let ((tmp-1 clause))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '((any . any)
+ (#(free-id #(syntax-object syntax-error ((top)) (hygiene guile)))
+ any
+ .
+ each-any)))))
+ (if (if tmp
+ (apply (lambda (keyword pattern message arg)
+ (string? (syntax->datum message)))
+ tmp)
+ #f)
+ (apply (lambda (keyword pattern message arg)
+ (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
+ (list '#(syntax-object syntax ((top)) (hygiene guile))
+ (cons '#(syntax-object syntax-error ((top)) (hygiene guile))
+ (cons (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
+ (cons message arg))))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '((any . any) any))))
+ (if tmp
+ (apply (lambda (keyword pattern template)
+ (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern)
+ (list '#(syntax-object syntax ((top)) (hygiene guile)) template)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))
+ (expand-syntax-rules
+ (lambda (dots keys docstrings clauses)
+ (let ((tmp-1 (list keys docstrings clauses (map expand-clause clauses))))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(each-any each-any #(each ((any . any) any)) each-any))))
+ (if tmp
+ (apply (lambda (k docstring keyword pattern template clause)
+ (let ((tmp (cons '#(syntax-object lambda ((top)) (hygiene guile))
+ (cons '(#(syntax-object x ((top)) (hygiene guile)))
+ (append
+ docstring
+ (list (vector
+ '(#(syntax-object macro-type ((top)) (hygiene guile))
+ .
+ #(syntax-object
+ syntax-rules
+ ((top)
+ #(ribcage
+ #(syntax-rules)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
+ (hygiene guile)))
+ (cons '#(syntax-object patterns ((top)) (hygiene guile))
+ pattern))
+ (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
+ (cons '#(syntax-object x ((top)) (hygiene guile))
+ (cons k clause)))))))))
+ (let ((form tmp))
+ (if dots
+ (let ((tmp dots))
+ (let ((dots tmp))
+ (list '#(syntax-object with-ellipsis ((top)) (hygiene guile))
+ dots
+ form)))
+ form))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
+ (let ((tmp xx))
+ (let ((tmp-1 ($sc-dispatch tmp '(_ each-any . #(each ((any . any) any))))))
+ (if tmp-1
+ (apply (lambda (k keyword pattern template)
+ (expand-syntax-rules
+ #f
+ k
+ '()
+ (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any . #(each ((any . any) any))))))
+ (if (if tmp-1
+ (apply (lambda (k docstring keyword pattern template)
+ (string? (syntax->datum docstring)))
+ tmp-1)
+ #f)
+ (apply (lambda (k docstring keyword pattern template)
+ (expand-syntax-rules
+ #f
+ k
+ (list docstring)
+ (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any . #(each ((any . any) any))))))
+ (if (if tmp-1
+ (apply (lambda (dots k keyword pattern template) (identifier? dots))
+ tmp-1)
+ #f)
+ (apply (lambda (dots k keyword pattern template)
+ (expand-syntax-rules
+ dots
+ k
+ '()
+ (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any any . #(each ((any . any) any))))))
+ (if (if tmp-1
+ (apply (lambda (dots k docstring keyword pattern template)
+ (if (identifier? dots) (string? (syntax->datum docstring)) #f))
+ tmp-1)
+ #f)
+ (apply (lambda (dots k docstring keyword pattern template)
+ (expand-syntax-rules
+ dots
+ k
+ (list docstring)
+ (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))))))))
+
(define define-syntax-rule
(make-syntax-transformer
'define-syntax-rule
HCoop / bpt / guile.git / blobdiff