X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/61989c705359c50c61d7f52392f244d386218298..ef7a71b768c583d795b5de6b0c49177e7dfb0dbf:/module/ice-9/psyntax-pp.scm

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index eeffecf38..6029f0565 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -276,7 +276,7 @@
        (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
@@ -463,7 +463,14 @@
                 (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
@@ -591,7 +598,14 @@
                                        (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))
@@ -1129,9 +1143,23 @@
            (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*
@@ -1607,14 +1635,15 @@
                           (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)
@@ -1625,7 +1654,7 @@
                                                  (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)
@@ -1847,6 +1876,30 @@
                                 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
@@ -2103,17 +2156,20 @@
     '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))
@@ -2194,12 +2250,13 @@
        (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
@@ -2273,7 +2330,7 @@
                (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
@@ -2398,6 +2455,13 @@
                             (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)
@@ -2579,80 +2643,197 @@
                       "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