Write a first draft macro expander.

Committing it because it compiles. I have to write tests and debug
it still.

1 files changed, 348 insertions, 104 deletions

diff --git a/csc/macros.csc b/csc/macros.csc
index a41a4a7..d8903eb 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -3,20 +3,31 @@
     expand
     test-environment)
   (import (scheme base)
-          (only (csc gensym) gensym)
+          (only (csc format) sprintf)
+          (only (csc gensym)
+            gensym
+            gensym=?)
           (only (csc hash-map)
             alist->map
             hash-bytevector
             insert
             key-not-found-error?
-            lookup)
+            lookup
+            merge)
           (only (csc ir1)
+            lexical-ref-gensym
+            lexical-ref?
+            library-ref-library
+            library-ref-name
+            library-ref?
             make-call
             make-constant
             make-lambda
-            make-lambda-case)
+            make-lambda-case
+            make-library-ref)
           (only (csc list) revappend)
-          (only (csc match) match))
+          (only (csc match) match)
+          (only (csc strings) join))
   (begin
 
 
@@ -37,9 +48,9 @@
       (raise (make-macro-syntax-error message irritants)))
 
 
-    ; symbols is a map with symbols as keys, and the values can be one of:
+    ; symbols is a map with identifiers as keys, and the values can be one of:
     ; - <lexical-ref>,
-    ; - <module-ref>,
+    ; - <library-ref>,
     ; - or <macro-transformer>.
     ; The first two correspond to variables bound lexically or from a module,
     ; and the third represents a macro transformer bound in the
@@ -50,135 +61,368 @@
     (define-record-type <environment>
       (make-environment symbols library)
       environment?
-      (symbols environment-symbols)
+      (symbols environment-substitutions)
       (library environment-library))
 
 
