diff --git a/golden/exec/begin-1/source.scm b/golden/exec/begin-1/source.scm new file mode 100644 index 0000000..c889138 --- /dev/null +++ b/golden/exec/begin-1/source.scm @@ -0,0 +1 @@ +(begin 123 456) ; => 456 diff --git a/golden/exec/callcc-early-exit/exec b/golden/exec/callcc-early-exit-1/exec similarity index 100% rename from golden/exec/callcc-early-exit/exec rename to golden/exec/callcc-early-exit-1/exec diff --git a/golden/exec/callcc-early-exit/source.scm b/golden/exec/callcc-early-exit-1/source.scm similarity index 100% rename from golden/exec/callcc-early-exit/source.scm rename to golden/exec/callcc-early-exit-1/source.scm diff --git a/golden/exec/callcc-early-exit-2/exec b/golden/exec/callcc-early-exit-2/exec new file mode 100644 index 0000000..7b842b0 --- /dev/null +++ b/golden/exec/callcc-early-exit-2/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > #t diff --git a/golden/exec/callcc-early-exit-2/source.scm b/golden/exec/callcc-early-exit-2/source.scm new file mode 100644 index 0000000..bb36ac8 --- /dev/null +++ b/golden/exec/callcc-early-exit-2/source.scm @@ -0,0 +1,4 @@ +(call/cc + (λ (k) + (begin (k #t) + #f))) diff --git a/golden/exec/callcc-early-exit-3/exec b/golden/exec/callcc-early-exit-3/exec new file mode 100644 index 0000000..7b842b0 --- /dev/null +++ b/golden/exec/callcc-early-exit-3/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > #t diff --git a/golden/exec/callcc-early-exit-3/source.scm b/golden/exec/callcc-early-exit-3/source.scm new file mode 100644 index 0000000..045c3c5 --- /dev/null +++ b/golden/exec/callcc-early-exit-3/source.scm @@ -0,0 +1,5 @@ +;; confer ../callcc-early-exit-4 +(letrec ((app (λ (f x) + (begin (f x) + #f)))) + (call/cc (λ (k) (app k #t)))) diff --git a/golden/exec/callcc-early-exit-4/exec b/golden/exec/callcc-early-exit-4/exec new file mode 100644 index 0000000..7b842b0 --- /dev/null +++ b/golden/exec/callcc-early-exit-4/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > #t diff --git a/golden/exec/callcc-early-exit-4/source.scm b/golden/exec/callcc-early-exit-4/source.scm new file mode 100644 index 0000000..6f3896a --- /dev/null +++ b/golden/exec/callcc-early-exit-4/source.scm @@ -0,0 +1,5 @@ +;; confer ../callcc-early-exit-3 +(letrec ((app (λ (f x) + (begin (f x) + #f)))) + (call/cc (λ (k) (app (λ (x) (k x)) #t)))) diff --git a/golden/exec/callcc-early-exit-5/exec b/golden/exec/callcc-early-exit-5/exec new file mode 100644 index 0000000..7b842b0 --- /dev/null +++ b/golden/exec/callcc-early-exit-5/exec @@ -0,0 +1,2 @@ +ret > ExitSuccess +out > #t diff --git a/golden/exec/callcc-early-exit-5/source.scm b/golden/exec/callcc-early-exit-5/source.scm new file mode 100644 index 0000000..c230305 --- /dev/null +++ b/golden/exec/callcc-early-exit-5/source.scm @@ -0,0 +1,5 @@ +(call/cc + (λ (k) + (begin ((λ (x) (k x)) + #t) + #f))) diff --git a/src/Gyehoek/Stack/VM.hs b/src/Gyehoek/Stack/VM.hs index b7ffc20..d2032ca 100644 --- a/src/Gyehoek/Stack/VM.hs +++ b/src/Gyehoek/Stack/VM.hs @@ -13,6 +13,7 @@ import Control.Lens import qualified Data.HashMap.Strict as H import Data.List (unfoldr) import Gyehoek.Prelude +import qualified Data.List.NonEmpty as NE data VM = MkVM @@ -133,11 +134,11 @@ eval p = initialVM & loop \vm -> case vm ^. #result of Nothing -> Right $ step (initialEnv p) vm Just rs -> Left rs -trace :: Program -> List VM -trace p = initialVM & unfoldr \vm -> +trace :: Program -> NonEmpty VM +trace p = initialVM & NE.unfoldr \vm -> case vm.result of - Just _ -> Nothing - Nothing -> Just (vm, step e vm) + Just _ -> (vm, Nothing) + Nothing -> (vm, Just $ step e vm) where e = initialEnv p writeObj :: Obj -> Text @@ -150,21 +151,75 @@ writeObj (ObjHob h) = case h of HobClosure code env -> "#" blah = [stkP| -(define ($lambda-body0-code7 %lambda-tail1 %lambda-body0 %x) - (prim %r2 (* %x %x)) - (tail-call %lambda-tail1 %r2)) - (define ($r3 %x4) - (pop! %main-ktail) - (tail-call %main-ktail %x4)) + (pop! %f) + (pop! %iter) + (pop! %lambda-tail1) + (pop! %n) + (prim %r5 (- %n 1)) + (prim %code22 (env-code %iter)) + (push! %lambda-tail1) + (tail-call %code22 $r6 %iter %r5 %f)) -(define ($main %main-ktail) - (prim %lambda-body0 (make-closure $lambda-body0-code7)) - (tail-call $let-body5 %lambda-body0)) +(define ($cc18 %r19) + (pop! %start-ktail0) + (tail-call %start-ktail0 %r19)) -(define ($let-body5 %square) - (pop! %main-ktail) - (prim %code6 (env-code %square)) - (push! %main-ktail) - (tail-call %code6 $r3 %square 4)) +(define ($lambda-body10-code26 %lambda-tail11 %lambda-body10 %n) + (prim %k (env-ref %lambda-body10 0)) + (prim %k (env-ref %lambda-body10 1)) + (prim %r12 (- %n 5)) + (prim %r13 (zero? %r12)) + (if %r13 + (then + (prim %code24 (env-code %k)) + (push! %lambda-tail11) + (tail-call %code24 $r14 %k #t)) + (else + (tail-call %lambda-tail11 #f)))) + +(define ($r6 %x7) + (pop! %lambda-tail1) + (tail-call %lambda-tail1 %x7)) + +(define ($r14 %x15) + (pop! %lambda-tail11) + (tail-call %lambda-tail11 %x15)) + +(define ($cc-ish20-code28 %_ %cc-ish20 %x21) + (prim %cc18 (env-ref %cc-ish20 0)) + (tail-call %cc18 %x21)) + +(define ($r16 %x17) + (pop! %lambda-tail9) + (tail-call %lambda-tail9 %x17)) + +(define ($iter-code30 %lambda-tail1 %iter %n %f) + (prim %r2 (zero? %n)) + (if %r2 + (then + (tail-call %lambda-tail1 #f)) + (else + (prim %code23 (env-code %f)) + (push! %n) + (push! %lambda-tail1) + (push! %iter) + (push! %f) + (tail-call %code23 $r3 %f %n)))) + +(define ($lambda-body8-code29 %lambda-tail9 %lambda-body8 %k) + (prim %iter (env-ref %lambda-body8 0)) + (prim %iter (env-ref %lambda-body8 1)) + (prim %lambda-body10 (make-closure $lambda-body10-code26 %k %k)) + (prim %code25 (env-code %iter)) + (push! %lambda-tail9) + (tail-call %code25 $r16 %iter 5 %lambda-body10)) + +(define ($start %start-ktail0) + (prim %iter (make-closure $iter-code30)) + (prim %lambda-body8 (make-closure $lambda-body8-code29 %iter %iter)) + (prim %cc-ish20 (make-closure $cc-ish20-code28 $cc18)) + (prim %code27 (env-code %lambda-body8)) + (push! %start-ktail0) + (tail-call %code27 $cc18 %lambda-body8 %cc-ish20)) |]