From bf5d88b64920e42360e978032aa1c48171388303 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 14 Sep 2005 04:37:50 +0000 Subject: [PATCH] changes to continuation words --- examples/numbers-game.factor | 2 +- library/alien/compiler.factor | 9 +- library/collections/lists.factor | 5 - library/collections/sequences-epilogue.factor | 28 +++- library/compiler/basic-blocks.factor | 4 +- library/compiler/compiler.factor | 17 +- library/compiler/xt.factor | 15 +- library/continuations.factor | 44 ++++-- library/errors.factor | 13 +- library/generic/standard-combination.factor | 5 +- library/inference/branches.factor | 2 +- library/inference/class-infer.factor | 10 +- library/inference/inference.factor | 21 +-- library/inference/optimizer.factor | 7 +- library/inference/words.factor | 39 +++-- library/io/files.factor | 6 +- library/syntax/parse-stream.factor | 21 +-- library/syntax/prettyprint.factor | 6 +- library/syntax/see.factor | 5 +- library/test/benchmark/continuations.factor | 7 +- library/test/collections/sequences.factor | 6 + library/test/continuations.factor | 12 +- library/test/inference.factor | 146 +++++++++--------- library/test/lists/lists.factor | 4 - library/test/lists/namespaces.factor | 13 -- library/test/redefine.factor | 2 +- library/test/tuple.factor | 2 +- library/threads.factor | 9 +- library/tools/annotations.factor | 11 +- library/tools/debugger.factor | 4 +- library/tools/inspector.factor | 5 +- library/tools/interpreter.factor | 7 +- library/tools/jedit.factor | 14 +- library/tools/memory.factor | 33 ++-- library/ui/fonts.factor | 2 +- library/ui/hand.factor | 11 +- library/ui/hierarchy.factor | 7 +- library/ui/panes.factor | 4 +- library/unix/io.factor | 10 +- library/unix/sockets.factor | 4 +- native/run.c | 2 +- native/run.h | 7 +- 42 files changed, 292 insertions(+), 289 deletions(-) diff --git a/examples/numbers-game.factor b/examples/numbers-game.factor index 18ee288ce0..32765d7f17 100644 --- a/examples/numbers-game.factor +++ b/examples/numbers-game.factor @@ -1,7 +1,7 @@ IN: numbers-game USING: kernel math parser random io ; -: read-number ( -- n ) readln str>number ; +: read-number ( -- n ) readln string>number ; : guess-banner "I'm thinking of a number between 0 and 100." print ; diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor index 8542d39080..649ef6c166 100644 --- a/library/alien/compiler.factor +++ b/library/alien/compiler.factor @@ -47,16 +47,11 @@ C: alien-node make-node ; : set-alien-return ( return node -- ) 2dup set-alien-node-return - swap "void" = [ - drop - ] [ - [ object ] produce-d 1 0 rot node-outputs - ] ifte ; + swap "void" = [ 1 over produce-values ] unless drop ; : set-alien-parameters ( parameters node -- ) 2dup set-alien-node-parameters - >r [ drop object ] map dup dup ensure-d - length 0 r> node-inputs consume-d ; + >r length r> consume-values ; : ensure-dlsym ( symbol library -- ) load-library dlsym drop ; diff --git a/library/collections/lists.factor b/library/collections/lists.factor index 1903a3dde4..37bd4bd93f 100644 --- a/library/collections/lists.factor +++ b/library/collections/lists.factor @@ -39,11 +39,6 @@ M: cons map ( cons quot -- cons ) M: general-list find ( list quot -- i elt ) 0 (list-find) ; -: unique ( elem list -- list ) - #! Prepend an element to a list if it does not occur in the - #! list. - 2dup member? [ nip ] [ cons ] ifte ; - M: general-list reverse-slice ( list -- list ) [ ] [ swons ] reduce ; diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index e8a3ef34e0..c6503b057a 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -36,6 +36,20 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ; : memq? ( obj seq -- ? ) [ eq? ] contains-with? ; flushable : remove ( obj list -- list ) [ = not ] subset-with ; flushable +: move ( to from seq -- ) + pick pick number= + [ 3drop ] [ [ nth swap ] keep set-nth ] ifte ; inline + +: (delete) ( elt store scan seq -- ) + 2dup length < [ + 3dup move + >r pick over r> dup >r nth = r> swap + [ >r >r 1 + r> r> ] unless >r 1 + r> (delete) + ] when ; + +: delete ( elt seq -- ) + 0 0 rot (delete) nip set-length drop ; + : copy-into-check ( start to from -- ) rot rot length + swap length < [ "Cannot copy beyond end of sequence" throw @@ -74,27 +88,29 @@ M: object peek ( sequence -- element ) #! Get value at end of sequence. dup length 1 - swap nth ; +: pop* ( sequence -- ) + #! Shorten the sequence by one element. + dup length 1 - swap set-length ; + : pop ( sequence -- element ) #! Get value at end of sequence and remove it. - dup peek >r dup length 1 - swap set-length r> ; + dup peek swap pop* ; -: push-new ( elt seq -- ) +: adjoin ( elt seq -- ) 2dup member? [ 2drop ] [ push ] ifte ; : prune ( seq -- seq ) [ - dup length swap [ over push-new ] each + dup length swap [ over adjoin ] each ] keep like ; flushable -: >pop> ( stack -- stack ) dup pop drop ; - : join ( seq glue -- seq ) #! The new sequence is of the same type as glue. swap dup empty? [ swap like ] [ dup length swap - [ over push 2dup push ] each nip >pop> + [ over push 2dup push ] each nip dup pop* concat ] ifte ; flushable diff --git a/library/compiler/basic-blocks.factor b/library/compiler/basic-blocks.factor index 02dedde52a..5eed43de2b 100644 --- a/library/compiler/basic-blocks.factor +++ b/library/compiler/basic-blocks.factor @@ -58,7 +58,7 @@ M: %replace-r simplify-stack* ( vop -- ) 0 vop-out update-cs ; #! continuation with 'f'. @{ @{ [ 2dup vop-inputs member? ] [ 3drop t ] }@ - @{ [ 2dup vop-outputs member? ] [ 2drop f swap call ] }@ + @{ [ 2dup vop-outputs member? ] [ 2drop f swap continue-with ] }@ @{ [ t ] [ 3drop f ] }@ }@ cond ; @@ -76,7 +76,7 @@ M: cs-loc live@end? cs-loc-n r-height get + 0 >= ; [ -rot [ >r 2dup r> preserves-location? ] contains? [ dup live@end? ] unless* - ] callcc1 2nip ; + ] with-continuation 2nip ; ! Used for elimination of dead loads from the stack: ! we keep a map of vregs to ds-loc/cs-loc/f. diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index 6b48b94a9e..3e1d214676 100644 --- a/library/compiler/compiler.factor +++ b/library/compiler/compiler.factor @@ -15,9 +15,8 @@ words ; "Compiling " write dup . dup word-def precompile generate ; : compile-postponed ( -- ) - compile-words get [ - uncons compile-words set (compile) compile-postponed - ] when* ; + compile-words get dup empty? + [ dup pop (compile) compile-postponed ] unless drop ; : compile ( word -- ) [ postpone-word compile-postponed ] with-compiler ; @@ -40,3 +39,15 @@ words ; ] [ call ] ifte ; + +\ dataflow profile +\ optimize profile +\ linearize profile +\ split-blocks profile +\ simplify profile +\ keep-optimizing profile +\ kill-set profile +\ kill-node profile +\ infer-classes profile +\ solve-recursion profile +\ split-node profile diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor index ee8052de17..958a8ef094 100644 --- a/library/compiler/xt.factor +++ b/library/compiler/xt.factor @@ -27,10 +27,9 @@ SYMBOL: compiled-xts : compiled-xt ( word -- xt ) dup compiled-xts get assoc [ ] [ word-xt ] ?ifte ; -! Words being compiled are consed onto this list. When a word -! is encountered that has not been previously compiled, it is -! consed onto this list. Compilation stops when the list is -! empty. +! When a word is encountered that has not been previously +! compiled, it is pushed onto this vector. Compilation stops +! when the vector is empty. SYMBOL: compile-words @@ -135,14 +134,12 @@ M: absolute-16/16 fixup ( absolute -- ) >absolute fixup-16/16 ; [ deferred-xts off compiled-xts off + { } clone compile-words set call fixup-xts commit-xts ] with-scope ; : postpone-word ( word -- ) - dup compiling? over compound? not or [ - drop - ] [ - compile-words [ unique ] change - ] ifte ; + dup compiling? not over compound? and + [ dup compile-words get push ] when drop ; diff --git a/library/continuations.factor b/library/continuations.factor index d6f9411144..b3dcb0fca0 100644 --- a/library/continuations.factor +++ b/library/continuations.factor @@ -1,31 +1,47 @@ ! Copyright (C) 2003, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. -IN: kernel USING: errors lists namespaces sequences words ; +IN: kernel +USING: errors lists namespaces sequences words vectors ; TUPLE: interp data call name catch ; -: interp ( -- interp ) - datastack callstack >pop> >pop> +: continuation ( -- interp ) + #! The continuation is reified from after the *caller* of + #! this word returns. + datastack callstack dup pop* dup pop* namestack catchstack ; -: continuation ( interp -- ) - interp dup interp-call >pop> >pop> drop - dup interp-data >pop> drop ; - : >interp< ( interp -- data call name catch ) [ interp-data ] keep [ interp-call ] keep [ interp-name ] keep interp-catch ; -: set-interp ( interp quot -- ) - >r >interp< set-catchstack set-namestack - >r set-datastack r> r> swap set-callstack call ; +: quot>interp ( quot -- continuation ) + #! Make a continuation that executes the quotation. + #! The quotation should not return, or a call stack + #! underflow will be signalled. + { } swap 1 [ push ] keep f f ; + +: continue ( continuation -- ) + #! Restore a continuation. + >interp< + set-catchstack set-namestack set-callstack set-datastack ; + +: continue-with ( object continuation -- object ) + #! Restore a continuation, and place the object in the + #! restored data stack. + >interp< set-catchstack set-namestack + >r swap >r set-datastack r> r> set-callstack ; + +: with-continuation ( quot -- | quot: continuation -- ) + #! Call a quotation with the current continuation, which may + #! be restored using continue or continue-with. + >r continuation dup interp-call dup pop* drop + r> call ; inline : callcc0 ( quot ++ | quot: cont -- | cont: ++ ) - continuation - [ [ ] set-interp ] cons swap call ; + "use with-continuation instead" throw ; : callcc1 ( quot ++ obj | quot: cont -- | cont: obj ++ obj ) - continuation - [ swap literalize unit set-interp ] cons swap call ; + "use with-continuation instead" throw ; diff --git a/library/errors.factor b/library/errors.factor index 142d431916..065294e8f3 100644 --- a/library/errors.factor +++ b/library/errors.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: kernel -USING: kernel-internals lists ; -DEFER: callcc1 +DEFER: with-continuation +DEFER: continue-with + IN: errors +USING: kernel-internals lists ; ! This is a very lightweight exception handling system. @@ -17,15 +19,18 @@ TUPLE: no-method object generic ; : >c ( catch -- ) catchstack cons set-catchstack ; : c> ( catch -- ) catchstack uncons set-catchstack ; +: (catch) ( try -- exception/f ) + [ >c call f c> drop f ] with-continuation nip ; + : catch ( try catch -- ) #! Call the try quotation. If an error occurs restore the #! datastack, push the error, and call the catch block. #! If no error occurs, push f and call the catch block. - [ >c >r call c> drop f r> f ] callcc1 rot drop swap call ; + >r (catch) r> call ; : rethrow ( error -- ) #! Use rethrow when passing an error on from a catch block. #! For convinience, this word is a no-op if error is f. - [ c> call ] when* ; + [ c> continue-with ] when* ; GENERIC: error. ( error -- ) diff --git a/library/generic/standard-combination.factor b/library/generic/standard-combination.factor index 90ec19684a..c06a6157b2 100644 --- a/library/generic/standard-combination.factor +++ b/library/generic/standard-combination.factor @@ -23,9 +23,8 @@ namespaces sequences vectors words ; : sort-methods ( assoc -- vtable ) #! Input is a predicate -> method association. num-types [ - type>class dup - [ swap [ car classes-intersect? ] subset-with ] - [ 2drop f ] ifte + type>class [ object ] unless* + swap [ car classes-intersect? ] subset-with ] map-with ; : simplify-alist ( class alist -- default alist ) diff --git a/library/inference/branches.factor b/library/inference/branches.factor index e19da163d4..222b67f532 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -79,7 +79,7 @@ namespaces parser prettyprint sequences strings vectors words ; dup literal-value infer-quot active? [ #values node, ] when f - ] callcc1 [ terminate ] when drop + ] with-continuation [ terminate ] when drop ] make-hash ; : (infer-branches) ( branchlist -- list ) diff --git a/library/inference/class-infer.factor b/library/inference/class-infer.factor index 787752af85..7766561119 100644 --- a/library/inference/class-infer.factor +++ b/library/inference/class-infer.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: optimizer USING: arrays generic hashtables inference kernel -kernel-internals namespaces sequences words ; +kernel-internals math namespaces sequences words ; ! Infer possible classes of values in a dataflow IR. @@ -114,15 +114,15 @@ M: node child-ties ( node -- seq ) call ] [ node-param "infer-effect" word-prop second + dup integer? [ drop f ] when ] ?ifte ; M: #call infer-classes* ( node -- ) dup node-param [ dup create-ties - dup output-classes swap node-out-d intersect-classes - ] [ - drop - ] ifte ; + dup output-classes + [ over node-out-d intersect-classes ] when* + ] when drop ; M: #shuffle infer-classes* ( node -- ) node-out-d [ literal? ] subset diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 5f689c3ed1..84b22e98c9 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: inference -USING: errors generic interpreter io kernel lists math +USING: arrays errors generic interpreter io kernel lists math namespaces parser prettyprint sequences strings vectors words ; ! This variable takes a boolean value. @@ -50,22 +50,13 @@ SYMBOL: d-in : required-inputs ( n stack -- values ) length - 0 max computed-value-vector ; -: ensure-d ( typelist -- ) +: ensure-values ( n -- ) length meta-d get required-inputs dup - meta-d [ append ] change - d-in [ append ] change ; + meta-d [ append ] change d-in [ append ] change ; -: effect ( -- [[ in# out# ]] ) +: effect #! After inference is finished, collect information. - d-in get length object >list - meta-d get length object >list 2list ; - -: no-base-case ( word -- ) - { - "The base case of a recursive word could not be inferred.\n" - "This means the word calls itself in every control flow path.\n" - "See the handbook for details." - } concat inference-error ; + d-in get length meta-d get length 2array ; : init-inference ( recursive-state -- ) init-interpreter @@ -113,7 +104,7 @@ M: wrapper apply-object wrapped apply-literal ; : with-infer ( quot -- ) [ inferring-base-case off - [ no-base-case ] base-case-continuation set + base-case-continuation off f init-inference call check-return diff --git a/library/inference/optimizer.factor b/library/inference/optimizer.factor index b4bbb83614..311650c797 100644 --- a/library/inference/optimizer.factor +++ b/library/inference/optimizer.factor @@ -29,11 +29,14 @@ DEFER: optimize-node over set-node-successor r> r> r> or or ] [ r> ] ifte ; -: optimize-loop ( dataflow -- dataflow ) +: optimize-1 ( dataflow -- dataflow ? ) recursive-state off dup kill-set over kill-node dup infer-classes - optimize-node [ optimize-loop ] when ; + optimize-node ; + +: optimize-loop ( dataflow -- dataflow ) + optimize-1 [ optimize-loop ] when ; : optimize ( dataflow -- dataflow ) [ diff --git a/library/inference/words.factor b/library/inference/words.factor index 29e39658a6..d78010dbc2 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -5,26 +5,20 @@ USING: errors generic interpreter kernel lists math math-internals namespaces sequences strings vectors words hashtables parser prettyprint ; -: consume-d ( typelist -- ) - [ pop-d 2drop ] each ; +: consume-values ( n node -- ) + over ensure-values + over 0 rot node-inputs [ pop-d 2drop ] each ; -: produce-d ( typelist -- ) - [ drop push-d ] each ; - -: hairy-node ( node effect quot -- quot: -- ) - over car ensure-d - -rot 2dup car length 0 rot node-inputs - 2slip - second length 0 rot node-outputs ; inline +: produce-values ( n node -- ) + over [ drop push-d ] each 0 swap node-outputs ; : consume/produce ( word effect -- ) #! Add a node to the dataflow graph that consumes and #! produces a number of values. - swap #call [ - over [ - first2 swap consume-d produce-d - ] hairy-node - ] keep node, ; + swap #call + over first length over consume-values + swap second length over produce-values + node, ; : no-effect ( word -- ) "Stack effect inference of the word " swap word-name @@ -77,7 +71,7 @@ M: compound apply-word ( word -- ) ] [ dup "infer-effect" word-prop [ over "infer" word-prop [ - swap car ensure-d call drop + swap first length ensure-values call drop ] [ consume/produce ] ifte* @@ -111,6 +105,17 @@ M: symbol apply-object ( word -- ) rethrow ] catch ; +: no-base-case ( word -- ) + { + "The base case of a recursive word could not be inferred.\n" + "This means the word calls itself in every control flow path.\n" + "See the handbook for details." + } concat inference-error ; + +: notify-base-case ( -- ) + base-case-continuation get + [ t swap continue-with ] [ no-base-case ] ifte* ; + : recursive-word ( word [[ label quot ]] -- ) #! Handle a recursive call, by either applying a previously #! inferred base case, or raising an error. If the recursive @@ -122,7 +127,7 @@ M: symbol apply-object ( word -- ) nip consume/produce ] [ inferring-base-case get [ - t base-case-continuation get call + notify-base-case ] [ car base-case ] ifte diff --git a/library/io/files.factor b/library/io/files.factor index a4d8014d01..cbecb1a4a8 100644 --- a/library/io/files.factor +++ b/library/io/files.factor @@ -21,9 +21,9 @@ USING: kernel lists namespaces sequences strings ; DEFER: -: resource-path ( -- path ) - "resource-path" get [ "." ] unless* ; +: resource-path ( path -- path ) + "resource-path" get [ "." ] unless* swap path+ ; : ( path -- stream ) #! Open a file path relative to the Factor source code root. - resource-path swap path+ ; + resource-path ; diff --git a/library/syntax/parse-stream.factor b/library/syntax/parse-stream.factor index ee45a7299c..aac3b2459c 100644 --- a/library/syntax/parse-stream.factor +++ b/library/syntax/parse-stream.factor @@ -7,22 +7,18 @@ USING: kernel lists namespaces sequences io words ; "scratchpad" "in" set [ "syntax" "scratchpad" ] "use" set ; -: (parse-stream) ( stream -- quot ) +: parse-lines ( lines -- quot ) [ - lines dup length [ ] + dup length [ ] [ line-number set (parse) ] 2reduce reverse ] with-parser ; -: parse-stream ( name stream -- quot ) - [ - swap file set file-vocabs - (parse-stream) - file off line-number off - ] with-scope ; +: parse-stream ( stream name -- quot ) + [ file set file-vocabs lines parse-lines ] with-scope ; : parse-file ( file -- quot ) - dup parse-stream ; + [ ] keep parse-stream ; : run-file ( file -- ) parse-file call ; @@ -34,15 +30,14 @@ USING: kernel lists namespaces sequences io words ; #! resource:. This allows words that operate on source #! files, like "jedit", to use a different resource path #! at run time than was used at parse time. - "resource:" over append swap parse-stream ; + [ "resource:" ] keep append parse-stream ; : run-resource ( file -- ) parse-resource call ; : word-file ( word -- file ) - "file" word-prop dup [ - "resource:/" ?head [ resource-path swap path+ ] when - ] when ; + "file" word-prop dup + [ "resource:/" ?head [ resource-path ] when ] when ; : reload ( word -- ) #! Reload the source file the word originated from. diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index b4849609bd..f53dbe8ad9 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -58,7 +58,7 @@ C: section ( length -- section ) ] [ last-newline set line-count inc - line-limit? [ "..." write end-printing get call ] when + line-limit? [ "..." write end-printing get continue ] when "\n" write do-indent ] ifte ; @@ -161,7 +161,7 @@ C: pprinter ( -- stream ) [ end-printing set dup pprinter-block pprint-section - ] callcc0 drop ; + ] with-continuation drop ; GENERIC: pprint* ( obj -- ) @@ -264,7 +264,7 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ; : pprint-elements ( seq -- ) length-limit? >r [ pprint-element ] each - r> [ "... " f text ] when ; + r> [ "..." f text ] when ; : pprint-sequence ( seq start end -- ) swap pprint* swap pprint-elements pprint* ; diff --git a/library/syntax/see.factor b/library/syntax/see.factor index 21036957e3..b207da79d8 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2003, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: prettyprint -USING: generic hashtables io kernel lists namespaces sequences -styles words ; +USING: generic hashtables io kernel lists math namespaces +sequences styles words ; : declaration. ( word prop -- ) tuck word-name word-prop [ pprint-word ] [ drop ] ifte ; @@ -19,6 +19,7 @@ styles words ; [ [[ font-style italic ]] ] text ; : stack-picture% ( seq -- string ) + dup integer? [ object ] when [ word-name % " " % ] each ; : effect>string ( effect -- string ) diff --git a/library/test/benchmark/continuations.factor b/library/test/benchmark/continuations.factor index b44d9aa6d0..bf7839adb7 100644 --- a/library/test/benchmark/continuations.factor +++ b/library/test/benchmark/continuations.factor @@ -1,7 +1,4 @@ IN: temporary -USE: kernel -USE: math -USE: test +USING: kernel sequences test ; -! This caused the Java Factor to run out of memory -[ ] [ 100000 [ [ call ] callcc0 ] times ] unit-test +[ ] [ 100000 [ drop [ continue ] with-continuation ] each ] unit-test diff --git a/library/test/collections/sequences.factor b/library/test/collections/sequences.factor index f180800a2d..ff62a1b091 100644 --- a/library/test/collections/sequences.factor +++ b/library/test/collections/sequences.factor @@ -153,3 +153,9 @@ unit-test [ @{ "" "a" "aa" "aaa" }@ ] [ 4 [ CHAR: a fill ] map ] unit-test + +[ { } ] [ "f" { } clone [ delete ] keep ] unit-test +[ { } ] [ "f" { "f" } clone [ delete ] keep ] unit-test +[ { } ] [ "f" { "f" "f" } clone [ delete ] keep ] unit-test +[ { "x" } ] [ "f" { "f" "x" "f" } clone [ delete ] keep ] unit-test +[ { "y" "x" } ] [ "f" { "y" "f" "x" "f" } clone [ delete ] keep ] unit-test diff --git a/library/test/continuations.factor b/library/test/continuations.factor index 3c8fd435b0..f0a32a9001 100644 --- a/library/test/continuations.factor +++ b/library/test/continuations.factor @@ -8,27 +8,29 @@ USE: test : (callcc1-test) swap 1 - tuck swons - over 0 = [ "test-cc" get call ] when + over 0 = [ "test-cc" get continue-with ] when (callcc1-test) ; : callcc1-test ( x -- list ) [ "test-cc" set [ ] (callcc1-test) - ] callcc1 nip ; + ] with-continuation nip ; : callcc-namespace-test ( -- ? ) [ "test-cc" set 5 "x" set [ - 6 "x" set "test-cc" get call + 6 "x" set "test-cc" get continue ] with-scope - ] callcc0 "x" get 5 = ; + ] with-continuation "x" get 5 = ; [ t ] [ 10 callcc1-test 10 >list = ] unit-test [ t ] [ callcc-namespace-test ] unit-test : multishot-test ( -- stack ) - [ dup "cc" set 5 swap call ] callcc1 "cc" get car interp-data ; + [ + dup "cc" set 5 swap continue-with + ] with-continuation "cc" get interp-data ; [ 5 { } ] [ multishot-test ] unit-test diff --git a/library/test/inference.factor b/library/test/inference.factor index ff3f122813..8ebe6e8c4a 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -18,21 +18,19 @@ namespaces parser sequences test vectors ; compose-shuffle ] unit-test -: simple-effect first2 >r length r> length 2array ; +[ @{ 0 2 }@ ] [ [ 2 "Hello" ] infer ] unit-test +[ @{ 1 2 }@ ] [ [ dup ] infer ] unit-test -[ @{ 0 2 }@ ] [ [ 2 "Hello" ] infer simple-effect ] unit-test -[ @{ 1 2 }@ ] [ [ dup ] infer simple-effect ] unit-test +[ @{ 1 2 }@ ] [ [ [ dup ] call ] infer ] unit-test +[ [ call ] infer ] unit-test-fails -[ @{ 1 2 }@ ] [ [ [ dup ] call ] infer simple-effect ] unit-test -[ [ call ] infer simple-effect ] unit-test-fails +[ @{ 2 4 }@ ] [ [ 2dup ] infer ] unit-test -[ @{ 2 4 }@ ] [ [ 2dup ] infer simple-effect ] unit-test - -[ @{ 1 0 }@ ] [ [ [ ] [ ] ifte ] infer simple-effect ] unit-test -[ [ ifte ] infer simple-effect ] unit-test-fails -[ [ [ ] ifte ] infer simple-effect ] unit-test-fails -[ [ [ 2 ] [ ] ifte ] infer simple-effect ] unit-test-fails -[ @{ 4 3 }@ ] [ [ [ rot ] [ -rot ] ifte ] infer simple-effect ] unit-test +[ @{ 1 0 }@ ] [ [ [ ] [ ] ifte ] infer ] unit-test +[ [ ifte ] infer ] unit-test-fails +[ [ [ ] ifte ] infer ] unit-test-fails +[ [ [ 2 ] [ ] ifte ] infer ] unit-test-fails +[ @{ 4 3 }@ ] [ [ [ rot ] [ -rot ] ifte ] infer ] unit-test [ @{ 4 3 }@ ] [ [ @@ -41,18 +39,18 @@ namespaces parser sequences test vectors ; ] [ -rot ] ifte - ] infer simple-effect + ] infer ] unit-test -[ @{ 1 1 }@ ] [ [ dup [ ] when ] infer simple-effect ] unit-test -[ @{ 1 1 }@ ] [ [ dup [ dup fixnum* ] when ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ [ dup fixnum* ] when ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ dup [ ] when ] infer ] unit-test +[ @{ 1 1 }@ ] [ [ dup [ dup fixnum* ] when ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ [ dup fixnum* ] when ] infer ] unit-test -[ @{ 1 0 }@ ] [ [ [ drop ] when* ] infer simple-effect ] unit-test -[ @{ 1 1 }@ ] [ [ [ { { [ ] } } ] unless* ] infer simple-effect ] unit-test +[ @{ 1 0 }@ ] [ [ [ drop ] when* ] infer ] unit-test +[ @{ 1 1 }@ ] [ [ [ { { [ ] } } ] unless* ] infer ] unit-test [ @{ 0 1 }@ ] [ - [ [ 2 2 fixnum+ ] dup [ ] when call ] infer simple-effect + [ [ 2 2 fixnum+ ] dup [ ] when call ] infer ] unit-test [ @@ -64,27 +62,27 @@ namespaces parser sequences test vectors ; : simple-recursion-1 dup [ simple-recursion-1 ] [ ] ifte ; -[ @{ 1 1 }@ ] [ [ simple-recursion-1 ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ simple-recursion-1 ] infer ] unit-test : simple-recursion-2 dup [ ] [ simple-recursion-2 ] ifte ; -[ @{ 1 1 }@ ] [ [ simple-recursion-2 ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ simple-recursion-2 ] infer ] unit-test : bad-recursion-2 dup [ uncons bad-recursion-2 ] [ ] ifte ; -[ [ bad-recursion-2 ] infer simple-effect ] unit-test-fails +[ [ bad-recursion-2 ] infer ] unit-test-fails ! Not sure how to fix this one : funny-recursion dup [ funny-recursion 1 ] [ 2 ] ifte drop ; -[ @{ 1 1 }@ ] [ [ funny-recursion ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ funny-recursion ] infer ] unit-test ! Simple combinators -[ @{ 1 2 }@ ] [ [ [ car ] keep cdr ] infer simple-effect ] unit-test +[ @{ 1 2 }@ ] [ [ [ car ] keep cdr ] infer ] unit-test ! Mutual recursion DEFER: foe @@ -107,8 +105,8 @@ DEFER: foe 2drop f ] ifte ; -[ @{ 2 1 }@ ] [ [ fie ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ foe ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ fie ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ foe ] infer ] unit-test : nested-when ( -- ) t [ @@ -117,7 +115,7 @@ DEFER: foe ] when ] when ; -[ @{ 0 0 }@ ] [ [ nested-when ] infer simple-effect ] unit-test +[ @{ 0 0 }@ ] [ [ nested-when ] infer ] unit-test : nested-when* ( -- ) [ @@ -126,11 +124,11 @@ DEFER: foe ] when* ] when* ; -[ @{ 1 0 }@ ] [ [ nested-when* ] infer simple-effect ] unit-test +[ @{ 1 0 }@ ] [ [ nested-when* ] infer ] unit-test SYMBOL: sym-test -[ @{ 0 1 }@ ] [ [ sym-test ] infer simple-effect ] unit-test +[ @{ 0 1 }@ ] [ [ sym-test ] infer ] unit-test : terminator-branch dup [ @@ -139,7 +137,7 @@ SYMBOL: sym-test not-a-number ] ifte ; -[ @{ 1 1 }@ ] [ [ terminator-branch ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ terminator-branch ] infer ] unit-test : recursive-terminator dup [ @@ -148,7 +146,7 @@ SYMBOL: sym-test not-a-number ] ifte ; -[ @{ 1 1 }@ ] [ [ recursive-terminator ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ recursive-terminator ] infer ] unit-test GENERIC: potential-hang M: fixnum potential-hang dup [ potential-hang ] when ; @@ -161,14 +159,14 @@ M: funny-cons iterate funny-cons-cdr iterate ; M: f iterate drop ; M: real iterate drop ; -[ @{ 1 0 }@ ] [ [ iterate ] infer simple-effect ] unit-test +[ @{ 1 0 }@ ] [ [ iterate ] infer ] unit-test -[ [ callstack ] infer simple-effect ] unit-test-fails +[ [ callstack ] infer ] unit-test-fails DEFER: agent : smith 1 + agent ; inline : agent dup 0 = [ [ swap call ] 2keep smith ] when ; inline -[ [ [ ] [ object object ] ] ] +[ @{ 0 2 }@ ] [ [ [ drop ] 0 agent ] infer ] unit-test ! : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] ifte ; @@ -177,62 +175,62 @@ DEFER: agent : no-base-case-2 no-base-case-2 ; [ [ no-base-case-2 ] infer ] unit-test-fails -[ @{ 2 1 }@ ] [ [ swons ] infer simple-effect ] unit-test -[ @{ 1 2 }@ ] [ [ uncons ] infer simple-effect ] unit-test -[ @{ 1 1 }@ ] [ [ unit ] infer simple-effect ] unit-test -[ @{ 1 2 }@ ] [ [ unswons ] infer simple-effect ] unit-test -[ @{ 1 1 }@ ] [ [ last ] infer simple-effect ] unit-test -[ @{ 1 1 }@ ] [ [ list? ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ swons ] infer ] unit-test +[ @{ 1 2 }@ ] [ [ uncons ] infer ] unit-test +[ @{ 1 1 }@ ] [ [ unit ] infer ] unit-test +[ @{ 1 2 }@ ] [ [ unswons ] infer ] unit-test +[ @{ 1 1 }@ ] [ [ last ] infer ] unit-test +[ @{ 1 1 }@ ] [ [ list? ] infer ] unit-test -[ @{ 1 0 }@ ] [ [ >n ] infer simple-effect ] unit-test -[ @{ 0 1 }@ ] [ [ n> ] infer simple-effect ] unit-test +[ @{ 1 0 }@ ] [ [ >n ] infer ] unit-test +[ @{ 0 1 }@ ] [ [ n> ] infer ] unit-test -[ @{ 2 1 }@ ] [ [ bitor ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ bitand ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ bitxor ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ mod ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ /i ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ /f ] infer simple-effect ] unit-test -[ @{ 2 2 }@ ] [ [ /mod ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ + ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ - ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ * ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ / ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ < ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ <= ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ > ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ >= ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ number= ] infer simple-effect ] unit-test +[ @{ 2 1 }@ ] [ [ bitor ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ bitand ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ bitxor ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ mod ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ /i ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ /f ] infer ] unit-test +[ @{ 2 2 }@ ] [ [ /mod ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ + ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ - ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ * ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ / ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ < ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ <= ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ > ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ >= ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ number= ] infer ] unit-test -[ @{ 1 1 }@ ] [ [ string>number ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ = ] infer simple-effect ] unit-test -[ @{ 1 1 }@ ] [ [ get ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ string>number ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ = ] infer ] unit-test +[ @{ 1 1 }@ ] [ [ get ] infer ] unit-test -[ @{ 2 0 }@ ] [ [ push ] infer simple-effect ] unit-test -[ @{ 2 0 }@ ] [ [ set-length ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ append ] infer simple-effect ] unit-test -[ @{ 1 1 }@ ] [ [ peek ] infer simple-effect ] unit-test +[ @{ 2 0 }@ ] [ [ push ] infer ] unit-test +[ @{ 2 0 }@ ] [ [ set-length ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ append ] infer ] unit-test +[ @{ 1 1 }@ ] [ [ peek ] infer ] unit-test -[ @{ 1 1 }@ ] [ [ length ] infer simple-effect ] unit-test -[ @{ 1 1 }@ ] [ [ reverse ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ member? ] infer simple-effect ] unit-test -[ @{ 2 1 }@ ] [ [ remove ] infer simple-effect ] unit-test -[ @{ 1 1 }@ ] [ [ prune ] infer simple-effect ] unit-test +[ @{ 1 1 }@ ] [ [ length ] infer ] unit-test +[ @{ 1 1 }@ ] [ [ reverse ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ member? ] infer ] unit-test +[ @{ 2 1 }@ ] [ [ remove ] infer ] unit-test +[ @{ 1 1 }@ ] [ [ prune ] infer ] unit-test : bad-code "1234" car ; -[ @{ 0 1 }@ ] [ [ bad-code ] infer simple-effect ] unit-test +[ @{ 0 1 }@ ] [ [ bad-code ] infer ] unit-test ! This form should not have a stack effect ! : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ; -! [ [ bad-bin ] infer simple-effect ] unit-test-fails +! [ [ bad-bin ] infer ] unit-test-fails -! [ [ infinite-loop ] infer simple-effect ] unit-test-fails +! [ [ infinite-loop ] infer ] unit-test-fails ! : bad-recursion-1 ! dup [ drop bad-recursion-1 5 ] [ ] ifte ; ! -! [ [ bad-recursion-1 ] infer simple-effect ] unit-test-fails +! [ [ bad-recursion-1 ] infer ] unit-test-fails ! This hangs diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor index e060e04327..e6fb32889d 100644 --- a/library/test/lists/lists.factor +++ b/library/test/lists/lists.factor @@ -17,9 +17,5 @@ USING: kernel lists sequences test ; [ t ] [ [ 1 2 ] list? ] unit-test [ f ] [ [[ 1 2 ]] list? ] unit-test -[ [ 1 2 3 ] ] [ 1 [ 2 3 ] unique ] unit-test -[ [ 1 2 3 ] ] [ 1 [ 1 2 3 ] unique ] unit-test -[ [ 1 2 3 ] ] [ 2 [ 1 2 3 ] unique ] unit-test - [ [ ] ] [ 0 >list ] unit-test [ [ 0 1 2 3 ] ] [ 4 >list ] unit-test diff --git a/library/test/lists/namespaces.factor b/library/test/lists/namespaces.factor index 46d795d78e..a0406d3f19 100644 --- a/library/test/lists/namespaces.factor +++ b/library/test/lists/namespaces.factor @@ -5,7 +5,6 @@ USE: test USE: sequences : cons@ [ cons ] change ; -: unique@ [ unique ] change ; [ [ 1 ] ] [ 1 f "x" set "x" cons@ "x" get ] unit-test [ [[ 1 2 ]] ] [ 1 2 "x" set "x" cons@ "x" get ] unit-test @@ -20,15 +19,3 @@ USE: sequences 2 "x" [ remove ] change "x" get ] unit-test - -[ [ "hello" f ] ] [ - "x" off - f "x" unique@ - "hello" "x" unique@ - f "x" unique@ - 5 "x" unique@ - f "x" unique@ - 5 "x" [ remove ] change - "hello" "x" unique@ - "x" get -] unit-test diff --git a/library/test/redefine.factor b/library/test/redefine.factor index f2dc4c74f6..c1909298e6 100644 --- a/library/test/redefine.factor +++ b/library/test/redefine.factor @@ -6,7 +6,7 @@ IN: temporary : foo 1 2 3 ; [ 1 2 3 1 2 3 ] [ bar ] unit-test -[ [ [ ] [ object object object ] ] ] [ [ foo ] infer ] unit-test +[ @{ 0 3 }@ ] [ [ foo ] infer ] unit-test [ ] [ "IN: temporary : foo ; : bar foo ; : baz foo ; : foo ;" eval diff --git a/library/test/tuple.factor b/library/test/tuple.factor index f220de5303..8fc8e46d9f 100644 --- a/library/test/tuple.factor +++ b/library/test/tuple.factor @@ -1,5 +1,5 @@ -IN: temporary USING: errors generic kernel math parser sequences test words ; +IN: temporary TUPLE: rect x y w h ; C: rect diff --git a/library/threads.factor b/library/threads.factor index ac5b0b2144..cb7e8f2f84 100644 --- a/library/threads.factor +++ b/library/threads.factor @@ -28,19 +28,20 @@ DEFER: next-thread : next-thread ( -- quot ) run-queue dup queue-empty? [ drop do-sleep ] [ deque ] ifte ; -: stop ( -- ) next-thread call ; +: stop ( -- ) next-thread continue ; -: yield ( -- ) [ schedule-thread stop ] callcc0 ; +: yield ( -- ) [ schedule-thread stop ] with-continuation ; : sleep ( ms -- ) - millis + [ cons sleep-queue push stop ] callcc0 drop ; + millis + + [ cons sleep-queue push stop ] with-continuation drop ; : in-thread ( quot -- ) [ schedule-thread [ ] set-catchstack { } set-callstack try stop - ] callcc0 drop ; + ] with-continuation drop ; TUPLE: timer object delay last ; diff --git a/library/tools/annotations.factor b/library/tools/annotations.factor index cd44e2a8f6..4f749ff03e 100644 --- a/library/tools/annotations.factor +++ b/library/tools/annotations.factor @@ -11,13 +11,14 @@ sequences strings test ; over >r >r dup word-def r> call r> swap define-compound ; inline +: watch-msg ( word prefix -- ) write word-name print .s ; + : (watch) ( word def -- def ) [ - "===> Entering: " pick word-name append , - [ print .s ] % - % - "===> Leaving: " swap word-name append , - [ print .s ] % + swap literalize + dup , "===> Entering: " , \ watch-msg , + swap % + , "===> Leaving: " , \ watch-msg , ] [ ] make ; : watch ( word -- ) diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index aa8ee3ec23..a3d70eb475 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -131,8 +131,8 @@ M: object error. ( error -- ) . ; ] bind ; : init-error-handler ( -- ) - [ die ] >c ( last resort ) - [ print-error die ] >c + [ die ] quot>interp >c ( last resort ) + [ print-error die ] quot>interp >c ( kernel calls on error ) [ datastack dupd callstack namestack catchstack diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index 22cdf85e58..f522c8aaaf 100644 --- a/library/tools/inspector.factor +++ b/library/tools/inspector.factor @@ -87,7 +87,6 @@ SYMBOL: inspector-stack "inspecting ( -- obj ) push current object" print "go ( n -- ) inspect nth slot" print "up -- return to previous object" print - "refs -- inspect references to current object" print "bye -- exit inspector" print ; : inspector ( obj -- ) @@ -107,6 +106,4 @@ SYMBOL: inspector-stack : go ( n -- ) inspector-slots get nth (inspect) ; -: up ( -- ) inspector-stack get >pop> pop (inspect) ; - -: refs ( -- ) inspecting references (inspect) ; +: up ( -- ) inspector-stack get dup pop* pop (inspect) ; diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index 70de964113..5fba8f98ff 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -52,10 +52,9 @@ SYMBOL: meta-executing : host-word ( word -- ) [ - \ call push-r interp [ - interp over interp-data push - [ ] set-interp - ] cons cons push-r meta-interp [ ] set-interp + \ call push-r continuation [ + continuation over interp-data push continue + ] cons cons push-r meta-interp continue ] call set-meta-interp pop-d 2drop ; : meta-call ( quot -- ) diff --git a/library/tools/jedit.factor b/library/tools/jedit.factor index c1f6cf38b8..cc835e1b9f 100644 --- a/library/tools/jedit.factor +++ b/library/tools/jedit.factor @@ -7,12 +7,8 @@ prettyprint sequences strings unparser words ; ! Some words to send requests to a running jEdit instance to ! edit files and position the cursor on a specific line number. -: jedit-server-file ( -- path ) - "jedit-server-file" get - [ "~" get "/.jedit/server" append ] unless* ; - : jedit-server-info ( -- port auth ) - jedit-server-file [ + "~" get "/.jedit/server" append [ readln drop readln string>number readln string>number @@ -30,7 +26,7 @@ prettyprint sequences strings unparser words ; jedit-server-info swap "localhost" swap [ 4 >be write dup length 2 >be write - write flush + write ] with-stream ; : jedit-line/file ( file line -- ) @@ -42,11 +38,7 @@ prettyprint sequences strings unparser words ; : jedit ( word -- ) #! Note that line numbers here start from 1 - dup word-file dup [ - swap "line" word-prop jedit-line/file - ] [ - 2drop "Unknown source" print - ] ifte ; + dup word-file swap "line" word-prop jedit-line/file ; ! Wire protocol for jEdit to evaluate Factor code. ! Packets are of the form: diff --git a/library/tools/memory.factor b/library/tools/memory.factor index d5150bac2e..4ed290c80f 100644 --- a/library/tools/memory.factor +++ b/library/tools/memory.factor @@ -39,16 +39,13 @@ sequences strings unparser vectors words ; ! Some words for iterating through the heap. : (each-object) ( quot -- ) - next-object [ swap [ call ] keep (each-object) ] when* ; - inline + next-object dup + [ swap [ call ] keep (each-object) ] [ 2drop ] ifte ; inline : each-object ( quot -- ) - #! Applies the quotation to each object in the image. We - #! use the lower-level >c and c> words here to avoid - #! copying the stacks. - [ end-scan rethrow ] >c - begin-scan (each-object) drop - f c> call ; inline + #! Applies the quotation to each object in the image. + [ begin-scan (each-object) ] + [ end-scan rethrow ] catch ; inline : instances ( quot -- list ) #! Return a list of all object that return true when the @@ -86,19 +83,13 @@ M: object each-slot ( obj quot -- ) num-types zero-array num-types zero-array [ >r 2dup r> heap-stat-step ] each-object ; -: heap-stat. ( type instances bytes -- ) - dup 0 = [ - 3drop - ] [ - rot type>class word-name write ": " write - pprint " bytes, " write - pprint " instances" print - ] ifte ; +: heap-stat. ( { instances bytes type } -- ) + dup first 0 = [ + dup third type>class pprint ": " write + dup second pprint " bytes, " write + dup first pprint " instances" print + ] unless drop ; : heap-stats. ( -- ) #! Print heap allocation breakdown. - 0 heap-stats [ >r >r dup r> r> heap-stat. 1 + ] 2each drop ; - -: orphans ( word -- list ) - #! Orphans are forgotten but still referenced. - [ word? ] instances [ interned? not ] subset ; + heap-stats dup length 3array flip [ heap-stat. ] each ; diff --git a/library/ui/fonts.factor b/library/ui/fonts.factor index 8a73cdeae2..aa1c2cc68b 100644 --- a/library/ui/fonts.factor +++ b/library/ui/fonts.factor @@ -21,7 +21,7 @@ sequences styles ; }} hash ; : ttf-path ( name -- string ) - [ resource-path % "/fonts/" % % ".ttf" % ] "" make ; + [ "/fonts/" % % ".ttf" % ] "" make resource-path ; : open-font ( [ font style ptsize ] -- alien ) first3 >r ttf-name ttf-path r> TTF_OpenFont ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 90744bdb40..c4b485781b 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -15,6 +15,7 @@ TUPLE: hand click-loc click-rel clicked buttons gadget focus ; C: hand ( world -- hand ) over set-delegate + { } clone over set-hand-buttons [ set-gadget-parent ] 2keep [ set-hand-gadget ] keep ; @@ -24,22 +25,22 @@ C: hand ( world -- hand ) dup hand-gadget over set-hand-clicked dup screen-loc over set-hand-click-loc dup hand-gadget over relative over set-hand-click-rel - [ hand-buttons unique ] keep set-hand-buttons ; + hand-buttons adjoin ; : button\ ( n hand -- ) - [ hand-buttons remove ] keep set-hand-buttons ; + hand-buttons delete ; : drag-gesture ( hand gadget gesture -- ) #! Send a gesture like [ drag 2 ]. - rot hand-buttons car add swap handle-gesture drop ; + rot hand-buttons first add swap handle-gesture drop ; : fire-motion ( hand -- ) #! Fire a motion gesture to the gadget underneath the hand, #! and if a mouse button is down, fire a drag gesture to the #! gadget that was clicked. [ motion ] over hand-gadget handle-gesture drop - dup hand-buttons - [ dup hand-clicked [ drag ] drag-gesture ] [ drop ] ifte ; + dup hand-buttons empty? + [ dup dup hand-clicked [ drag ] drag-gesture ] unless drop ; : drop-prefix ( l1 l2 -- l1 l2 ) 2dup and [ 2dup 2car eq? [ 2cdr drop-prefix ] when ] when ; diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index 5b77bf4c1c..029fd41dde 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -5,13 +5,14 @@ USING: gadgets-layouts generic hashtables kernel lists math namespaces sequences vectors ; : remove-gadget ( gadget parent -- ) - 2dup gadget-children remove over set-gadget-children - relayout f swap set-gadget-parent ; + f pick set-gadget-parent + [ gadget-children delete ] keep + relayout ; : unparent ( gadget -- ) [ dup gadget-parent dup - [ remove-gadget ] [ 2drop ] ifte + [ 2dup remove-gadget ] when 2drop ] when* ; : (clear-gadget) ( gadget -- ) diff --git a/library/ui/panes.factor b/library/ui/panes.factor index 7d909009fb..edf8312e1a 100644 --- a/library/ui/panes.factor +++ b/library/ui/panes.factor @@ -32,7 +32,7 @@ TUPLE: pane output active current input continuation ; dup pane-continuation f rot set-pane-continuation ; : pane-eval ( string pane -- ) - pop-continuation in-thread drop ; + pop-continuation [ continue-with ] in-thread 2drop ; SYMBOL: structured-input @@ -112,7 +112,7 @@ M: pane stream-flush ( pane -- ) drop ; M: pane stream-finish ( pane -- ) drop ; M: pane stream-readln ( pane -- line ) - [ over set-pane-continuation stop ] callcc1 nip ; + [ over set-pane-continuation stop ] with-continuation nip ; M: pane stream-write1 ( char pane -- ) [ >r ch>string