-    (define (with-binding environment symbol binding)
-      (make-environment (insert (environment-symbols environment) symbol binding) (environment-library environment)))
+    (define (with-binding environment identifier binding)
+      (make-environment (insert (environment-substitutions environment) identifier binding) (environment-library environment)))
 
 
-    (define (expand-procedure-call procedure arguments environment)
-      (let*-values (((expanded-procedure environment) (expand procedure environment))
-                    ((expanded-arguments environment)
+    (define-record-type <syntax-object>
+      (make-syntax-object expression environment marks)
+      syntax-object?
+      (expression syntax-object-expression)
+      (environment syntax-object-environment)
+      (marks syntax-object-marks))
+
+
+    (define (wrap-syntax expression environment)
+      (if (syntax-object? expression)
+        expression
+        (make-syntax-object expression environment '())))
+
+
+    (define (identifier? s)
+      (or (symbol? s)
+          (and (syntax-object? s)
+               (symbol? (syntax-object-expression s)))))
+
+
+    (define (marks s)
+      (if (syntax-object? s)
+        (syntax-object-marks s)
+        '()))
+
+
+    (define (marks=? m1 m2)
+      (and
+        (= (length m1) (length m2))
+        (let loop ((m1 m1)
+                   (m2 m2))
+          (if (null? m1)
+            #t
+            (and (= (car m1) (car m2)) (loop (cdr m1) (cdr m2)))))))
+
+
+    (define (identifier-name s)
+      (if (syntax-object? s)
+        (syntax-object-expression s)
+        s))
+
+
+    (define (bound-identifier=? s1 s2)
+      (and (symbol=? (identifier-name s1) (identifier-name s2))
+           (marks=? (marks s1) (marks s2))))
+
+
+    (define (binding=? b1 b2)
+      (or (and (lexical-ref? b1)
+               (lexical-ref? b2)
+               (gensym=? (lexical-ref-gensym b1) (lexical-ref-gensym b2)))
+          (and (library-ref? b1)
+               (library-ref? b2)
+               (equal? (library-ref-library b1) (library-ref-library b2))
+               (symbol=? (library-ref-name b1) (library-ref-name b2)))
+          (and (macro-transformer? b1)
+               (macro-transformer? b2)
+               (eq? (transformer-function b1) (transformer-function b2)))))
+
+
+    ; free-identifier=? only works on wrapped syntax objects.
+    (define (free-identifier=? s1 s2)
+      (let ((s1-binding (guard (e ((key-not-found-error? e) #f))
+                          (lookup (environment-substitutions (syntax-object-environment s1)) s1)))
+            (s2-binding (guard (e ((key-not-found-error? e) #f))
+                          (lookup (environment-substitutions (syntax-object-environment s2)) s2))))
+        (or (and (not s1-binding) (not s2-binding))
+            (binding=? s1-binding s2-binding))))
+
+
+    (define *next-mark* 0)
+
+
+    (define (new-mark)
+      (let ((m *next-mark*))
+        (set! *next-mark* (+ 1 *next-mark*))
+        m))
+
+
+    (define (add-mark mark expression)
+      (make-syntax-object
+        (syntax-object-expression expression)
+        (syntax-object-environment expression)
+        (if (and (pair? (syntax-object-marks expression))
+                 (not (car (syntax-object-marks expression))))  ; Anti-mark.
+          (cdr (syntax-object-marks expression))
+          (cons mark (syntax-object-marks expression)))))
+
+
+    (define (add-marks marks expression)
+      (let loop ((marks marks)
+                 (expression expression))
+        (match marks
+          ('() expression)
+          ((mark . marks)
+           (loop marks (add-mark mark expression))))))
+
+
+    (define (anti-mark expression)
+      (add-mark #f expression))
+
+
+    (define (decorate marks expression environment)
+      (add-marks marks (wrap-syntax expression environment)))
+
+
+    (define (with-wrap expression parent)
+      (decorate (marks parent) expression (syntax-object-environment parent)))
+
+
+    (define (syntax-map f expr)
+      (with-wrap (f (syntax->expression expr)) expr))
+
+
+    (define-record-type <syntax-case-no-match>
+      (make-syntax-case-no-match)
+      syntax-case-no-match?)
+
+
+    (define-syntax syntax-case-match-pattern
+      (syntax-rules (_ when)
+        ((syntax-case-match-pattern x pattern (when condition) result result* ...)
+          (syntax-case-match-pattern x pattern
+            (if condition
+              (begin result result* ...)
+              (raise (make-syntax-case-no-match)))))
+        ((syntax-case-match-pattern x _ result result* ...)
+          (begin result result* ...))
+        ((syntax-case-match-pattern x '() result result* ...)
+          (if (null? (syntax->expression x))
+            (begin result result* ...)
+            (raise (make-syntax-case-no-match))))
+        ((syntax-case-match-pattern x (pattern) result result* ...)
+          (if (= 1 (length (syntax->expression x)))
+            (syntax-case-match-pattern (syntax-map car x) pattern result result* ...)
+            (raise (make-syntax-case-no-match))))
+        ((syntax-case-match-pattern x (pattern . rest) result result* ...)
+          (let ((y x))
+            (if (pair? (syntax->expression y))
+              (syntax-case-match-pattern (syntax-map car y) pattern
+                (syntax-case-match-pattern (syntax-map cdr y) rest result result* ...)))))
+        ((syntax-case-match-pattern x ident result result* ...)
+          (let ((ident x)) result result* ...))))
+
+
+    ; Yes, I just defined syntax-case in terms of syntax-rules.
+    ; Are we sure this won't create a black hole?
+    (define-syntax syntax-case
+      (syntax-rules ()
+        ((syntax-case x (arm ...))
+          (guard (e ((syntax-case-no-match? e) (if #f #f)))
+            (syntax-case-match-pattern x arm ...)))
+        ((syntax-case x (arm ...) clause clause* ...)
+          (let ((y x))
+            (guard (e ((syntax-case-no-match? e)
+                        (syntax-case y clause clause* ...)))
+              (syntax-case-match-pattern y arm ...))))))
+
+
+    (define (expand-procedure-call procedure arguments)
+      (let-values (((expanded-procedure environment) (expand-syntax-object procedure))
+                   ((expanded-arguments)
                      (let loop ((arguments arguments)
-                                (environment environment)
                                 (expanded-arguments '()))
-                       (match arguments
-                         ('() (values (reverse expanded-arguments) environment))
+                       (syntax-case arguments
+                         ('() (reverse expanded-arguments))
                          ((argument . rest)
-                          (let-values (((expanded-argument environment) (expand argument environment)))
-                            (loop
-                              rest
-                              environment
-                              (cons expanded-argument expanded-arguments))))
+                           (let-values (((expanded-argument environment) (expand-syntax-object argument)))
+                             (loop
+                               rest
+                               (cons expanded-argument expanded-arguments))))
                          (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments))))))
         (make-call expanded-procedure expanded-arguments)))
 
 
+    ; From R6RS:
+    ; Each time the expander encounters a macro use, it applies an antimark to
+    ; the input form, invokes the associated transformer, then applies a fresh
+    ; mark to the output.
+    ;
+    ; In cute scheme, macros compile themselves, and syntax-rules is therefore
+    ; responsible for applying a mark to an expanded expression before
+    ; expanding it with expand-syntax-object.
+    (define (expand-macro-use transformer syntax)
+      ((transformer-function transformer) (anti-mark syntax)))
+
+
+    (define (expand-syntax-object syntax)
+      (syntax-case syntax
+        ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" syntax))
+        ((macro-name . tail) (when (identifier? macro-name))
+          (let ((macro-body
+                  (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" macro-name)))
+                    (lookup (environment-substitutions (syntax-object-environment macro-name)) macro-name))))
+            (if (macro-transformer? macro-body)
+              (expand-macro-use macro-body syntax)
+              (values (expand-procedure-call macro-name tail) (syntax-object-environment syntax)))))
+        ((procedure . arguments)
+          (values (expand-procedure-call procedure arguments) (syntax-object-environment syntax)))
+        (_ (when (identifier? syntax))
+          (let ((binding
+                  (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" syntax)))
+                    (lookup (environment-substitutions (syntax-object-environment syntax)) syntax))))
+            (if (macro-transformer? binding)
+              (raise-syntax-error "macro is not allowed in this context" syntax)
+              (values binding (syntax-object-environment syntax)))))
+        (_ (when (let ((expr (syntax->expression syntax)))
+                   (or (boolean? expr)
+                       (char? expr)
+                       (number? expr)
+                       (string? expr)
+                       (vector? expr))))
+          (values (make-constant (syntax->expression syntax)) (syntax-object-environment syntax)))
+        (_ (raise-syntax-error "unexpected expression type" syntax))))
+
+
     ; expand can be thought of as a compiler from Scheme to IR1. Macros
     ; included in the environment can be used to extend the syntax. Returns an
     ; IR1 expression and an environment which has been modified with any new
     ; bindings introduced by the expression.
     (define (expand expression environment)
-      (cond
-        ((null? expression) (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" expression))
-        ((and (pair? expression)
-              (symbol? (car expression)))
-         (let* ((macro-name (car expression))
-                (macro-body
-                  (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" macro-name)))
-                    (lookup (environment-symbols environment) macro-name))))
-           (if (macro-transformer? macro-body)
-             ((transformer-function macro-body) expression environment)
-             (expand-procedure-call macro-name (cdr expression) environment))))
-        ((pair? expression)
-         (let ((procedure (car expression))
-               (arguments (cdr expression)))
-           (expand-procedure-call procedure arguments environment)))
-        ((symbol? expression)
-         (let ((binding
-                 (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" expression)))
-                   (lookup (environment-symbols environment) expression))))
-           (if (macro-transformer? binding)
-             (raise-syntax-error "macro is not allowed in this context" expression)
-             (values binding environment))))
-        ((or (boolean? expression)
-             (bytevector? expression)
-             (char? expression)
-             (number? expression)
-             (string? expression)
-             (vector? expression))
-         (values (make-constant expression) environment))
-        (else (raise-syntax-error "unexpected expression type" expression))))
+      (expand-syntax-object (wrap-syntax expression environment)))
 
 
     (define builtin-quote
       (make-macro-transformer
-        (lambda (expression environment)
-          (match expression
-            ((_ datum) (values (make-constant datum) environment))
-            (_ (raise-syntax-error "invalid form for quote" expression))))))
+        (lambda (syntax)
+          (syntax-case syntax
+            ((_ datum) (values (make-constant (syntax->expression datum)) (syntax-object-environment syntax)))
+            (_ (raise-syntax-error "invalid form for quote" syntax))))))
 
 
-    (define builtin-lambda
-      (make-macro-transformer
-        (lambda (expression environment)
-          (match expression
-            ((_ formals body)
-             (let loop ((formals formals)
-                        (environment environment)
-                        (argument-names '())
-                        (gensyms '()))
-               (match formals
-                 ('()
-                  (make-lambda
-                    (make-lambda-case
-                      (reverse argument-names)
-                      #f
-                      (reverse gensyms)
-                      (expand body environment)
-                      #f)))
-                 ((variable . variables) (when (symbol? variable))
-                  (let ((sym (gensym)))
-                    (loop
-                      variables
-                      (with-binding environment variable sym)
-                      (cons variable argument-names)
-                      (cons sym gensyms))))
-                 (variable (when (symbol? variable))
-                   (let ((sym (gensym)))
-                     (make-lambda
-                       (make-lambda-case
-                         (reverse argument-names)
-                         variable
-                         (revappend gensyms (list sym))
-                         (expand body (with-binding environment variable sym))
-                         #f))))
-                 (_ (raise-syntax-error "invalid form for lambda arguments" expression)))))
-            (_ (raise-syntax-error "invalid form for lambda" expression))))))
+    (define (syntax->expression s)
+      (if (syntax-object? s)
+        (syntax-object-expression s)
+        s))
 
 
-    #;(define builtin-syntax-rules
-      (make-macro-transformer
-        (lambda (expression environment)
-          (match expression))))
+    (define (matches-literals literals object)
+      (unless (list? (syntax->expression literals))
+        (raise-syntax-error "invalid form in literals, expecting list" literals))
+      (let ((literal-identifiers
+              (map
+                (lambda (lit) (with-wrap lit literals))
+                (syntax->expression literals))))
+        (let loop ((literal-identifiers literal-identifiers))
+          (match literal-identifiers
+            ('() #f)
+            ((lit . literals)
+              (or (free-identifier=? lit object)
+                  (loop literals)))))))
 
 
-    (define (hash-symbol s)
-      (hash-bytevector (string->utf8 (symbol->string s))))
+    (define (identifier-uuid i)
+      ; Join marks by ( because symbols aren't allowed to have ( in the name.
+      (sprintf "{}({}" (apply join "(" (map number->string (marks i))) (identifier-name i)))
 
 
-    (define (symbol<? s1 s2)
-      (string<? (symbol->string s1) (symbol->string s2)))
+    (define (hash-identifier i)
+      (hash-bytevector (string->utf8 (identifier-uuid i))))
+
+
+    (define (cmp-identifier i1 i2)
+      (cond
+        ((string<? (identifier-uuid i1) (identifier-uuid i2)) -1)
+        ((string=? (identifier-uuid i1) (identifier-uuid i2)) 0)
+        (else 1)))
+
+
+    (define (alist->substitutions l)
+      (alist->map hash-identifier cmp-identifier l))
+
+
+    (define (is-underscore expression)
+      (free-identifier=?
+        expression
+        (wrap-syntax '_ (make-environment (alist->substitutions (list (cons '_ (make-library-ref '(csc builtins) '_ #t)))) '()))))
+
+
+    (define (pattern-bindings pattern literals object)
+      (syntax-case pattern
+        (lit (when (and (free-identifier=? object lit)
+                        (matches-literals literals object)))
+          (alist->substitutions '()))
+        (underscore (when (is-underscore underscore))
+          (alist->substitutions '()))
+        (ident (when (identifier? ident))
+          (alist->substitutions (list (cons ident object))))
+        ('()
+          (syntax-case object
+            ('() (alist->substitutions '()))
+            (_ #f)))
+        ((p . p*)
+          (syntax-case object
+            ((e . e*)
+              (merge (pattern-bindings p literals e)
+                     (pattern-bindings p* literals e*)))
+            (_ #f)))
+        (constant
+          (if (equal? constant (syntax->expression object))
+            (alist->substitutions '())
+            #f))))
+
+
+    (define (expand-template substitutions template)
+      (syntax-case template
+        ('() (with-wrap '() template))
+        ((head . tail)
+          (with-wrap
+            (cons (expand-template substitutions head)
+                  (expand-template substitutions tail))
+            template))
+        (ident (when (identifier? ident))
+          (guard (e ((key-not-found-error? e) template))
+            (lookup substitutions template)))
+        (_ template)))
+
+
+    (define (syntax-match literals all-rules object)
+      (let loop ((rules all-rules))
+        (syntax-case rules
+          ('() (raise-syntax-error "form did not match any patterns in syntax-rules" object (map car all-rules)))
+          ((((_ . pattern) template) . tail)
+            (let ((bindings (pattern-bindings pattern literals (with-wrap (cdr (syntax->expression object)) object))))
+              (if bindings
+                ; Each time the expander encounters a macro use,
+                ; it applies an antimark to the input form,
+                ; invokes the associated transformer,
+                ; then applies a fresh mark to the output.
+                ;
+                ; We also call expand-syntax-object immediately,
+                ; since macros are allowed to be recursive -- rose
+                (expand-syntax-object (add-mark (new-mark) (expand-template bindings template)))
+                (loop tail))))
+          (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules)))))
+
+
+    (define builtin-syntax-rules
+      (make-macro-transformer
+        (lambda (syntax-rules-form)
+          (syntax-case syntax-rules-form
+            ((_ literals . rules)
+              (values
+                (make-macro-transformer
+                  (lambda (input-form)
+                    (syntax-match literals rules input-form)))
+                (syntax-object-environment syntax-rules-form)))
+            (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form))))))
 
 
     (define test-environment
       (make-environment
-        (alist->map
-          hash-symbol
-          symbol<?
-          (list
-            (cons 'quote builtin-quote)
-            (cons 'lambda builtin-lambda)))
+        (alist->substitutions
+          (list (cons 'syntax-rules builtin-syntax-rules)
+                (cons 'quote builtin-quote)
+                (cons '_ (make-library-ref '(csc builtins) '_ #t))))
         '()))))