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

fixing test cases

Browse Source
This commit is contained in:
Danny Yoo 2011-03-25 23:19:21 -04:00
parent d758585c85
commit 6cb062d83e
6 changed files with 15 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
compile.rkt
View File

@ -14,9 +14,10 @@
;; We try to keep at compile time a mapping from environment positions to
;; statically known things, to generate better code.
(define-struct: StaticallyKnownLam ([entry-point : Symbol]
(define-struct: StaticallyKnownLam ([name : (U Symbol False)]
[entry-point : Symbol]
[arity : Natural]) #:transparent)
(define-type CompileTimeEnvironmentEntry (U '? 'prefix StaticallyKnownLam))
(define-type CompileTimeEnvironmentEntry (U '? Prefix StaticallyKnownLam))
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
@ -52,7 +53,7 @@
(cond
[(Top? exp)
(loop (Top-code exp) (cons 'prefix cenv))]
(loop (Top-code exp) (cons (Top-prefix exp) cenv))]
[(Constant? exp)
'()]
[(LocalRef? exp)
@ -164,7 +165,7 @@
(append-instruction-sequences
(make-instruction-sequence
`(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
(compile (Top-code top) (cons 'prefix cenv) target linkage))))
(compile (Top-code top) (cons (Top-prefix top) cenv) target linkage))))
@ -396,19 +397,16 @@
[(and (LocalRef? operator) (not (LocalRef-unbox? operator)))
(let: ([static-knowledge : CompileTimeEnvironmentEntry (list-ref extended-cenv (LocalRef-depth operator))])
(cond
[(eq? static-knowledge 'prefix)
(default)]
[(eq? static-knowledge '?)
(default)]
[(Prefix? static-knowledge)
(default)]
[(StaticallyKnownLam? static-knowledge)
;; Currently disabling the static analysis stuff till I get error trapping working first.
#;(default)
(unless (= n (StaticallyKnownLam-arity static-knowledge))
(error 'arity-mismatch "Expected ~s, received ~s"
(error 'arity-mismatch "~s expected ~s arguments, but received ~s"
(StaticallyKnownLam-name static-knowledge)
(StaticallyKnownLam-arity static-knowledge)
n))
;; FIXME: do the arity check here...
#;(printf "I'm here with ~s\n" static-knowledge)
(compile-procedure-call/statically-known-lam static-knowledge
extended-cenv
n
@ -559,7 +557,8 @@
(define (extract-static-knowledge exp cenv)
(cond
[(Lam? exp)
(make-StaticallyKnownLam (Lam-entry-label exp)
(make-StaticallyKnownLam (Lam-name exp)
(Lam-entry-label exp)
(Lam-num-parameters exp))]
[(LocalRef? exp)
(list-ref cenv (LocalRef-depth exp))]

2
simulator-primitives.rkt
View File

@ -28,7 +28,7 @@
(syntax->list #'(name ...)))])
(syntax/loc stx
(let ([prim-name (make-primitive-proc
(lambda (machine return-label . args)
(lambda (machine . args)
(apply name args)))]
...)
(lambda (n)

2
simulator-structs.rkt
View File

@ -67,7 +67,7 @@
;; Primitive procedure wrapper
(define-struct: primitive-proc ([f : (machine Symbol PrimitiveValue * -> PrimitiveValue)])
(define-struct: primitive-proc ([f : (machine PrimitiveValue * -> PrimitiveValue)])
#:transparent)

1
simulator.rkt
View File

@ -309,7 +309,6 @@
(current-simulated-output-port)])
(apply (primitive-proc-f prim)
m
(ApplyPrimitiveProcedure-label op)
args))))]
[else
(error 'apply-primitive-procedure)]))]

2
test-assemble.rkt
View File

@ -154,7 +154,7 @@
(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f)
(make-Const 4))
(make-AssignPrimOpStatement 'val
(make-ApplyPrimitiveProcedure 2 'done))
(make-ApplyPrimitiveProcedure 2))
'done))
"7")

2
test-simulator.rkt
View File

@ -472,7 +472,7 @@
,(make-PushEnvironment 2 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 126389))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 42))
,(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure 2 'after))
,(make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure 2))
after))])
(test (machine-val (run m))
(+ 126389 42))