diff --git a/assemble-open-coded.rkt b/assemble-open-coded.rkt index c4c269b..c1fd767 100644 --- a/assemble-open-coded.rkt +++ b/assemble-open-coded.rkt @@ -209,7 +209,7 @@ (: maybe-typecheck-operand (OperandDomain Natural String CompileTimeEnvironmentEntry -> String)) (define (maybe-typecheck-operand domain-type position operand-string knowledge) (cond - [#t #;(redundant-check? domain-type knowledge) + [(redundant-check? domain-type knowledge) operand-string] [else (assemble-domain-check domain-type operand-string position)])) @@ -217,9 +217,22 @@ (: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean)) (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) (build-list n (lambda (i) x))) \ No newline at end of file diff --git a/compile.rkt b/compile.rkt index 6689e97..87dac45 100644 --- a/compile.rkt +++ b/compile.rkt @@ -396,7 +396,9 @@ [(StaticallyKnownLam? op-knowledge) (compile-statically-known-lam-application op-knowledge exp cenv extended-cenv target linkage)] [(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)) @@ -754,6 +756,8 @@ name] [else '?]))] + [(Constant? exp) + (make-Const (Constant-v exp))] [else '?])) diff --git a/il-structs.rkt b/il-structs.rkt index 299ae63..66011a4 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -325,6 +325,7 @@ Prefix ;; placeholder: necessary since the toplevel lives in the environment too StaticallyKnownLam ;; The value is a known lam ModuleVariable ;; The value is a known module variable + Const )) (define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))