From d2cc4852edecd036a44cd34f4fcedffa6588c13f Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 14 Mar 2011 16:38:16 -0400 Subject: [PATCH] trying to trace why conform is failing in an unexpected way --- simulator-primitives.rkt | 82 ++++++++++++++++++++++++++++++++++++---- simulator-structs.rkt | 10 ++++- simulator.rkt | 4 +- test-compiler.rkt | 5 ++- test-conform.rkt | 4 +- 5 files changed, 91 insertions(+), 14 deletions(-) diff --git a/simulator-primitives.rkt b/simulator-primitives.rkt index 5f60338..262e7f2 100644 --- a/simulator-primitives.rkt +++ b/simulator-primitives.rkt @@ -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)))])) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index e1aad89..52e522d 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -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)])) diff --git a/simulator.rkt b/simulator.rkt index 8e4bd50..3d878aa 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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) diff --git a/test-compiler.rkt b/test-compiler.rkt index 9063731..5543318 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -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)) diff --git a/test-conform.rkt b/test-conform.rkt index dd08ebf..651a73c 100644 --- a/test-conform.rkt +++ b/test-conform.rkt @@ -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)