Add a first implementation of a macro expander.

This half-finished macro expander is the most satisfying piece of code I
have ever written.

1 files changed, 184 insertions, 0 deletions

diff --git a/macros.csc b/macros.csc
new file mode 100644
index 0000000..a41a4a7
--- /dev/null
+++ b/macros.csc
@@ -0,0 +1,184 @@
+(define-library (csc macros)
+  (export
+    expand
+    test-environment)
+  (import (scheme base)
+          (only (csc gensym) gensym)
+          (only (csc hash-map)
+            alist->map
+            hash-bytevector
+            insert
+            key-not-found-error?
+            lookup)
+          (only (csc ir1)
+            make-call
+            make-constant
+            make-lambda
+            make-lambda-case)
+          (only (csc list) revappend)
+          (only (csc match) match))
+  (begin
+
+
+    (define-record-type <macro-transformer>
+      (make-macro-transformer transformer)
+      macro-transformer?
+      (transformer transformer-function))
+
+
+    (define-record-type <macro-syntax-error>
+      (make-macro-syntax-error message irritants)
+      macro-syntax-error?
+      (message syntax-error-object-message)
+      (irritants syntax-error-object-irritants))
+
+
+    (define (raise-syntax-error message . irritants)
+      (raise (make-macro-syntax-error message irritants)))
+
+
+    ; symbols is a map with symbols as keys, and the values can be one of:
+    ; - <lexical-ref>,
+    ; - <module-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
+    ; current context.
+    ;
+    ; library is the current library name being compiled. A nil library
+    ; corresponds to top level expressions.
+    (define-record-type <environment>
+      (make-environment symbols library)
+      environment?
+      (symbols environment-symbols)
+      (library environment-library))
+
+
+    (define (with-binding environment symbol binding)
+      (make-environment (insert (environment-symbols environment) symbol binding) (environment-library environment)))
+
+
+    (define (expand-procedure-call procedure arguments environment)
+      (let*-values (((expanded-procedure environment) (expand procedure environment))
+                    ((expanded-arguments environment)
+                     (let loop ((arguments arguments)
+                                (environment environment)
+                                (expanded-arguments '()))
+                       (match arguments
+                         ('() (values (reverse expanded-arguments) environment))
+                         ((argument . rest)
+                          (let-values (((expanded-argument environment) (expand argument environment)))
+                            (loop
+                              rest
+                              environment
+                              (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)))
+
+
+    ; 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))))
+
+
+    (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))))))
+
+
+    (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 builtin-syntax-rules
+      (make-macro-transformer
+        (lambda (expression environment)
+          (match expression))))
+
+
+    (define (hash-symbol s)
+      (hash-bytevector (string->utf8 (symbol->string s))))
+
+
+    (define (symbol<? s1 s2)
+      (string<? (symbol->string s1) (symbol->string s2)))
+
+
+    (define test-environment
+      (make-environment
+        (alist->map
+          hash-symbol
+          symbol<?
+          (list
+            (cons 'quote builtin-quote)
+            (cons 'lambda builtin-lambda)))
+        '()))))