From 1e83a6f8e595cc50ffeac7275191e4a9f7e76115 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 14 Mar 2011 17:04:48 -0400 Subject: [PATCH] still trying to figure out why the lexical scoping is breaking up --- simulator-helpers.rkt | 90 +++++++++++++++++++++++++++++++++++++- simulator-primitives.rkt | 31 +------------ simulator.rkt | 37 +++------------- test-compiler.rkt | 2 +- test-conform.rkt | 4 +- tests/conform/program0.sch | 18 +++++++- 6 files changed, 117 insertions(+), 65 deletions(-) diff --git a/simulator-helpers.rkt b/simulator-helpers.rkt index fef5e6c..543084d 100644 --- a/simulator-helpers.rkt +++ b/simulator-helpers.rkt @@ -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)))])) + diff --git a/simulator-primitives.rkt b/simulator-primitives.rkt index 262e7f2..5719cdf 100644 --- a/simulator-primitives.rkt +++ b/simulator-primitives.rkt @@ -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)))])) diff --git a/simulator.rkt b/simulator.rkt index 3d878aa..10c56a5 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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. diff --git a/test-compiler.rkt b/test-compiler.rkt index 5543318..e8eeeb9 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -2,7 +2,7 @@ (require "simulator.rkt" "simulator-structs.rkt" - "simulator-primitives.rkt" + "simulator-helpers.rkt" "compile.rkt" "parse.rkt") diff --git a/test-conform.rkt b/test-conform.rkt index 651a73c..5daf484 100644 --- a/test-conform.rkt +++ b/test-conform.rkt @@ -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")) diff --git a/tests/conform/program0.sch b/tests/conform/program0.sch index 5e99d4b..48f0579 100644 --- a/tests/conform/program0.sch +++ b/tests/conform/program0.sch @@ -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))) \ No newline at end of file +#;(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) '10))) \ No newline at end of file