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

in the middle of getting arity

Browse Source
This commit is contained in:
Danny Yoo 2011-04-11 14:05:01 -04:00
parent 9094c345cd
commit f76bec0d13
2 changed files with 16 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
compile.rkt
View File

@ -712,7 +712,17 @@
(values (reverse constants) rands)))]))) (values (reverse constants) rands)))])))
(define-predicate natural? Natural)
(: arity-matches? (Arity Natural -> Boolean))
(define (arity-matches? an-arity n)
(cond
[(natural? an-arity)
(= an-arity n)]
[(ArityAtLeast? an-arity)
(>= n (ArityAtLeast-value an-arity))]
[else
(error 'fixme)]))
(: compile-statically-known-lam-application (: compile-statically-known-lam-application
@ -721,8 +731,8 @@
(define (compile-statically-known-lam-application static-knowledge exp cenv target linkage) (define (compile-statically-known-lam-application static-knowledge exp cenv target linkage)
;; FIXME: this needs to be turned into a runtime error, not a compile-time error, to preserve ;; FIXME: this needs to be turned into a runtime error, not a compile-time error, to preserve
;; Racket semantics. ;; Racket semantics.
(unless (= (length (App-operands exp)) (unless (arity-matches? (StaticallyKnownLam-arity static-knowledge)
(StaticallyKnownLam-arity static-knowledge)) (length (App-operands exp)))
(error 'arity-mismatch "~s expected ~s arguments, but received ~s" (error 'arity-mismatch "~s expected ~s arguments, but received ~s"
(StaticallyKnownLam-name static-knowledge) (StaticallyKnownLam-name static-knowledge)
(StaticallyKnownLam-arity static-knowledge) (StaticallyKnownLam-arity static-knowledge)
@ -1009,7 +1019,9 @@
[(Lam? exp) [(Lam? exp)
(make-StaticallyKnownLam (Lam-name exp) (make-StaticallyKnownLam (Lam-name exp)
(Lam-entry-label exp) (Lam-entry-label exp)
(Lam-num-parameters exp))] (if (Lam-rest? exp)
(make-ArityAtLeast (Lam-num-parameters exp))
(Lam-num-parameters exp)))]
[(and (LocalRef? exp) [(and (LocalRef? exp)
(not (LocalRef-unbox? exp))) (not (LocalRef-unbox? exp)))
(let ([entry (list-ref cenv (LocalRef-depth exp))]) (let ([entry (list-ref cenv (LocalRef-depth exp))])

2
il-structs.rkt
View File

@ -364,7 +364,7 @@
;; statically known things, to generate better code. ;; statically known things, to generate better code.
(define-struct: StaticallyKnownLam ([name : (U Symbol False)] (define-struct: StaticallyKnownLam ([name : (U Symbol False)]
[entry-point : Symbol] [entry-point : Symbol]
[arity : Natural]) #:transparent) [arity : Arity]) #:transparent)
(define-type CompileTimeEnvironmentEntry (define-type CompileTimeEnvironmentEntry
(U '? ;; no knowledge (U '? ;; no knowledge