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 racket/math
(for-syntax racket/base)) (for-syntax racket/base))
(provide lookup-primitive) (provide lookup-primitive
PrimitiveValue->racket)
(define-syntax (make-lookup stx) (define-syntax (make-lookup stx)
(syntax-case stx () (syntax-case stx ()
[(_ #:functions (name ...) [(_ #:functions (name ...)
#:constants (cname ...)) #: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 (syntax/loc stx
(let ([prim-name (make-primitive-proc (let ([prim-name (make-primitive-proc
(lambda (machine return-label . args) (lambda (machine return-label . args)
@ -19,7 +29,7 @@
...) ...)
(lambda (n) (lambda (n)
(cond (cond
[(eq? n 'name) [(eq? n 'exported-name)
prim-name] prim-name]
... ...
[(eq? n 'cname) [(eq? n 'cname)
@ -37,15 +47,32 @@
(define e (exp 1)) (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 sub1
display newline displayln display newline displayln
not not
pair?
eq?
null? null?
eq?
add1 add1
sub1 sub1
abs abs
@ -54,5 +81,44 @@
remainder remainder
display display
displayln displayln
newline) newline
#:constants (null pi e call/cc call-with-current-continuation)))
(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 primitive-proc
closure closure
(Pairof PrimitiveValue PrimitiveValue) (Vectorof PrimitiveValue)
MutablePair
))) )))
(define-type SlotValue (U PrimitiveValue (define-type SlotValue (U PrimitiveValue
(Boxof PrimitiveValue) (Boxof PrimitiveValue)
@ -20,6 +22,10 @@
CapturedControl CapturedControl
CapturedEnvironment)) CapturedEnvironment))
(define-struct: MutablePair ([h : PrimitiveValue]
[t : PrimitiveValue]))
;; For continuation capture: ;; For continuation capture:
(define-struct: CapturedControl ([frames : (Listof frame)])) (define-struct: CapturedControl ([frames : (Listof frame)]))
(define-struct: CapturedEnvironment ([vals : (Listof SlotValue)])) (define-struct: CapturedEnvironment ([vals : (Listof SlotValue)]))

4
simulator.rkt
View File

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

5
test-compiler.rkt
View File

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

4
test-conform.rkt
View File

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