From 2df3a9e6e9f84ff0d3949d12f1a3d35482690aab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Nov 2004 04:14:12 +0000 Subject: [PATCH] some dataflow IR unit tests and fixes --- TODO.FACTOR.txt | 9 +++++ factor/jedit/FactorPlugin.props | 2 +- library/bootstrap/cross-compiler.factor | 3 +- library/bootstrap/init-stage2.factor | 4 +- library/httpd/file-responder.factor | 2 +- library/httpd/html.factor | 4 +- library/httpd/httpd.factor | 4 +- library/httpd/resource-responder.factor | 2 +- library/inference/branches.factor | 43 ++++++++++---------- library/io/logging.factor | 3 +- library/io/stdio.factor | 22 +++++----- library/io/stream-impl.factor | 5 ++- library/list-namespaces.factor | 12 ++++-- library/lists.factor | 26 ++++++------ library/test/dataflow.factor | 53 +++++++++++++++++++++---- library/test/lists/combinators.factor | 5 +++ library/test/lists/lists.factor | 4 +- library/test/stream.factor | 2 +- library/tools/jedit-wire.factor | 4 +- version.factor | 2 +- 20 files changed, 141 insertions(+), 70 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 6134b7bd91..876f010894 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,3 +1,11 @@ +[error] AWT-EventQueue-0: java.lang.NullPointerException +[error] AWT-EventQueue-0: at org.gjt.sp.jedit.Buffer.markTokens(Buffer.java:2109) +[error] AWT-EventQueue-0: at factor.jedit.WordPreview.getWordAtCaret(WordPreview.java:95) +[error] AWT-EventQueue-0: at factor.jedit.WordPreview.showPreview(WordPreview.java:137) +[error] AWT-EventQueue-0: at factor.jedit.WordPreview.actionPerformed(WordPreview.java:79) +[error] AWT-EventQueue-0: at javax.swing.Timer.fireActionPerformed(Timer.java:271) + + + inference/interpreter: - combinator inference @@ -25,6 +33,7 @@ + listener/plugin: +- errors don't always disappear - console: wrong history - listener: if too many things popped off the stack, complain - gracefully handle non-working cfactor diff --git a/factor/jedit/FactorPlugin.props b/factor/jedit/FactorPlugin.props index c3481f4805..75573f8091 100644 --- a/factor/jedit/FactorPlugin.props +++ b/factor/jedit/FactorPlugin.props @@ -2,7 +2,7 @@ plugin.factor.jedit.FactorPlugin.activate=startup plugin.factor.jedit.FactorPlugin.name=Factor -plugin.factor.jedit.FactorPlugin.version=0.69 +plugin.factor.jedit.FactorPlugin.version=0.70 plugin.factor.jedit.FactorPlugin.author=Slava Pestov plugin.factor.jedit.FactorPlugin.docs=/doc/jedit/index.html diff --git a/library/bootstrap/cross-compiler.factor b/library/bootstrap/cross-compiler.factor index ffc5f0d575..f239cb0c3f 100644 --- a/library/bootstrap/cross-compiler.factor +++ b/library/bootstrap/cross-compiler.factor @@ -400,7 +400,8 @@ IN: image "big-endian" on "boot.image.be32" make-image "64-bits" on "big-endian" off "boot.image.le64" make-image - "big-endian" on "boot.image.be64" make-image ; + "big-endian" on "boot.image.be64" make-image + "64-bits" off ; : cross-compile-resource ( resource -- ) [ diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor index 0668d6ec95..a836415d64 100644 --- a/library/bootstrap/init-stage2.factor +++ b/library/bootstrap/init-stage2.factor @@ -66,7 +66,7 @@ USE: unparser ! The first CLI arg is the image name. cli-args uncons parse-command-line "image" set - "ansi" get [ "stdio" get "stdio" set ] when + "ansi" get [ stdio get stdio set ] when "compile" get [ compile-all ] when @@ -91,7 +91,7 @@ unparse write " words have a stack effect" print "Now, you can run ./f factor.image" print ! Save a bit of space -global [ "stdio" off ] bind +global [ stdio off ] bind garbage-collection "factor.image" save-image diff --git a/library/httpd/file-responder.factor b/library/httpd/file-responder.factor index 640e2d8f0b..b16ae51086 100644 --- a/library/httpd/file-responder.factor +++ b/library/httpd/file-responder.factor @@ -56,7 +56,7 @@ USE: unparser over file-length file-response "method" get "head" = [ drop ] [ - "stdio" get fcopy + stdio get fcopy ] ifte ; : serve-file ( filename -- ) diff --git a/library/httpd/html.factor b/library/httpd/html.factor index 639d611753..f02e61b113 100644 --- a/library/httpd/html.factor +++ b/library/httpd/html.factor @@ -162,10 +162,10 @@ C: html-stream ( stream -- stream ) #! underline #! size #! link - an object path - [ dup delegate set "stdio" set ] extend ; + [ dup delegate set stdio set ] extend ; : with-html-stream ( quot -- ) - [ "stdio" get "stdio" set call ] with-scope ; + [ stdio get stdio set call ] with-scope ; : html-document ( title quot -- ) swap chars>entities dup diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor index ccfa2e3ffe..162bc4da50 100644 --- a/library/httpd/httpd.factor +++ b/library/httpd/httpd.factor @@ -46,7 +46,7 @@ USE: url-encoding "httpd-log-file" get dup [ ] [ - drop "stdio" get + drop stdio get ] ifte ; : url>path ( uri -- path ) @@ -86,7 +86,7 @@ USE: url-encoding : httpd-client ( socket -- ) [ [ - "stdio" get "client" set log-client + stdio get "client" set log-client read [ parse-request ] when* ] with-stream ] print-error ; diff --git a/library/httpd/resource-responder.factor b/library/httpd/resource-responder.factor index a226ec1046..eec95622d8 100644 --- a/library/httpd/resource-responder.factor +++ b/library/httpd/resource-responder.factor @@ -47,7 +47,7 @@ USE: strings dup mime-type resource-response "method" get "head" = [ drop ] [ - "stdio" get fcopy + stdio get fcopy ] ifte ; : resource-responder ( filename -- ) diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 41fbf1305a..f81bf36976 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -41,15 +41,17 @@ USE: vectors USE: words USE: hashtables -: infer-branch ( quot -- [ in-d | datastack ] dataflow ) +: branch-effect ( -- [ dataflow [ in-d | datastack ] ] ) + get-dataflow d-in get meta-d get cons cons ; + +: infer-branch ( quot -- [ dataflow [ in-d | datastack ] ] ) #! Infer the quotation's effect, restoring the meta #! interpreter state afterwards. [ copy-interpreter dataflow-graph off (infer) - d-in get meta-d get cons - get-dataflow + branch-effect ] with-scope ; : difference ( [ in | stack ] -- diff ) @@ -89,31 +91,35 @@ USE: hashtables "Unbalanced branches" throw ] ifte ; -: recursive-branch ( quot -- ? ) +: recursive-branch ( quot -- ) #! Set base case if inference didn't fail. [ - car infer-branch drop recursive-state get set-base t + infer-branch cdr recursive-state get set-base ] [ - [ drop f ] when + [ drop ] when ] catch ; -: infer-branches ( branchlist instruction -- ) +: (infer-branches) ( branchlist -- dataflowlist effectlist ) + dup + [ car recursive-branch ] each + [ car infer-branch ] map + unzip ; + +: infer-branches ( inputs instruction branchlist -- ) #! Recursive stack effect inference is done here. If one of #! the branches has an undecidable stack effect, we set the - #! base case to this stack effect and try again. - swap f over [ recursive-branch or ] each [ - [ [ car infer-branch , ] map ] make-list swap - >r dataflow, drop r> unify - ] [ - current-word no-base-case - ] ifte ; + #! base case to this stack effect and try again. The inputs + #! parameter is a vector. + (infer-branches) >r + swap dataflow, [ node-consume-d set ] bind + r> unify ; : infer-ifte ( -- ) #! Infer effects for both branches, unify. 3 ensure-d dataflow-drop, pop-d dataflow-drop, pop-d 2list - IFTE + >r 1 meta-d get vector-tail* IFTE r> pop-d drop ( condition ) infer-branches ; @@ -129,17 +135,14 @@ USE: hashtables #! Infer effects for all branches, unify. 2 ensure-d dataflow-drop, pop-d vtable>list - GENERIC - peek-d drop ( dispatch ) + >r 1 meta-d get vector-tail* GENERIC r> infer-branches ; : infer-2generic ( -- ) #! Infer effects for all branches, unify. 3 ensure-d dataflow-drop, pop-d vtable>list - 2GENERIC - peek-d drop ( dispatch ) - peek-d drop ( dispatch ) + >r 2 meta-d get vector-tail* 2GENERIC r> infer-branches ; \ ifte [ infer-ifte ] "infer" set-word-property diff --git a/library/io/logging.factor b/library/io/logging.factor index b6a295c38d..b8f57a1b46 100644 --- a/library/io/logging.factor +++ b/library/io/logging.factor @@ -31,6 +31,7 @@ USE: combinators USE: hashtables USE: namespaces USE: stack +USE: stdio USE: streams USE: strings USE: unparser @@ -48,7 +49,7 @@ USE: unparser ] when* ; : with-logging ( quot -- ) - [ "stdio" get "log" set call ] with-scope ; + [ stdio get "log" set call ] with-scope ; : with-log-file ( file quot -- ) [ swap "log" set call ] with-scope ; diff --git a/library/io/stdio.factor b/library/io/stdio.factor index f0ada997d0..d5cc6e4269 100644 --- a/library/io/stdio.factor +++ b/library/io/stdio.factor @@ -36,28 +36,30 @@ USE: streams USE: generic USE: strings -: flush ( -- ) "stdio" get fflush ; -: read ( -- string ) "stdio" get freadln ; -: read1 ( count -- string ) "stdio" get fread1 ; -: read# ( count -- string ) "stdio" get fread# ; -: write ( string -- ) "stdio" get fwrite ; -: write-attr ( string style -- ) "stdio" get fwrite-attr ; -: print ( string -- ) "stdio" get fprint ; +SYMBOL: stdio + +: flush ( -- ) stdio get fflush ; +: read ( -- string ) stdio get freadln ; +: read1 ( count -- string ) stdio get fread1 ; +: read# ( count -- string ) stdio get fread# ; +: write ( string -- ) stdio get fwrite ; +: write-attr ( string style -- ) stdio get fwrite-attr ; +: print ( string -- ) stdio get fprint ; : terpri ( -- ) "\n" write ; -: close ( -- ) "stdio" get fclose ; +: close ( -- ) stdio get fclose ; : write-icon ( resource -- ) #! Write an icon. Eg, /library/icons/File.png "icon" swons unit "" swap write-attr ; : with-stream ( stream quot -- ) - [ swap "stdio" set [ close rethrow ] catch ] with-scope ; + [ swap stdio set [ close rethrow ] catch ] with-scope ; : with-string ( quot -- str ) #! Execute a quotation, and push a string containing all #! text printed by the quotation. 1024 [ - call "stdio" get stream>str + call stdio get stream>str ] with-stream ; TRAITS: stdio-stream diff --git a/library/io/stream-impl.factor b/library/io/stream-impl.factor index 4cbbacf7f6..9dbe3bb204 100644 --- a/library/io/stream-impl.factor +++ b/library/io/stream-impl.factor @@ -25,6 +25,9 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +IN: stdio +DEFER: stdio + IN: streams USE: combinators USE: continuations @@ -78,7 +81,7 @@ C: fd-stream ( in out -- stream ) ; : init-stdio ( -- ) - stdin stdout "stdio" set ; + stdin stdout stdio set ; : (fcopy) ( from to -- ) #! Copy the contents of the fd-stream 'from' to the diff --git a/library/list-namespaces.factor b/library/list-namespaces.factor index ea56baa038..64334eec1f 100644 --- a/library/list-namespaces.factor +++ b/library/list-namespaces.factor @@ -30,6 +30,7 @@ USE: combinators USE: kernel USE: namespaces USE: stack +USE: math : cons@ ( x var -- ) #! Prepend x to the list stored in var. @@ -54,11 +55,13 @@ USE: stack #! variable if it is not already contained in the list. tuck get unique put ; +SYMBOL: list-buffer + : make-rlist ( quot -- list ) #! Call a quotation. The quotation can call , to prepend #! objects to the list that is returned when the quotation #! is done. - [ "list-buffer" off call "list-buffer" get ] with-scope ; + [ list-buffer off call list-buffer get ] with-scope ; inline : make-list ( quot -- list ) @@ -68,9 +71,12 @@ USE: stack : , ( obj -- ) #! Append an object to the currently constructing list. - "list-buffer" cons@ ; + list-buffer cons@ ; : unique, ( obj -- ) #! Append an object to the currently constructing list, only #! if the object does not already occur in the list. - "list-buffer" unique@ ; + list-buffer unique@ ; + +: count ( n -- [ 0 ... n-1 ] ) + [ [ , ] times* ] make-list ; diff --git a/library/lists.factor b/library/lists.factor index 59afb3af41..62726c1159 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -42,14 +42,22 @@ USE: vectors : append ( [ list1 ] [ list2 ] -- [ list1 list2 ] ) over [ >r uncons r> append cons ] [ nip ] ifte ; -: contains? ( element list -- remainder ) - #! Push remainder of list from first occurrence of element, - #! or f. - dup [ - 2dup car = [ nip ] [ cdr contains? ] ifte +: some? ( list pred -- ? ) + #! Apply predicate to each element ,return remainder of list + #! from first occurrence where it is true, or return f. + over [ + dup >r over >r >r car r> call [ + r> r> drop + ] [ + r> cdr r> some? + ] ifte ] [ 2drop f - ] ifte ; + ] ifte ; inline + +: contains? ( element list -- ? ) + #! Test if a list contains an element. + [ over = ] some? nip ; : nth ( n list -- list[n] ) #! nth element of a proper list. @@ -208,12 +216,6 @@ DEFER: tree-contains? #! partial order with stack effect ( o1 o2 -- ? ). swap [ pick >r maximize r> swap ] (top) nip ; -: (count) ( n list -- list ) - >r pred dup 0 < [ drop r> ] [ dup r> cons (count) ] ifte ; - -: count ( n -- [ 0 ... n-1 ] ) - [ ] (count) ; - : cons= ( obj cons -- ? ) 2dup eq? [ 2drop t diff --git a/library/test/dataflow.factor b/library/test/dataflow.factor index 83a96c1c07..8dfb13eb30 100644 --- a/library/test/dataflow.factor +++ b/library/test/dataflow.factor @@ -5,11 +5,50 @@ USE: math USE: test USE: logic USE: combinators +USE: hashtables +USE: stack +USE: dataflow +USE: kernel +USE: vectors +USE: namespaces -! [ t ] [ \ + [ 2 2 + ] dataflow tree-contains? >boolean ] unit-test -! [ t ] [ 3 [ [ sq ] [ 3 + ] ifte ] dataflow tree-contains? >boolean ] unit-test -! -! : inline-test -! car car ; inline -! -! [ t ] [ \ car [ inline-test ] dataflow tree-contains? >boolean ] unit-test +: dataflow-contains-op? ( object list -- ? ) + #! Check if some dataflow node contains a given operation. + [ dupd node-op swap hash = ] some? nip ; + +: dataflow-contains-param? ( object list -- ? ) + #! Check if some dataflow node contains a given operation. + [ dupd node-param swap hash = ] some? nip ; + +[ t ] [ + \ + [ 2 2 + ] dataflow dataflow-contains-param? >boolean +] unit-test + +: inline-test + car car ; inline + +[ t ] [ + \ car [ inline-test ] dataflow dataflow-contains-param? >boolean +] unit-test + +[ t ] [ + IFTE [ [ drop ] [ + ] ifte ] dataflow dataflow-contains-op? >boolean +] unit-test + +: dataflow-consume-d-len ( object -- n ) + [ node-consume-d get vector-length ] bind ; + +: dataflow-produce-d-len ( object -- n ) + [ node-produce-d get vector-length ] bind ; + +[ t ] [ [ drop ] dataflow car dataflow-consume-d-len 1 = ] unit-test + +[ t ] [ [ 2 ] dataflow car dataflow-produce-d-len 1 = ] unit-test + +: dataflow-ifte-node-consume-d ( list -- node ) + IFTE swap dataflow-contains-op? car [ node-consume-d get ] bind ; + +[ t ] [ + [ 2 [ swap ] [ nip "hi" ] ifte ] dataflow + dataflow-ifte-node-consume-d vector-length 1 = +] unit-test diff --git a/library/test/lists/combinators.factor b/library/test/lists/combinators.factor index d2545f446f..a4f78f3a3e 100644 --- a/library/test/lists/combinators.factor +++ b/library/test/lists/combinators.factor @@ -35,3 +35,8 @@ USE: strings [ 6 ] [ [ 5 6 ] [ > ] top ] unit-test [ 99 ] [ 100 count [ > ] top ] unit-test [ 0 ] [ 100 count [ < ] top ] unit-test + +[ f ] [ [ ] [ ] some? ] unit-test +[ t ] [ [ 1 ] [ ] some? >boolean ] unit-test +[ t ] [ [ 1 2 3 ] [ 2 > ] some? >boolean ] unit-test +[ f ] [ [ 1 2 3 ] [ 10 > ] some? ] unit-test diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor index bdfd89b393..49e951bf7e 100644 --- a/library/test/lists/lists.factor +++ b/library/test/lists/lists.factor @@ -16,8 +16,8 @@ USE: strings [ f ] [ 3 [ ] contains? ] unit-test [ f ] [ 3 [ 1 2 ] contains? ] unit-test -[ [ 1 2 ] ] [ 1 [ 1 2 ] contains? ] unit-test -[ [ 2 ] ] [ 2 [ 1 2 ] contains? ] unit-test +[ t ] [ 1 [ 1 2 ] contains? >boolean ] unit-test +[ t ] [ 2 [ 1 2 ] contains? >boolean ] unit-test [ 1 ] [ -1 [ 1 2 ] nth ] unit-test [ 1 ] [ 0 [ 1 2 ] nth ] unit-test diff --git a/library/test/stream.factor b/library/test/stream.factor index ed6aae76d2..b3d8296976 100644 --- a/library/test/stream.factor +++ b/library/test/stream.factor @@ -33,7 +33,7 @@ C: xyzzy-stream ( stream -- stream ) "" ] [ [ - "stdio" get [ + stdio get [ "xyzzy" write ] with-stream ] with-string diff --git a/library/tools/jedit-wire.factor b/library/tools/jedit-wire.factor index d8904b8205..e7d183621f 100644 --- a/library/tools/jedit-wire.factor +++ b/library/tools/jedit-wire.factor @@ -90,11 +90,11 @@ M: jedit-stream fflush ( stream -- ) [ CHAR: f write flush ] bind ;M C: jedit-stream ( stream -- stream ) - [ dup delegate set "stdio" set ] extend ;C + [ dup delegate set stdio set ] extend ;C : stream-server ( -- ) #! Execute this in the inferior Factor. - "stdio" get "stdio" set + stdio get stdio set print-banner ; : jedit-lookup ( word vocabs -- ) diff --git a/version.factor b/version.factor index 0ab99671e6..8fb49d4201 100644 --- a/version.factor +++ b/version.factor @@ -1,2 +1,2 @@ IN: kernel -: version "0.69" ; +: version "0.70" ;