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

trying to trace why conform is failing in an unexpected way

Browse Source
This commit is contained in:
Danny Yoo 2011-03-14 16:38:16 -04:00
parent cc61b1daf1
commit d2cc4852ed
5 changed files with 91 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
simulator-primitives.rkt
View File

@ -4,14 +4,24 @@
racket/math
(for-syntax racket/base))
(provide lookup-primitive)
(provide lookup-primitive
PrimitiveValue->racket)
(define-syntax (make-lookup stx)
(syntax-case stx ()
[(_ #:functions (name ...)
#:constants (cname ...))
(with-syntax ([(prim-name ...) (generate-temporaries #'(name ...))])
(with-syntax ([(prim-name ...) (generate-temporaries #'(name ...))]
[((name exported-name) ...)
(map (lambda (name)
(syntax-case name ()
[(real-name exported-name)
(list #'real-name #'exported-name)]
[_
(identifier? name)
(list name name)]))
(syntax->list #'(name ...)))])
(syntax/loc stx
(let ([prim-name (make-primitive-proc
(lambda (machine return-label . args)
@ -19,7 +29,7 @@
...)
(lambda (n)
(cond
[(eq? n 'name)
[(eq? n 'exported-name)
prim-name]
...
[(eq? n 'cname)
@ -37,15 +47,32 @@
(define e (exp 1))
(define my-cons (lambda (x y)
(make-MutablePair x y)))
(define my-list (lambda args
(let loop ([args args])
(cond
[(null? args)
null]
[else
(make-MutablePair (car args)
(loop (cdr args)))]))))
(define my-car (lambda (x)
(MutablePair-h x)))
(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >= cons list car cdr
(define my-cdr (lambda (x)
(MutablePair-t x)))
(define my-pair? (lambda (x)
(MutablePair? x)))
(define lookup-primitive (make-lookup #:functions (+ - * / = < <= > >=
sub1
display newline displayln
not
pair?
eq?
null?
eq?
add1
sub1
abs
@ -54,5 +81,44 @@
remainder
display
displayln
newline)
#:constants (null pi e call/cc call-with-current-continuation)))
newline
(my-cons cons)
(my-list list)
(my-car car)
(my-cdr cdr)
(my-pair? pair?)
vector
symbol?)
#:constants (null pi e
call/cc
call-with-current-continuation)))
(define (PrimitiveValue->racket v)
(cond
[(string? v)
v]
[(number? v)
v]
[(symbol? v)
v]
[(boolean? v)
v]
[(null? v)
v]
[(void? v)
v]
[(undefined? v)
(letrec ([x x]) x)]
[(primitive-proc? v)
v]
[(closure? v)
v]
[(vector? v)
(apply vector (map PrimitiveValue->racket (vector->list v)))]
[(MutablePair? v)
(cons (PrimitiveValue->racket (MutablePair-h v))
(PrimitiveValue->racket (MutablePair-t v)))]))

10
simulator-structs.rkt
View File

@ -11,8 +11,10 @@
primitive-proc
closure
(Pairof PrimitiveValue PrimitiveValue)
(Vectorof PrimitiveValue)
MutablePair
)))
(define-type SlotValue (U PrimitiveValue
(Boxof PrimitiveValue)
@ -20,6 +22,10 @@
CapturedControl
CapturedEnvironment))
(define-struct: MutablePair ([h : PrimitiveValue]
[t : PrimitiveValue]))
;; For continuation capture:
(define-struct: CapturedControl ([frames : (Listof frame)]))
(define-struct: CapturedEnvironment ([vals : (Listof SlotValue)]))

4
simulator.rkt
View File

@ -369,7 +369,9 @@
[(void? v)
v]
[(cons? v)
(cons (loop (car v)) (loop (cdr v)))]
(make-MutablePair (loop (car v)) (loop (cdr v)))]
[(MutablePair? v)
v]
[(primitive-proc? v)
v]
[(closure? v)

5
test-compiler.rkt
View File

@ -2,6 +2,7 @@
(require "simulator.rkt"
"simulator-structs.rkt"
"simulator-primitives.rkt"
"compile.rkt"
"parse.rkt")
@ -20,7 +21,7 @@
(printf "Running ~s ...\n" code)
(let*-values([(a-machine num-steps)
(run (new-machine (run-compiler code)) options ...)]
[(actual) (machine-val a-machine)])
[(actual) (PrimitiveValue->racket (machine-val a-machine))])
(unless (equal? actual exp)
(raise-syntax-error #f (format "Expected ~s, got ~s" exp actual)
#'stx))
@ -628,7 +629,7 @@
(test (read (open-input-file "tests/conform/program0.sch"))
#;(test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt")))
;(simulate (compile (parse '42) 'val 'next))

4
test-conform.rkt
View File

@ -61,5 +61,7 @@
#'stx))
(printf "ok. ~s steps.\n\n" num-steps)))))]))
(test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt")))
(port->string (open-input-file "tests/conform/expected0.txt"))
#:debug? #t)