summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm31
1 files changed, 31 insertions, 0 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 50ac1e8..f7dd555 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -215,6 +215,10 @@
(define params* (lookup-all params env*))
`(lambda ,params* ,(expand body env*)))
+;; Arithmetic operators, in true Lisp fashion, can accept many
+;; arguments. + and * accept 0 or more. - and / accept one or more.
+;; The expansion pass transforms all such expressions into binary
+;; operator form.
(define (expand:+ args env)
(match args
(() 0)
@@ -222,6 +226,14 @@
((n . rest)
`(primcall + ,(expand n env) ,(expand:+ rest env)))))
+(define (expand:- args env)
+ (match args
+ ((n) `(primcall - ,(expand n env) 0))
+ ((m n)
+ `(primcall - ,(expand m env) ,(expand n env)))
+ ((n . rest)
+ `(primcall - ,(expand n env) ,(expand:- rest env)))))
+
(define (expand:* args env)
(match args
(() 1)
@@ -229,6 +241,21 @@
((n . rest)
`(primcall * ,(expand n env) ,(expand:* rest env)))))
+(define (expand:/ args env)
+ (match args
+ ((n)
+ `(primcall / 1 ,(expand n env)))
+ ((m n)
+ `(primcall / ,(expand m env) ,(expand n env)))
+ ((m n . rest)
+ (let loop ((rest rest)
+ (exp `(primcall / ,(expand m env) ,(expand n env))))
+ (match rest
+ ((l)
+ `(primcall / ,exp ,(expand l env)))
+ ((l . rest)
+ (loop rest `(primcall / ,exp ,(expand l env)))))))))
+
(define (expand:primitive-call operator operands env)
`(primcall ,operator ,@(expand:list operands env)))
@@ -264,8 +291,12 @@
(expand:let* bindings body env))
(('+ args ...)
(expand:+ args env))
+ (('- args ...)
+ (expand:- args env))
(('* args ...)
(expand:* args env))
+ (('/ args ...)
+ (expand:/ args env))
;; Primitive calls:
(((? primitive-call? operator) args ...)
(expand:primitive-call operator args env))