Add case/cond.

1 files changed, 67 insertions, 16 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index b3aef24..d1a90da 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -203,6 +203,25 @@
 ;; '+' being a user defined variable that shadows the primitive
 ;; addition operation.
 
+(define &seagull-syntax-error
+  (make-exception-type '&seagull-syntax-error &error '(form)))
+
+(define make-seagull-syntax-error
+  (record-constructor &seagull-syntax-error))
+
+(define seagull-syntax-form
+  (exception-accessor &seagull-syntax-error
+                      (record-accessor &seagull-syntax-error 'form)))
+
+(define (seagull-syntax-error exp msg origin)
+  (raise-exception
+   (make-exception
+    (make-seagull-syntax-error exp)
+    (make-exception-with-origin origin)
+    (make-exception-with-message
+     (format #f "seagull syntax error: ~a" msg))
+    (make-exception-with-irritants (list exp)))))
+
 (define unique-identifier-counter (make-parameter 0))
 
 (define (unique-identifier-number)
@@ -315,6 +334,49 @@
      (expand `(let ((x ,exp)) (if x (and ,@rest) #f))
              stage env))))
 
+(define (expand:cond clauses stage env)
+  (define (cond->if clauses*)
+    (match clauses*
+      ;; Our version of 'cond' requires a final else clause because the
+      ;; static type checker enforces that both branches of an 'if' must
+      ;; be the same type.  If 'else' were optional then we wouldn't
+      ;; know what type the final alternate branch should be.
+      ((('else exp))
+       exp)
+      (((predicate consequent) . rest)
+       `(if ,predicate
+            ,consequent
+            ,(cond->if rest)))
+      (()
+       (seagull-syntax-error "'cond' form must end with 'else' clause"
+                             `(cond ,@clauses)
+                             expand:cond))
+      (_
+       (seagull-syntax-error "invalid 'cond' form"
+                             `(cond ,@clauses)
+                             expand:cond))))
+  (expand (cond->if clauses) stage env))
+
+(define (expand:case key clauses stage env)
+  (define (case->if clauses*)
+    (match clauses*
+      ;; Like 'cond', 'case' also requires a final 'else' clause.
+      ((('else exp))
+       exp)
+      ((((possibilities ..1) consequent) . rest)
+       `(if (or ,@(map (lambda (n) `(= key ,n)) possibilities))
+            ,consequent
+            ,(case->if rest)))
+      (()
+       (seagull-syntax-error "'case' form must end with 'else' clause"
+                             `(case ,key ,@clauses)
+                             expand:case))
+      (_
+       (seagull-syntax-error "invalid 'cond' form"
+                             `(case ,key ,@clauses)
+                             expand:case))))
+  (expand `(let ((key ,key)) ,(case->if clauses)) stage env))
+
 (define (expand:primitive-call operator operands stage env)
   `(primcall ,operator ,@(expand:list operands stage env)))
 
@@ -338,16 +400,6 @@
                    (expand exp stage env)))
            names exps)))
 
-(define &seagull-syntax-error
-  (make-exception-type '&seagull-syntax-error &error '(form)))
-
-(define make-seagull-syntax-error
-  (record-constructor &seagull-syntax-error))
-
-(define seagull-syntax-form
-  (exception-accessor &seagull-syntax-error
-                      (record-accessor &seagull-syntax-error 'form)))
-
 (define (expand exp stage env)
   (define (primitive-call-for-stage? x)
     (primitive-call? x stage))
@@ -386,6 +438,10 @@
      (expand:or exps stage env))
     (('and exps ...)
      (expand:and exps stage env))
+    (('cond clauses ...)
+     (expand:cond clauses stage env))
+    (('case key clauses ...)
+     (expand:case key clauses stage env))
     ;; Primitive calls:
     (((? primitive-call-for-stage? operator) args ...)
      (expand:primitive-call operator args stage env))
@@ -394,12 +450,7 @@
      (expand:call operator args stage env))
     ;; Syntax error:
     (_
-     (raise-exception
-      (make-exception
-       (make-seagull-syntax-error exp)
-       (make-exception-with-origin expand)
-       (make-exception-with-message "seagull: invalid syntax")
-       (make-exception-with-irritants (list exp)))))))
+     (seagull-syntax-error "unknown form" exp expand))))
 
 
 ;;;