diff --git a/library/collections/virtual-sequences.factor b/library/collections/virtual-sequences.factor index f3db9a63aa..545280da75 100644 --- a/library/collections/virtual-sequences.factor +++ b/library/collections/virtual-sequences.factor @@ -6,7 +6,9 @@ USING: errors generic kernel math sequences-internals vectors ; ! A reversal of an underlying sequence. TUPLE: reversed ; -C: reversed [ set-delegate ] keep ; +C: reversed + #! A delegate f means no delegate... + [ >r [ { } ] unless* r> set-delegate ] keep ; : reversed@ delegate [ length swap - 1- ] keep ; inline diff --git a/library/compiler/inference/branches.factor b/library/compiler/inference/branches.factor index e8d9f3b080..64659697c8 100644 --- a/library/compiler/inference/branches.factor +++ b/library/compiler/inference/branches.factor @@ -54,8 +54,8 @@ namespaces parser prettyprint sequences strings vectors words ; : callstack-effect ( seq -- ) dup length 0 - swap meta-r active-variable - unify-effect meta-r set drop ; + swap meta-c active-variable + unify-effect meta-c set drop ; : unify-effects ( seq -- ) dup datastack-effect dup callstack-effect @@ -65,7 +65,7 @@ namespaces parser prettyprint sequences strings vectors words ; [ [ dataflow-graph get ] bind ] map ; : copy-inference ( -- ) - meta-r [ clone ] change + meta-c [ clone ] change meta-d [ clone ] change d-in [ ] change dataflow-graph off @@ -73,7 +73,7 @@ namespaces parser prettyprint sequences strings vectors words ; : infer-branch ( value -- namespace ) #! Return a namespace with inferencer variables: - #! meta-d, meta-r, d-in. They are set to f if + #! meta-d, meta-c, d-in. They are set to f if #! terminate was called. [ [ diff --git a/library/compiler/inference/dataflow.factor b/library/compiler/inference/dataflow.factor index 9747528793..5c96f5858c 100644 --- a/library/compiler/inference/dataflow.factor +++ b/library/compiler/inference/dataflow.factor @@ -34,7 +34,7 @@ M: node = eq? ; : meta-d-node meta-d get clone in-node ; : d-tail ( n -- list ) meta-d get tail* ; -: r-tail ( n -- list ) meta-r get tail* ; +: c-tail ( n -- list ) meta-c get tail* ; : node-child node-children first ; @@ -97,12 +97,12 @@ C: #declare make-node ; : node-inputs ( d-count r-count node -- ) tuck - >r r-tail r> set-node-in-r + >r c-tail r> set-node-in-r >r d-tail r> set-node-in-d ; : node-outputs ( d-count r-count node -- ) tuck - >r r-tail r> set-node-out-r + >r c-tail r> set-node-out-r >r d-tail r> set-node-out-d ; ! Variable holding dataflow graph being built. diff --git a/library/compiler/inference/inference.factor b/library/compiler/inference/inference.factor index 4daa433220..b318e0a173 100644 --- a/library/compiler/inference/inference.factor +++ b/library/compiler/inference/inference.factor @@ -15,7 +15,7 @@ SYMBOL: base-case-continuation TUPLE: inference-error message rstate data-stack call-stack ; : inference-error ( msg -- ) - recursive-state get meta-d get meta-r get + recursive-state get meta-d get meta-c get throw ; M: inference-error error. ( error -- ) @@ -64,7 +64,7 @@ SYMBOL: terminated? : init-inference ( recursive-state -- ) terminated? off - V{ } clone meta-r set + V{ } clone meta-c set V{ } clone meta-d set 0 d-in set recursive-state set diff --git a/library/kernel.factor b/library/kernel.factor index dc4581b3f0..0e473d75d6 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -23,7 +23,7 @@ M: object clone ; : set-boot ( quot -- ) 8 setenv ; -: num-types ( -- n ) 20 ; inline +: num-types ( -- n ) 19 ; inline : ? ( cond t f -- t/f ) rot [ drop ] [ nip ] if ; inline diff --git a/library/test/continuations.factor b/library/test/continuations.factor index 9e0664e8d3..087076ab18 100644 --- a/library/test/continuations.factor +++ b/library/test/continuations.factor @@ -5,15 +5,17 @@ USE: math USE: namespaces USE: io USE: test +USE: sequences +USE: vectors : (callcc1-test) - swap 1- tuck swons + swap 1- tuck swap ?push over 0 = [ "test-cc" get continue-with ] when (callcc1-test) ; : callcc1-test ( x -- list ) [ - "test-cc" set [ ] (callcc1-test) + "test-cc" set V{ } clone (callcc1-test) ] callcc1 nip ; : callcc-namespace-test ( -- ? ) @@ -25,5 +27,5 @@ USE: test ] with-scope ] callcc0 "x" get 5 = ; -[ t ] [ 10 callcc1-test 10 >list = ] unit-test +[ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test [ t ] [ callcc-namespace-test ] unit-test diff --git a/library/test/generic.factor b/library/test/generic.factor index ff425cd673..01f215c621 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -39,7 +39,7 @@ M: object sorting-test drop "object" ; [ "object" ] [ f sorting-test ] unit-test ! Testing unions -UNION: funnies ratio complex ; +UNION: funnies quotation ratio complex ; GENERIC: funny M: funnies funny drop 2 ; diff --git a/library/test/init.factor b/library/test/init.factor index c4b418dab4..ad3ff93582 100644 --- a/library/test/init.factor +++ b/library/test/init.factor @@ -13,26 +13,3 @@ USE: hashtables [ "sdl.factor" ] [ "sdl.factor" cli-arg ] unit-test ] with-scope - -: traverse-path ( name object -- object ) - dup hashtable? [ hash ] [ 2drop f ] if ; - -: (object-path) ( object list -- object ) - [ uncons >r swap traverse-path r> (object-path) ] when* ; - -: object-path ( list -- object ) - #! An object path is a list of strings. Each string is a - #! variable name in the object namespace at that level. - #! Returns f if any of the objects are not set. - namespace swap (object-path) ; - -[ - 5 [ "test" "object" "path" ] set-path - [ 5 ] [ [ "test" "object" "path" ] object-path ] unit-test - - 7 [ "test" "object" "pathe" ] set-path - [ 7 ] [ [ "test" "object" "pathe" ] object-path ] unit-test - - 9 [ "teste" "object" "pathe" ] set-path - [ 9 ] [ [ "teste" "object" "pathe" ] object-path ] unit-test -] with-scope diff --git a/library/test/interpreter.factor b/library/test/interpreter.factor index 36efb005b2..655e8151ab 100644 --- a/library/test/interpreter.factor +++ b/library/test/interpreter.factor @@ -1,18 +1,19 @@ +IN: temporary USING: errors interpreter io kernel lists math math-internals namespaces prettyprint sequences test ; -IN: temporary : done-cf? ( -- ? ) meta-cf get not ; -: done? ( -- ? ) done-cf? meta-r get length 0 = and ; +: done? ( -- ? ) done-cf? meta-c get empty? and ; : run ( -- ) done? [ next do run ] unless ; : init-interpreter ( -- ) - V{ } clone meta-r set V{ } clone meta-d set - namestack meta-n set - catchstack meta-c set + V{ } clone meta-r set + V{ } clone meta-c set + namestack meta-name set + catchstack meta-catch set meta-cf off meta-executing off ; diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index 27882139df..d42cf8681e 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -8,17 +8,21 @@ namespaces prettyprint sequences strings vectors words ; ! continuation to and from the primary interpreter. Used by ! compiler for partial evaluation, also by the walker. -! Meta-stacks -SYMBOL: meta-r -: push-r meta-r get push ; -: pop-r meta-r get pop ; -: peek-r meta-r get peek ; +! Meta-stacks; SYMBOL: meta-d : push-d meta-d get push ; : pop-d meta-d get pop ; : peek-d meta-d get peek ; -SYMBOL: meta-n +SYMBOL: meta-r +: push-r meta-r get push ; +: pop-r meta-r get pop ; +: peek-r meta-r get peek ; SYMBOL: meta-c +: push-c meta-c get push ; +: pop-c meta-c get pop ; +: peek-c meta-c get peek ; +SYMBOL: meta-name +SYMBOL: meta-catch ! Call frame SYMBOL: meta-cf @@ -27,28 +31,34 @@ SYMBOL: meta-cf SYMBOL: meta-executing ! Callframe. -: up ( -- ) pop-r meta-cf set pop-r drop ; +: up ( -- ) pop-c meta-cf set pop-c drop ; : next ( -- obj ) meta-cf get [ meta-cf [ uncons ] change ] [ up next ] if ; : meta-interp ( -- interp ) - meta-d get meta-r get meta-n get meta-c get ; + meta-d get meta-r get meta-c get + meta-name get meta-catch get ; : set-meta-interp ( interp -- ) - >continuation< meta-c set meta-n set meta-r set meta-d set ; + >continuation< + meta-catch set + meta-name set + meta-c set + meta-r set + meta-d set ; : host-word ( word -- ) [ - \ call push-r - [ continuation swap continue-with ] cons cons push-r + \ call push-c + [ continuation swap continue-with ] cons cons push-c meta-interp continue ] callcc1 set-meta-interp pop-d 2drop ; : meta-call ( quot -- ) #! Note we do tail call optimization here. meta-cf [ - [ meta-executing get push-r push-r ] when* + [ meta-executing get push-c push-c ] when* ] change ; GENERIC: do-1 ( object -- ) diff --git a/library/tools/walker.factor b/library/tools/walker.factor index 5372320ef6..2a6adbfc09 100644 --- a/library/tools/walker.factor +++ b/library/tools/walker.factor @@ -7,12 +7,14 @@ vectors words ; : &s ( -- ) meta-d get stack. ; -: meta-r* - [ meta-r get % meta-executing get , meta-cf get , ] { } make ; +: &r ( -- ) meta-r get stack. ; -: &r ( -- ) meta-r* stack. ; +: meta-c* + [ meta-c get % meta-executing get , meta-cf get , ] { } make ; -: &get ( var -- value ) meta-n get hash-stack ; +: &c ( -- ) meta-c* stack. ; + +: &get ( var -- value ) meta-name get hash-stack ; : report ( -- ) meta-cf get . ; @@ -21,10 +23,10 @@ vectors words ; : into ( -- ) next do report ; : end-walk ( -- ) - \ call push-r meta-cf get push-r meta-interp continue ; + \ call push-c meta-cf get push-c meta-interp continue ; : walk-banner ( -- ) - "&s &r show stepper stacks" print + "&s &r &c show stepper stacks" print "&get ( var -- value ) get stepper variable value" print "step -- single step over" print "into -- single step into" print @@ -36,8 +38,16 @@ vectors words ; "walk " listener-prompt set ; : walk ( quot -- ) - datastack dup pop* callstack namestack catchstack [ - meta-c set meta-n set meta-r set meta-d set + datastack dup pop* + retainstack + callstack + namestack + catchstack [ + meta-catch set + meta-name set + meta-c set + meta-r set + meta-d set meta-cf set meta-executing off set-walk-hooks