suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

open-coding a few operators

Browse Source
This commit is contained in:
Danny Yoo 2011-03-26 19:49:53 -04:00
parent 870af8736c
commit e0b6367935
3 changed files with 75 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
assemble.rkt
View File

@ -412,14 +412,48 @@ EOF
(open-code-kernel-primitive-procedure op)]))
;; FIXME: this needs to check that the domains are good!
(: open-code-kernel-primitive-procedure (CallKernelPrimitiveProcedure -> String))
(define (open-code-kernel-primitive-procedure op)
(let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
[rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))])
(cond
[(eq? operator '+)
;; FIXME: this needs to check that all the values are numbers!
(string-join rand-vals " + ")])))
(cond [(empty? rand-vals)
"0"]
[else
(string-append "(" (string-join rand-vals " + ") ")")])]
[(eq? operator 'add1)
(unless (= 1 (length rand-vals))
(error 'add1 "Expected one argument"))
(format "(~a + 1)" (first rand-vals))]
[(eq? operator 'sub1)
(unless (= 1 (length rand-vals))
(error 'sub1 "Expected one argument"))
(format "(~a - 1)" (first rand-vals))]
[(eq? operator '<)
(unless (> (length rand-vals) 0)
(error '< "Expected at least one argument"))
(assemble-chain "<" rand-vals)]
[(eq? operator '<=)
(unless (> (length rand-vals) 0)
(error '<= "Expected at least one argument"))
(assemble-chain "<=" rand-vals)])))
(: assemble-chain (String (Listof String) -> String))
(define (assemble-chain rator rands)
(string-append "("
(string-join (let: loop : (Listof String) ([rands : (Listof String) rands])
(cond
[(empty? rands)
'()]
[(empty? (rest rands))
'()]
[else
(cons (format "(~a ~a ~a)" (first rands) rator (second rands))
(loop (rest rands)))]))
"&&")
")"))

8
il-structs.rkt
View File

@ -147,7 +147,13 @@
#:transparent)
(define-type KernelPrimitiveName (U '+))
;; The following are primitives that the compiler knows about:
(define-type KernelPrimitiveName (U '+
'add1
'sub1
'<
'<=))
(define-predicate KernelPrimitiveName? KernelPrimitiveName)

36
simulator.rkt
View File

@ -333,7 +333,6 @@
(target-updater! m (evaluate-kernel-primitive-procedure-call m op))])))
(: evaluate-kernel-primitive-procedure-call (machine CallKernelPrimitiveProcedure -> PrimitiveValue))
(define (evaluate-kernel-primitive-procedure-call m op)
(let: ([op : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
@ -341,10 +340,30 @@
(map (lambda: ([a : OpArg])
(evaluate-oparg m a))
(CallKernelPrimitiveProcedure-operands op))])
(cond
[(eq? op '+)
(apply + (map ensure-number rand-vals))])))
(case op
[(+)
(apply + (map ensure-number rand-vals))]
[(add1)
(add1 (ensure-number (first rand-vals)))]
[(sub1)
(sub1 (ensure-number (first rand-vals)))]
[(<)
(chain-compare < (map ensure-real-number rand-vals))]
[(<=)
(chain-compare <= (map ensure-real-number rand-vals))]
[else
(error 'evaluate-kernel-primitive-procedure-call "missing operator: ~s\n" op)])))
(: chain-compare (All (A) (A A -> Boolean) (Listof A) -> Boolean))
(define (chain-compare f vals)
(cond
[(empty? vals)
#t]
[(empty? (rest vals))
#t]
[else
(and (f (first vals) (second vals))
(chain-compare f (rest vals)))]))
@ -447,6 +466,15 @@
(error 'ensure-number "Not a number: ~s" x)))
(: ensure-real-number (Any -> Real))
(define (ensure-real-number x)
(if (real? x)
x
(error 'ensure-number "Not a number: ~s" x)))
(: ensure-CapturedControl (Any -> CapturedControl))
(define (ensure-CapturedControl x)
(if (CapturedControl? x)