diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 83 |
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)))) ;;; |