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

still trying to figure out why the lexical scoping is breaking up

Browse Source
This commit is contained in:
Danny Yoo 2011-03-14 17:04:48 -04:00
parent d2cc4852ed
commit 1e83a6f8e5
6 changed files with 117 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
simulator-helpers.rkt
View File

@ -1,9 +1,97 @@
#lang racket/base
(require "simulator-structs.rkt")
(provide ensure-primitive-value-box)
(provide ensure-primitive-value-box
ensure-primitive-value
PrimitiveValue->racket
racket->PrimitiveValue)
(define (ensure-primitive-value-box x)
(if (and (box? x)
(PrimitiveValue? (unbox x)))
x
(error 'ensure-primitive-value-box "~s" x)))
;; Make sure the value is primitive.
(define (ensure-primitive-value val)
(let loop ([v val])
(cond
[(string? v)
v]
[(symbol? v)
v]
[(number? v)
v]
[(boolean? v)
v]
[(null? v)
v]
[(void? v)
v]
[(MutablePair? v)
v]
[(primitive-proc? v)
v]
[(closure? v)
v]
[(undefined? v)
v]
[(vector? v)
v]
[else
(error 'ensure-primitive-value "~s" v)])))
(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)))]))
(define (racket->PrimitiveValue v)
(cond
[(string? v)
v]
[(number? v)
v]
[(symbol? v)
v]
[(boolean? v)
v]
[(null? v)
v]
[(void? v)
v]
[(eq? v (letrec ([x x]) x))
(make-undefined)]
[(procedure? v)
(error 'racket->PrimitiveValue "Can't coerse procedure")]
[(vector? v)
(apply vector (map racket->PrimitiveValue (vector->list v)))]
[(pair? v)
(make-MutablePair (racket->PrimitiveValue (car v))
(racket->PrimitiveValue (cdr v)))]))

31
simulator-primitives.rkt
View File

@ -4,8 +4,7 @@
racket/math
(for-syntax racket/base))
(provide lookup-primitive
PrimitiveValue->racket)
(provide lookup-primitive)
(define-syntax (make-lookup stx)
@ -82,7 +81,7 @@
display
displayln
newline
symbol->string
(my-cons cons)
(my-list list)
@ -96,29 +95,3 @@
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)))]))

37
simulator.rkt
View File

@ -15,8 +15,10 @@
[lookup-primitive (Symbol -> PrimitiveValue)])
(require/typed "simulator-helpers.rkt"
[ensure-primitive-value-box (Any -> (Boxof PrimitiveValue))])
[ensure-primitive-value-box (SlotValue -> (Boxof PrimitiveValue))]
[ensure-primitive-value (SlotValue -> PrimitiveValue)]
[racket->PrimitiveValue (Any -> PrimitiveValue)])
(provide new-machine can-step? step! current-instruction
current-simulated-output-port
@ -296,7 +298,7 @@
(define (evaluate-oparg m an-oparg)
(cond
[(Const? an-oparg)
(ensure-primitive-value (Const-const an-oparg))]
(racket->PrimitiveValue (Const-const an-oparg))]
[(Label? an-oparg)
(Label-name an-oparg)]
@ -351,35 +353,6 @@
(error 'ensure-closure)))
(: ensure-primitive-value (Any -> PrimitiveValue))
;; Make sure the value is primitive.
(define (ensure-primitive-value val)
(let: loop : PrimitiveValue ([v : Any val])
(cond
[(string? v)
v]
[(symbol? v)
v]
[(number? v)
v]
[(boolean? v)
v]
[(null? v)
v]
[(void? v)
v]
[(cons? v)
(make-MutablePair (loop (car v)) (loop (cdr v)))]
[(MutablePair? v)
v]
[(primitive-proc? v)
v]
[(closure? v)
v]
[(undefined? v)
v]
[else
(error 'ensure-primitive-value "Unable to coerse Const ~s to a primitive value" v)])))
(: ensure-symbol (Any -> Symbol))
;; Make sure the value is a symbol.

2
test-compiler.rkt
View File

@ -2,7 +2,7 @@
(require "simulator.rkt"
"simulator-structs.rkt"
"simulator-primitives.rkt"
"simulator-helpers.rkt"
"compile.rkt"
"parse.rkt")

4
test-conform.rkt
View File

@ -19,7 +19,8 @@
(let loop ([steps 0])
(when debug?
(when (can-step? m)
(printf "|env|=~s, |control|=~s, instruction=~s\n"
(printf "pc=~s, |env|=~s, |control|=~s, instruction=~s\n"
(machine-pc m)
(length (machine-env m))
(length (machine-control m))
(current-instruction m))))
@ -61,6 +62,7 @@
#'stx))
(printf "ok. ~s steps.\n\n" num-steps)))))]))
(current-simulated-output-port (current-output-port))
(test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt"))

18
tests/conform/program0.sch
View File

@ -87,6 +87,10 @@
(define set-internal-node-blue-edges! (lambda (node edges) (vector-set! node '3 edges)))
(define make-node
(lambda (name blue-edges)
(displayln "name:")
(displayln name)
(displayln "blue-edges:")
(displayln blue-edges)
(let ((name (if (symbol? name) (symbol->string name) name))
(blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges))))
(make-internal-node name '() '() blue-edges))))
@ -211,7 +215,12 @@
(map (lambda (class) (fix (car class))) classes)
(fix-table (already-met graph))
(fix-table (already-joined graph))))))
(displayln 'here)
(define none-node (make-node 'none '(#t)))
(displayln 'here5)
(define none-node? (lambda (node) (eq? node none-node)))
(define any-node (make-node 'any ('())))
(define any-node? (lambda (node) (eq? node any-node)))
@ -229,6 +238,7 @@
(if (none-node? from-node)
(begin '#t)
(if (memq to-node (red-edges from-node)) (begin '#t) (begin '#f))))))
(displayln 'here4)
(define sig
(let ((none-comma-any (cons none-node any-node)))
(lambda (op node)
@ -236,6 +246,7 @@
(if (not (null? the-edge)) (cons (arg-node the-edge) (res-node the-edge)) none-comma-any)))))
(define arg (lambda (pair) (car pair)))
(define res (lambda (pair) (cdr pair)))
(displayln 'here3)
(define conforms?
(lambda (t1 t2)
(letrec ((nodes-with-red-edges-out '())
@ -327,6 +338,11 @@
(define blue-edge-operate
(lambda (arg-fn res-fn graph op sig1 sig2)
(make-blue-edge op (arg-fn graph (arg sig1) (arg sig2)) (res-fn graph (res sig1) (res sig2)))))
(displayln 'here2)
(define meet
(lambda (graph node1 node2)
(if (eq? node1 node2)
@ -462,4 +478,4 @@
(newline))))
(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) '10)))
#;(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) '10)))