From 882b228ae8979c6050849da71d4fb9395d55bce6 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Thu, 12 May 2011 14:36:06 -0400 Subject: [PATCH] trying to deal with case-lam's revised structure --- compiler.rkt | 57 ++++++++++++++++++++++++----------- expression-structs.rkt | 2 +- kernel-primitives.rkt | 1 + parse-bytecode-5.1.1.rkt | 9 ++++-- simulator.rkt | 6 ++-- test-compiler.rkt | 2 +- test-parse-bytecode-5.1.1.rkt | 7 +++++ 7 files changed, 59 insertions(+), 25 deletions(-) diff --git a/compiler.rkt b/compiler.rkt index 409d285..280df36 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -85,7 +85,7 @@ (extract-lambda-cenv exp cenv)))] [(CaseLam? exp) (cons (make-lam+cenv exp cenv) - (apply append (map (lambda: ([lam : Lam]) + (apply append (map (lambda: ([lam : (U Lam EmptyClosureReference)]) (loop lam cenv)) (CaseLam-clauses exp))))] @@ -652,15 +652,22 @@ ;; Compile each of the lambdas (apply append-instruction-sequences - (map (lambda: ([lam : Lam] + (map (lambda: ([lam : (U Lam EmptyClosureReference)] [target : Target]) (make-instruction-sequence `(,(make-AssignPrimOpStatement target - (make-MakeCompiledProcedure (Lam-entry-label lam) - (Lam-arity lam) - (shift-closure-map (Lam-closure-map lam) n) - (Lam-name lam)))))) + (cond + [(Lam? lam) + (make-MakeCompiledProcedure (Lam-entry-label lam) + (Lam-arity lam) + (shift-closure-map (Lam-closure-map lam) n) + (Lam-name lam))] + [(EmptyClosureReference? lam) + (make-MakeCompiledProcedure (EmptyClosureReference-entry-label lam) + (EmptyClosureReference-arity lam) + '() + (EmptyClosureReference-name lam))]))))) (CaseLam-clauses exp) (build-list (length (CaseLam-clauses exp)) (lambda: ([i : Natural]) @@ -680,19 +687,25 @@ singular-context-check)))) -(: Lam-arity (Lam -> Arity)) +(: Lam-arity ((U Lam EmptyClosureReference) -> Arity)) (define (Lam-arity lam) - (if (Lam-rest? lam) - (make-ArityAtLeast (Lam-num-parameters lam)) - (Lam-num-parameters lam))) + (cond + [(Lam? lam) + (if (Lam-rest? lam) + (make-ArityAtLeast (Lam-num-parameters lam)) + (Lam-num-parameters lam))] + [(EmptyClosureReference? lam) + (if (EmptyClosureReference-rest? lam) + (make-ArityAtLeast (EmptyClosureReference-num-parameters lam)) + (EmptyClosureReference-num-parameters lam))])) (: EmptyClosureReference-arity (EmptyClosureReference -> Arity)) (define (EmptyClosureReference-arity lam) - (if (EmptyClosureReference-rest? lam) +(if (EmptyClosureReference-rest? lam) (make-ArityAtLeast (EmptyClosureReference-num-parameters lam)) (EmptyClosureReference-num-parameters lam))) - + @@ -784,7 +797,7 @@ `(,(CaseLam-entry-label exp))) (apply append-instruction-sequences - (map (lambda: ([lam : Lam] + (map (lambda: ([lam : (U Lam EmptyClosureReference)] [i : Natural]) (let ([not-match (make-label 'notMatch)]) (make-instruction-sequence @@ -800,7 +813,11 @@ 'proc (make-CompiledProcedureClosureReference (make-Reg 'proc) i)) - ,(make-GotoStatement (make-Label (Lam-entry-label lam))) + ,(make-GotoStatement (make-Label + (cond [(Lam? lam) + (Lam-entry-label lam)] + [(EmptyClosureReference? lam) + (EmptyClosureReference-entry-label lam)]))) ,not-match)))) (CaseLam-clauses exp) @@ -2050,8 +2067,12 @@ [(CaseLam? exp) (make-CaseLam (CaseLam-name exp) - (map (lambda: ([lam : Lam]) - (ensure-lam (adjust-expression-depth lam n skip))) + (map (lambda: ([lam : (U Lam EmptyClosureReference)]) + (cond + [(Lam? lam) + (ensure-lam (adjust-expression-depth lam n skip))] + [(EmptyClosureReference? lam) + lam])) (CaseLam-clauses exp)) (CaseLam-entry-label exp))] @@ -2101,10 +2122,10 @@ (cons (ensure-lam (adjust-expression-depth (first procs) n - (+ skip (length (LetRec-procs exp))))) + skip)) (loop (rest procs)))])) (adjust-expression-depth (LetRec-body exp) n - (+ skip (length (LetRec-procs exp)))))] + skip))] [(InstallValue? exp) (if (< (InstallValue-depth exp) skip) diff --git a/expression-structs.rkt b/expression-structs.rkt index 9a09a7c..461d0fa 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -64,7 +64,7 @@ [alternative : Expression]) #:transparent) (define-struct: CaseLam ([name : (U Symbol LamPositionalName)] - [clauses : (Listof Lam)] + [clauses : (Listof (U Lam EmptyClosureReference))] [entry-label : Symbol]) #:transparent) (define-struct: Lam ([name : (U Symbol LamPositionalName)] diff --git a/kernel-primitives.rkt b/kernel-primitives.rkt index f2f719c..f09aa7a 100644 --- a/kernel-primitives.rkt +++ b/kernel-primitives.rkt @@ -46,6 +46,7 @@ 'continuation-mark-set->list 'values 'call-with-values + 'apply )) (define-predicate KernelPrimitiveName? KernelPrimitiveName) diff --git a/parse-bytecode-5.1.1.rkt b/parse-bytecode-5.1.1.rkt index b1114dc..537bd82 100644 --- a/parse-bytecode-5.1.1.rkt +++ b/parse-bytecode-5.1.1.rkt @@ -365,7 +365,7 @@ entry-point-label))])) -;; parse-closure: closure -> Expression +;; parse-closure: closure -> (U Lam EmptyClosureReference) ;; Either parses as a regular lambda, or if we come across the same closure twice, ;; breaks the cycle by creating an EmptyClosureReference with the pre-existing lambda ;; entry point. @@ -425,7 +425,12 @@ [(struct case-lam (name clauses)) (let ([case-lam-label (make-lam-label)]) (make-CaseLam (extract-lam-name name) - (map (lambda (l) (parse-lam l (make-lam-label))) + (map (lambda (l) + (cond + [(closure? l) + (parse-closure l)] + [else + (parse-lam l (make-lam-label))])) clauses) case-lam-label))])) diff --git a/simulator.rkt b/simulator.rkt index 69fcdeb..09ef0fe 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -391,17 +391,17 @@ 'ok)] [(RaiseContextExpectedValuesError!? op) - (error "context expected ~a values, received ~a values." + (error 'step "context expected ~a values, received ~a values." (RaiseContextExpectedValuesError!-expected op) (machine-argcount m))] [(RaiseArityMismatchError!? op) - (error "expects ~s arguments, given ~a" + (error 'step "expects ~s arguments, given ~a" (RaiseArityMismatchError!-expected op) (evaluate-oparg m (RaiseArityMismatchError!-received op)))] [(RaiseOperatorApplicationError!? op) - (error "expected procedure, given ~a" + (error 'step "expected procedure, given ~a" (evaluate-oparg m (RaiseOperatorApplicationError!-operator op)))] diff --git a/test-compiler.rkt b/test-compiler.rkt index 6789bcb..12340df 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -387,7 +387,7 @@ ;; deriv -(test '(let () +#;(test '(let () (define (deriv-aux a) (list '/ (deriv a) a)) (define (map f l) (if (null? l) diff --git a/test-parse-bytecode-5.1.1.rkt b/test-parse-bytecode-5.1.1.rkt index 0de4d08..429a958 100644 --- a/test-parse-bytecode-5.1.1.rkt +++ b/test-parse-bytecode-5.1.1.rkt @@ -371,6 +371,11 @@ +(void + (run-my-parse #'(case-lambda [(x) x] + [(x y) (list x y)]))) + + ;; make sure we don't see an infinite loop #;(run-zo-parse #'(letrec ([g (lambda () (g))]) (g))) @@ -390,6 +395,8 @@ + + #;(parameterize ([current-module-path "/home/dyoo/local/racket-5.1.1/lib/racket/collects/racket/private/foo.rkt"]) (run-my-parse/file "/home/dyoo/local/racket-5.1.1/lib/racket/collects/racket/private/for.rkt"))