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

getting weird error message from typed racket.

Browse Source
This commit is contained in:
Danny Yoo 2011-03-04 15:55:05 -05:00
parent b2df94e060
commit f1a9c6039c
3 changed files with 36 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
simulator-structs.rkt
View File

@ -16,14 +16,20 @@
#:transparent)
(define-struct: frame ([return : Symbol])
(define-struct: frame ([return : Symbol]
;; TODO: add continuation marks
)
#:transparent)
(define-struct: toplevel ([vals : (Vectorof Any)])
#:transparent)
;; Primitive procedure wrapper
(define-struct: primitive-proc ([f : (Any * -> Any)]))
(define-struct: primitive-proc ([f : (Any * -> Any)])
#:transparent)
;; Compiled procedure closures
(define-struct: closure ([label : Symbol]
[vals : (Listof Any)])
#:transparent)

22
simulator.rkt
View File

@ -12,7 +12,7 @@
(for-syntax racket/base))
(require/typed "simulator-prims.rkt"
[lookup-primitive (Symbol -> (Any * -> Any))])
[lookup-primitive (Symbol -> Any)])
(provide new-machine can-step? step)
@ -43,7 +43,7 @@
[(AssignPrimOpStatement? i)
(error 'step)]
[(PerformStatement? i)
(error 'step)]
(step-perform m i)]
[(GotoStatement? i)
(step-goto m i)]
[(TestAndBranchStatement? i)
@ -132,6 +132,24 @@
(machine-val m)]
[(eq? reg 'proc)
(machine-proc m)]))
(: step-perform (machine PerformStatement -> machine))
(define (step-perform m stmt)
(let: ([op : PrimitiveCommand (PerformStatement-op stmt)])
(cond
[(SetToplevel!? op)
(error 'step-perform)]
[(CheckToplevelBound!? op)
(error 'step-perform)]
[(ExtendEnvironment/Prefix!? op)
(env-push m
(make-toplevel (list->vector
(map lookup-primitive
(ExtendEnvironment/Prefix!-names op)))))]
[(InstallClosureValues!? op)
(error 'step-perform)])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

17
test-simulator.rkt
View File

@ -11,12 +11,7 @@
[(_ actual exp)
(with-syntax ([stx stx])
(syntax/loc #'stx
(let ([results (with-handlers ([exn:fail?
(lambda (exn)
(raise-syntax-error #f (format "Exception happened: ~s"
(exn-message exn))
#'stx))])
actual)])
(let ([results actual])
(unless (equal? actual exp)
(raise-syntax-error #f (format "Expected ~s, got ~s" exp results)
#'stx)))))]))
@ -227,8 +222,8 @@
;; AssignPrimOpStatement
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+ - * =)))))])
(test (machine-env (run m))
(list (make-toplevel (vector (lookup-primitive +)
(lookup-primitive -)
(lookup-primitive *)
(lookup-primitive =))))))
(test (first (machine-env (run m)))
(make-toplevel (vector (lookup-primitive '+)
(lookup-primitive '-)
(lookup-primitive '*)
(lookup-primitive '=)))))