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

added type checks

Browse Source
This commit is contained in:
Danny Yoo 2011-03-29 18:36:47 -04:00
parent 073688b1a9
commit 7c473c8658
3 changed files with 22 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
assemble-open-coded.rkt
View File

@ -209,7 +209,7 @@
(: maybe-typecheck-operand (OperandDomain Natural String CompileTimeEnvironmentEntry -> String)) (: maybe-typecheck-operand (OperandDomain Natural String CompileTimeEnvironmentEntry -> String))
(define (maybe-typecheck-operand domain-type position operand-string knowledge) (define (maybe-typecheck-operand domain-type position operand-string knowledge)
(cond (cond
[#t #;(redundant-check? domain-type knowledge) [(redundant-check? domain-type knowledge)
operand-string] operand-string]
[else [else
(assemble-domain-check domain-type operand-string position)])) (assemble-domain-check domain-type operand-string position)]))
@ -217,9 +217,22 @@
(: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean)) (: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean))
(define (redundant-check? domain-type knowledge) (define (redundant-check? domain-type knowledge)
#f) (cond [(Const? knowledge)
(case domain-type
[(number)
(number? (Const-const knowledge))]
[(string)
(string? (Const-const knowledge))]
[(box)
(box? (Const-const knowledge))]
[(list)
(list? (Const-const knowledge))]
[(pair)
(pair? (Const-const knowledge))])]
[else
#f]))
(: repeat (All (A) (A Natural -> (Listof A)))) (: repeat (All (A) (A Natural -> (Listof A))))
(define (repeat x n) (define (repeat x n)
(build-list n (lambda (i) x))) (build-list n (lambda (i) x)))

6
compile.rkt
View File

@ -396,7 +396,9 @@
[(StaticallyKnownLam? op-knowledge) [(StaticallyKnownLam? op-knowledge)
(compile-statically-known-lam-application op-knowledge exp cenv extended-cenv target linkage)] (compile-statically-known-lam-application op-knowledge exp cenv extended-cenv target linkage)]
[(Prefix? op-knowledge) [(Prefix? op-knowledge)
(error 'impossible)])))) (error 'impossible)]
[(Const? op-knowledge)
(error 'application "Can't apply constant ~s as a function" (Const-const op-knowledge))]))))
(: compile-general-application (App CompileTimeEnvironment CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-general-application (App CompileTimeEnvironment CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -754,6 +756,8 @@
name] name]
[else [else
'?]))] '?]))]
[(Constant? exp)
(make-Const (Constant-v exp))]
[else [else
'?])) '?]))

1
il-structs.rkt
View File

@ -325,6 +325,7 @@
Prefix ;; placeholder: necessary since the toplevel lives in the environment too Prefix ;; placeholder: necessary since the toplevel lives in the environment too
StaticallyKnownLam ;; The value is a known lam StaticallyKnownLam ;; The value is a known lam
ModuleVariable ;; The value is a known module variable ModuleVariable ;; The value is a known module variable
Const
)) ))
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry)) (define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))