Improvements in macros and IR1.

We're omitting libraries for now, and I'll add them in later.

1 files changed, 75 insertions, 2 deletions

diff --git a/csc/ir1.csc b/csc/ir1.csc
index 334f870..3826c34 100644
--- a/csc/ir1.csc
+++ b/csc/ir1.csc
@@ -10,6 +10,7 @@
     if-test
     if?
     import?
+    ir1=?
     lambda-body
     lambda-case-alternate
     lambda-case-arguments
@@ -41,6 +42,7 @@
     make-lexical-set
     make-sequence
     make-toplevel-define
+    make-toplevel-ref
     make-void
     sequence-head
     sequence-tail
@@ -48,8 +50,11 @@
     toplevel-define-expression
     toplevel-define-name
     toplevel-define?
+    toplevel-ref-name
+    toplevel-ref?
     void?)
-  (import (scheme base))
+  (import (scheme base)
+          (only (csc loop) loop return))
   (begin
     ; This library defines the intermediate representation IR1. An expression
     ; in IR1 has one of the following forms (plagiarized from Guile's
@@ -82,6 +87,14 @@
       (gensym lexical-ref-gensym))
 
 
+    ; <toplevel-ref> name
+    ; A free reference to a top level variable.
+    (define-record-type <toplevel-ref>
+      (make-toplevel-ref name)
+      toplevel-ref?
+      (name toplevel-ref-name))
+
+
     ; <lexical-set> name gensym expression
     ; Sets a lexically-bound variable.
     (define-record-type <lexical-set>
@@ -175,4 +188,64 @@
       (names letrec-names)
       (gensyms letrec-gensyms)
       (values letrec-values)
-      (expression letrec-expression))))
+      (expression letrec-expression))
+
+
+    (define (ir1=? x y)
+      (cond
+        ((and (void? x) (void? y)) #t)
+        ((and (constant? x) (constant? y))
+          (equal? (constant-expression x) (constant-expression y)))
+        ((and (lexical-ref? x) (lexical-ref? y))
+          (symbol=? (lexical-ref-name x) (lexical-ref-name y)))
+        ((and (toplevel-ref? x) (toplevel-ref? y))
+          (symbol=? (toplevel-ref-name x) (toplevel-ref-name y)))
+        ((and (lexical-set? x) (lexical-set? y))
+          (and
+            (symbol=? (lexical-set-name x) (lexical-set-name y))
+            (ir1=? (lexical-set-expression x) (lexical-set-expression y))))
+        ((and (toplevel-define? x) (toplevel-define? y))
+          (and
+            (symbol=? (toplevel-define-name x) (toplevel-define-name y))
+            (ir1=? (toplevel-define-expression x) (toplevel-define-expression y))))
+        ((and (if? x) (if? y))
+          (and
+            (ir1=? (if-test x) (if-test y))
+            (ir1=? (if-consequent x) (if-consequent y))
+            (ir1=? (if-alternate x) (if-alternate y))))
+        ((and (call? x) (call? y))
+          (and
+            (ir1=? (call-procedure x) (call-procedure y))
+            (= (length (call-arguments x)) (length (call-arguments y)))
+            (loop for x-arg in (call-arguments x)
+                  for y-arg in (call-arguments y)
+                  unless (ir1=? x-arg y-arg)
+                    return #f
+                  finally (return #t))))
+        ((and (sequence? x) (sequence? y))
+          (and
+            (ir1=? (sequence-head x) (sequence-head y))
+            (ir1=? (sequence-tail x) (sequence-tail y))))
+        ((and (lambda? x) (lambda? y))
+          (ir1=? (lambda-body x) (lambda-body y)))
+        ((and (lambda-case? x) (lambda-case? y))
+          (and
+            (equal? (lambda-case-arguments x) (lambda-case-arguments y))
+            (eq? (lambda-case-rest x) (lambda-case-rest y))
+            (ir1=? (lambda-case-body x) (lambda-case-body y))
+            (or (and (not (lambda-case-alternate x))
+                     (not (lambda-case-alternate y)))
+                (ir1=? (lambda-case-alternate x) (lambda-case-alternate y)))))
+        ((and (letrec? x) (letrec? y))
+          (and
+            (boolean=? (letrec-in-order? x) (letrec-in-order? y))
+            (map symbol=? (letrec-names x) (letrec-names y))
+            (= (length (letrec-values x)) (length (letrec-values y)))
+            (loop for x-val in (letrec-values x)
+                  for y-val in (letrec-values y)
+                  unless (ir1=? x-val y-val) return #f
+                  finally (return #t))
+            (ir1=? (letrec-expression x) (letrec-expression y))))
+        ((and (ir1=? x x) (ir1=? y y))
+          #f)
+        (else (error "One or more arguments has a type unknown to ir1=?" x y))))))