Add pattern matching for record types.

I like scheme because it's possible to add any convenient language
feature I can think of.

5 files changed, 233 insertions, 152 deletions

diff --git a/csc/cps.csc b/csc/cps.csc
index cf4a26d..b6decbb 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -1,37 +1,28 @@
 (define-library (csc cps)
   (export
     ir1->ir2)
-  (import (only (csc gensym) gensym)
+  (import (scheme base)
+          (only (csc gensym) gensym)
           (only (csc hash-map)
             insert
             make-map
             merge)
           (only (csc ir1)
-            call-arguments
-            call-procedure
+            %call
+            %define-syntax
+            %if
+            %lambda
+            %letrec
+            %lexical-set
+            %library-define
+            %sequence
             call?
             constant?
-            define-syntax?
-            if-alternate
-            if-consequent
-            if-test
             if?
-            lambda-arguments
-            lambda-body
-            lambda-rest
             lambda?
-            letrec-expression
-            letrec-gensyms
-            letrec-in-order?
-            letrec-names
-            letrec-values
             letrec?
             lexical-ref?
-            lexical-set-expression
-            lexical-set-ref
             lexical-set?
-            library-define-expression
-            library-define-ref
             library-define?
             library-ref?
             make-call
@@ -40,8 +31,6 @@
             make-lexical-ref
             make-lexical-set
             make-sequence
-            sequence-head
-            sequence-tail
             sequence?)
           (only (csc ir2)
             make-apply
@@ -57,7 +46,7 @@
           (only (csc loop)
             loop
             return)
-          (scheme base))
+          (only (csc match) match))
   (begin
 
 
@@ -66,48 +55,52 @@
 
 
     (define (collect-functions-and-variables expr)
-      (loop for name in (letrec-names expr)
-            for gensym in (letrec-gensyms expr)
-            for value in (letrec-values expr)
-            if (lambda? value)
-              collect (let ((continuation (new-ref)))
-                        (make-closure
-                          (make-lexical-ref name gensym)
-                          (cons continuation (lambda-arguments value))
-                          (lambda-rest value)
-                          (ir1->ir2
-                            (lambda-body value)
-                            (lambda (z)
-                              (make-apply continuation (list z))))))
-                      into functions
-            else
-              collect (make-lexical-ref name gensym) into variable-names
-              and collect value into variable-values
-            finally (return (values functions variable-names variable-values))))
+      (match expr
+        ((% %letrec _ names gensyms vals _)
+          (loop for name in names
+                for gensym in gensyms
+                for value in vals
+                if (lambda? value)
+                  collect (match value
+                            ((% %lambda args rest body)
+                              (define continuation (new-ref))
+                              (make-closure
+                                (make-lexical-ref name gensym)
+                                (cons continuation args)
+                                rest
+                                (ir1->ir2
+                                  body
+                                  (lambda (z)
+                                    (make-apply continuation (list z)))))))
+                          into functions
+                else
+                  collect (make-lexical-ref name gensym) into variable-names
+                  and collect value into variable-values
+                finally (return (values functions variable-names variable-values))))))
 
 
     (define (ir1->ir2 expr continuation)
-      (cond
-        ((or (constant? expr)
-             (lexical-ref? expr)
-             (library-ref? expr))
+      (match expr
+        (_ (when (or (constant? expr)
+                     (lexical-ref? expr)
+                     (library-ref? expr)))
           (continuation expr))
-        ((lexical-set? expr)
+        ((% %lexical-set ref arg)
           (ir1->ir2
-            (lexical-set-expression expr)
+            arg
             (lambda (val)
-              (make-update (lexical-set-ref expr) val (continuation (make-constant #f))))))
-        ((library-define? expr)
+              (make-update ref val (continuation (make-constant #f))))))
+        ((% %library-define ref arg)
           (ir1->ir2
-            (library-define-expression expr)
+            arg
             (lambda (val)
-              (make-update (library-define-ref expr) val (continuation (make-constant #f))))))
-        ((define-syntax? expr)
+              (make-update ref val (continuation (make-constant #f))))))
+        ((% %define-syntax _ _)
           ; no-op
           (continuation (make-constant #f)))
-        ((if? expr)
+        ((% %if test consequent alternate)
           (ir1->ir2
-            (if-test expr)
+            test
             (lambda (val)
               (define continuation-ref (new-ref))
               (define result-ref (new-ref))
@@ -116,81 +109,81 @@
                         (continuation result-ref)))
                 (make-branch val
                   (ir1->ir2
-                    (if-consequent expr)
+                    consequent
                     (lambda (result)
                       (make-apply continuation-ref (list result))))
                   (ir1->ir2
-                    (if-alternate expr)
+                    alternate
                     (lambda (result)
                       (make-apply continuation-ref (list result)))))))))
-        ((call? expr)
-          (let ((return-address (new-ref))
-                (result (new-ref)))
-            (make-fix
-              (list (make-closure return-address (list result) #f (continuation result)))
-              (ir1->ir2
-                (call-procedure expr)
-                (lambda (f)
-                  ; Technically the order of evaluation is unspecified.
-                  ; We evaluate expressions left to right.
-                  ;
-                  ; I would use the loop macro, but it mutates the loop
-                  ; variables which plays badly with building a lambda.
-                  (let loop ((args (reverse (call-arguments expr)))
-                             (exprs (lambda (vals)
-                                      (make-apply f (cons return-address (reverse vals))))))
-                    (if (null? args)
-                      (exprs '())
-                      (loop (cdr args)
-                            (lambda (vals)
-                              (ir1->ir2
-                                (car args)
-                                (lambda (val)
-                                  (exprs (cons val vals)))))))))))))
-        ((sequence? expr)
+        ((% %call proc args)
+          (define return-address (new-ref))
+          (define result (new-ref))
+          (make-fix
+            (list (make-closure return-address (list result) #f (continuation result)))
+            (ir1->ir2
+              proc
+              (lambda (f)
+                ; Technically the order of evaluation is unspecified.
+                ; We evaluate expressions left to right.
+                ;
+                ; I would use the loop macro, but it mutates the loop
+                ; variables which plays badly with building a lambda.
+                (let loop ((args* (reverse args))
+                           (exprs (lambda (vals)
+                                    (make-apply f (cons return-address (reverse vals))))))
+                  (if (null? args*)
+                    (exprs '())
+                    (loop (cdr args*)
+                          (lambda (vals)
+                            (ir1->ir2
+                              (car args*)
+                              (lambda (val)
+                                (exprs (cons val vals))))))))))))
+        ((% %sequence head tail)
           (ir1->ir2
-            (sequence-head expr)
+            head
             (lambda (x)
               (ir1->ir2
-                (sequence-tail expr)
-                continuation))))
-        ((lambda? expr)
-          (let ((f (new-ref))
-                (k (new-ref)))
-            (make-fix
-              (list
-                (make-closure f (cons k (lambda-arguments expr)) (lambda-rest expr)
-                  (ir1->ir2
-                    (lambda-body expr)
-                    (lambda (ret)
-                      (make-apply k (list ret))))))
-              (continuation f))))
-        ((letrec? expr)
-          (let-values (((functions variable-names variable-values) (collect-functions-and-variables expr)))
-            (make-fix functions
-              (ir1->ir2
-                ; We re-write a letrec into a corresponding lambda form.
-                (if (letrec-in-order? expr)
-                  (loop for name in (reverse variable-names)
-                        for value in (reverse variable-values)
-                        for expr = (make-call
-                                     (make-lambda
-                                       (list name)
-                                       #f
-                                       (letrec-expression expr))
-                                     (list value))
-                                 then (make-call
-                                        (make-lambda
-                                          (list name)
-                                          #f
-                                          expr)
-                                        (list value))
-                        finally (return expr))
-                  (make-call
-                    (make-lambda
-                      variable-names
-                      #f
-                      (letrec-expression expr))
-                    variable-values))
+                tail
                 continuation))))
-        (else (error "unexpected type in ir1->ir2" expr))))))
+        ((% %lambda args rest body)
+          (define f (new-ref))
+          (define k (new-ref))
+          (make-fix
+            (list
+              (make-closure f (cons k args) rest
+                (ir1->ir2
+                  body
+                  (lambda (ret)
+                    (make-apply k (list ret))))))
+            (continuation f)))
+        ((% %letrec in-order? _ _ _ body)
+          (define-values (functions variable-names variable-values) (collect-functions-and-variables expr))
+          (make-fix functions
+            (ir1->ir2
+              ; We re-write a letrec into a corresponding lambda form.
+              (if in-order?
+                (loop for name in (reverse variable-names)
+                      for value in (reverse variable-values)
+                      for expr = (make-call
+                                   (make-lambda
+                                     (list name)
+                                     #f
+                                     body)
+                                   (list value))
+                               then (make-call
+                                      (make-lambda
+                                        (list name)
+                                        #f
+                                        expr)
+                                      (list value))
+                      finally (return expr))
+                (make-call
+                  (make-lambda
+                    variable-names
+                    #f
+                    body)
+                  variable-values))
+              continuation)))
+        (_ (error "unexpected type in ir1->ir2" expr))))))
diff --git a/csc/ir1.csc b/csc/ir1.csc
index d82cf12..73ec703 100644
--- a/csc/ir1.csc
+++ b/csc/ir1.csc
@@ -1,5 +1,16 @@
 (define-library (csc ir1)
   (export
+    %call
+    %constant
+    %define-syntax
+    %if
+    %lambda
+    %letrec
+    %lexical-ref
+    %lexical-set
+    %library-define
+    %library-ref
+    %sequence
     call-arguments
     call-procedure
     call?
@@ -12,7 +23,6 @@
     if-consequent
     if-test
     if?
-    import?
     ir1=?
     lambda-arguments
     lambda-body
@@ -53,7 +63,9 @@
   (import (scheme base)
           (only (csc list)
             all)
-          (only (csc loop) loop return))
+          (only (csc loop) loop return)
+          (only (csc match)
+            define-match-record-type))
   (begin
     ; This library defines the intermediate representation IR1. An expression
     ; in IR1 has one of the following forms (plagiarized from Guile's
@@ -62,9 +74,10 @@
 
     ; <constant> expression
     ; Constant is used to include literal constants in scheme code.
-    (define-record-type <constant>
+    (define-match-record-type <constant>
       (make-constant expression)
       constant?
+      %constant
       (expression constant-expression))
 
 
@@ -72,9 +85,10 @@
     ; A reference to a lexically-bound variable. The name is the original name
     ; of the variable in the source program. gensym is a unique identifier for
     ; this variable.
-    (define-record-type <lexical-ref>
+    (define-match-record-type <lexical-ref>
       (make-lexical-ref name gensym)
       lexical-ref?
+      %lexical-ref
       (name lexical-ref-name)
       (gensym lexical-ref-gensym))
 
@@ -82,27 +96,30 @@
     ; <library-ref> name
     ; A free reference to a variable in a library. If the library is 'main,
     ; then it is a top-level global variable.
-    (define-record-type <library-ref>
+    (define-match-record-type <library-ref>
       (make-library-ref name library)
       library-ref?
+      %library-ref
       (name library-ref-name)
       (library library-ref-library))
 
 
     ; <lexical-set> name gensym expression
     ; Sets a lexically-bound variable.
-    (define-record-type <lexical-set>
+    (define-match-record-type <lexical-set>
       (make-lexical-set ref expression)
       lexical-set?
+      %lexical-set
       (ref lexical-set-ref)
       (expression lexical-set-expression))
 
 
     ; <library-define> name expression
     ; Defines a new variable in the current library.
-    (define-record-type <library-define>
+    (define-match-record-type <library-define>
       (make-library-define ref expression)
       library-define?
+      %library-define
       (ref library-define-ref)
       (expression library-define-expression))
 
@@ -110,18 +127,20 @@
     ; <define-syntax> name transformer
     ; Defines a new macro in the current environment. name is the name of the
     ; macro. transformer is a macro transformer.
-    (define-record-type <define-syntax>
+    (define-match-record-type <define-syntax>
       (make-define-syntax name transformer)
       define-syntax?
+      %define-syntax
       (name define-syntax-name)
       (transformer define-syntax-transformer))
 
 
     ; <if> test consequent alternate
     ; A conditional.
-    (define-record-type <if>
+    (define-match-record-type <if>
       (make-if test consequent alternate)
       if?
+      %if
       (test if-test)
       (consequent if-consequent)
       (alternate if-alternate))
@@ -131,18 +150,20 @@
     ; A procedure call. The procedure and arguments are evaluated in an
     ; unspecified order, and the resulting procedure is passed the
     ; resulting arguments.
-    (define-record-type <call>
+    (define-match-record-type <call>
       (make-call procedure arguments)
       call?
+      %call
       (procedure call-procedure)
       (arguments call-arguments))
 
 
     ; <sequence> head tail
     ; Evaluate head, ignoring any result. Then tail is evaluated.
-    (define-record-type <sequence>
+    (define-match-record-type <sequence>
       (make-sequence head tail)
       sequence?
+      %sequence
       (head sequence-head)
       (tail sequence-tail))
 
@@ -150,9 +171,10 @@
     ; <lambda> body
     ; A closure. Arguments is a list of lexical-refs.
     ; Rest is a lexical ref or #f if the lambda doesn't take a rest parameter.
-    (define-record-type <lambda>
+    (define-match-record-type <lambda>
       (make-lambda arguments rest body)
       lambda?
+      %lambda
       (arguments lambda-arguments)
       (rest lambda-rest)
       (body lambda-body))
@@ -163,9 +185,10 @@
     ; names are the original binding names, gensyms are gensyms corresponding
     ; to the names, and values are IR1 expressions for the values. expression
     ; is a single IR1 expression.
-    (define-record-type <letrec>
+    (define-match-record-type <letrec>
       (make-letrec in-order? names gensyms values expression)
       letrec?
+      %letrec
       (in-order? letrec-in-order?)
       (names letrec-names)
       (gensyms letrec-gensyms)
diff --git a/csc/ir2.csc b/csc/ir2.csc
index 9b9397f..40109fe 100644
--- a/csc/ir2.csc
+++ b/csc/ir2.csc
@@ -78,7 +78,9 @@
           (only (csc list) all)
           (only (csc loop)
             loop
-            return))
+            return)
+          (only (csc match)
+            define-match-record-type))
   (begin
     ; This library defines the intermediate representation IR2.
     ; It's CPS time bitch.
@@ -90,6 +92,27 @@
     ;     - constant,
     ;     - lexical-ref,
     ;     - or library-ref
+    ;   After closure conversion, lexical refs are no longer allowed.
+    ;   Lexical refs are converted to one of the below data types.
+
+
+    ; A variable representing the address of a function in the same compilation
+    ; unit. This will be a constant after linking.
+    (define-match-record-type <label>
+      (make-label gensym)
+      label?
+      %label
+      (gensym label-gensym))
+
+
+    ; A local variable. This can be an argument to a function or the result of
+    ; a primitive.
+    (define-match-record-type <var>
+      (make-var gensym)
+      var?
+      %var
+      (gensym var-gensym))
+
 
     ; CPS expressions:
     ;   CPS expressions are similar to IR1 expressions,
@@ -98,9 +121,10 @@
 
 
     ; Modifies a library or lexically bound variable to the given atom.
-    (define-record-type <update>
+    (define-match-record-type <update>
       (make-update ref atom continuation)
       update?
+      %update
       (ref update-ref)
       (atom update-atom)
       (continuation update-continuation))
@@ -109,9 +133,10 @@
     ; Branches depending on the given atom.
     ; If it is true, continue with continuation true.
     ; If false, continue with continuation false.
-    (define-record-type <branch>
+    (define-match-record-type <branch>
       (make-branch atom true false)
       branch?
+      %branch
       (atom branch-atom)
       (true branch-true)
       (false branch-false))
@@ -120,9 +145,10 @@
     ; Applies a procedure to a list of arguments. Apply does not take a
     ; continuation. Instead the continuation will be passed as the first
     ; argument to the function.
-    (define-record-type <apply>
+    (define-match-record-type <apply>
       (make-apply procedure arguments)
       apply?
+      %apply
       (procedure apply-procedure)
       (arguments apply-arguments))
 
@@ -130,9 +156,10 @@
     ; A procedure. All closures are allocated in a fix expression. A closure
     ; does not take a continuation. Instead, the procedure will accept the
     ; continuation as an argument.
-    (define-record-type <closure>
+    (define-match-record-type <closure>
       (make-closure name arguments rest body)
       closure?
+      %closure
       (name closure-name)
       (arguments closure-arguments)
       (rest closure-rest)
@@ -141,9 +168,10 @@
 
     ; Defines a list of mutually recursive procedures.
     ; Functions is a list of closures, and body is an expression.
-    (define-record-type <fix>
+    (define-match-record-type <fix>
       (make-fix functions body)
       fix?
+      %fix
       (functions fix-functions)
       (body fix-body))
 
diff --git a/csc/match-test.csc b/csc/match-test.csc
index 31e7afa..c5314ce 100644
--- a/csc/match-test.csc
+++ b/csc/match-test.csc
@@ -85,3 +85,19 @@
       (n (when (= 1 n)) 1)
       (n (when (= 10 n)) 2)
       (_ 3))))
+
+
+(define-match-record-type <test-record-type>
+  (make-test-record-type a b c)
+  test-record-type?
+  %test-record-type
+  (a test-record-type-a)
+  (b test-record-type-b)
+  (c test-record-type-c))
+
+
+(test match-record-type
+  (assert-equal
+    2
+    (match (make-test-record-type 1 2 3)
+      ((% %test-record-type a b c) b))))
diff --git a/csc/match.csc b/csc/match.csc
index 5b85f09..ad9b56a 100644
--- a/csc/match.csc
+++ b/csc/match.csc
@@ -1,5 +1,7 @@
 (define-library (csc match)
-  (export match)
+  (export
+    define-match-record-type
+    match)
   (import (scheme base))
   (begin
 
@@ -9,34 +11,53 @@
       no-match?)
 
 
+    (define *no-match* (make-no-match))
+
+
+    (define-syntax define-match-record-type
+      (syntax-rules ()
+        ((define-match-record-type name constructor predicate matcher (field-name* field-getter*) ...)
+          (begin
+            (define-record-type name
+              constructor
+              predicate
+              (field-name* field-getter*) ...)
+            (define (matcher x)
+              (unless (predicate x)
+                (raise *no-match*))
+              (list (field-getter* x) ...))))))
+
+
     (define-syntax match-pattern
-      (syntax-rules (_ ! when)
+      (syntax-rules (_ ! when %)
         ((match-pattern x pattern (when condition) result result* ...)
          (match-pattern x pattern
            (if condition
-             (begin result result* ...)
-             (raise (make-no-match)))))
+             (let () result result* ...)
+             (raise *no-match*))))
         ((match-pattern x _ result result* ...)
-         (begin result result* ...))
+         (let () result result* ...))
         ((match-pattern x '() result result* ...)
          (if (null? x)
-           (begin result result* ...)
-           (raise (make-no-match))))
+           (let () result result* ...)
+           (raise *no-match*)))
         ((match-pattern x (! constant) result result* ...)
          (if (equal? x constant)
-           (begin result result* ...)
-           (raise (make-no-match))))
+           (let () result result* ...)
+           (raise *no-match*)))
         ((match-pattern x (pattern) result result* ...)
          (let ((y x))
            (if (= 1 (length y))
              (match-pattern (car y) pattern result result* ...)
-             (raise (make-no-match)))))
+             (raise *no-match*))))
+        ((match-pattern x (% record-matcher . patterns) result result* ...)
+          (match-pattern (record-matcher x) patterns result result* ...))
         ((match-pattern x (pattern . rest) result result* ...)
          (let ((y x))
            (if (pair? y)
              (match-pattern (car y) pattern
                (match-pattern (cdr y) rest result result* ...))
-             (raise (make-no-match)))))
+             (raise *no-match*))))
         ((match-pattern x identifier result result* ...)
          (let ((identifier x))
            result result* ...))))