some dataflow IR unit tests and fixes

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

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
 

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 -- )
     [

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 <ansi-stream> "stdio" set ] when
+    "ansi" get [ stdio get <ansi-stream> 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

library/httpd/file-responder.factor

@@ -56,7 +56,7 @@ USE: unparser
     over file-length file-response  "method" get "head" = [
         drop
     ] [
-        <filebr> "stdio" get fcopy
+        <filebr> stdio get fcopy
     ] ifte ;
 
 : serve-file ( filename -- )

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 <html-stream> "stdio" set call ] with-scope ;
+    [ stdio get <html-stream> stdio set call ] with-scope ;
 
 : html-document ( title quot -- )
     swap chars>entities dup

library/httpd/httpd.factor

@@ -46,7 +46,7 @@ USE: url-encoding
     "httpd-log-file" get dup [
         <filecr>
     ] [
-        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 ;

library/httpd/resource-responder.factor

@@ -47,7 +47,7 @@ USE: strings
     dup mime-type resource-response  "method" get "head" = [
         drop
     ] [
-        <resource-stream> "stdio" get fcopy
+        <resource-stream> stdio get fcopy
     ] ifte ;
 
 : resource-responder ( filename -- )

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
+        branch-effect
-        get-dataflow
     ] 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.
+    #! base case to this stack effect and try again. The inputs
-    swap f over [ recursive-branch or ] each [
+    #! parameter is a vector.
-        [ [ car infer-branch , ] map ] make-list swap
+    (infer-branches) >r
-        >r dataflow, drop r> unify
+    swap dataflow, [ node-consume-d set ] bind
-    ] [
+    r> unify ;
-        current-word no-base-case
-    ] ifte ;
 
 : 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
+    >r 1 meta-d get vector-tail* GENERIC r>
-    peek-d drop ( dispatch )
     infer-branches ;
 
 : infer-2generic ( -- )
     #! Infer effects for all branches, unify.
     3 ensure-d
     dataflow-drop, pop-d vtable>list
-    2GENERIC
+    >r 2 meta-d get vector-tail* 2GENERIC r>
-    peek-d drop ( dispatch )
-    peek-d drop ( dispatch )
     infer-branches ;
 
 \ ifte [ infer-ifte ] "infer" set-word-property

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 <filecr> "log" set call ] with-scope ;

library/io/stdio.factor

@@ -36,28 +36,30 @@ USE: streams
 USE: generic
 USE: strings
 
-: flush      ( -- )              "stdio" get fflush ;
+SYMBOL: stdio
-: read       ( -- string )       "stdio" get freadln ;
+
-: read1      ( count -- string ) "stdio" get fread1 ;
+: flush      ( -- )              stdio get fflush ;
-: read#      ( count -- string ) "stdio" get fread# ;
+: read       ( -- string )       stdio get freadln ;
-: write      ( string -- )       "stdio" get fwrite ;
+: read1      ( count -- string ) stdio get fread1 ;
-: write-attr ( string style -- ) "stdio" get fwrite-attr ;
+: read#      ( count -- string ) stdio get fread# ;
-: print      ( string -- )       "stdio" get fprint ;
+: 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 <string-output-stream> [
-        call "stdio" get stream>str
+        call stdio get stream>str
     ] with-stream ;
 
 TRAITS: stdio-stream

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 )
     <filecw> ;
 
 : init-stdio ( -- )
-    stdin stdout <fd-stream> <stdio-stream> "stdio" set ;
+    stdin stdout <fd-stream> <stdio-stream> stdio set ;
 
 : (fcopy) ( from to -- )
     #! Copy the contents of the fd-stream 'from' to the

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 ;

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 )
+: some? ( list pred -- ? )
-    #! Push remainder of list from first occurrence of element,
+    #! Apply predicate to each element ,return remainder of list
-    #! or f.
+    #! from first occurrence where it is true, or return f.
-    dup [
+    over [
-        2dup car = [ nip ] [ cdr contains? ] ifte
+        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

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
+: dataflow-contains-op? ( object list -- ? )
-! [ t ] [ 3 [ [ sq ] [ 3 + ] ifte ] dataflow tree-contains? >boolean ] unit-test
+    #! Check if some dataflow node contains a given operation.
-! 
+    [ dupd node-op swap hash = ] some? nip ;
-! : inline-test
+
-!     car car ; inline
+: dataflow-contains-param? ( object list -- ? )
-! 
+    #! Check if some dataflow node contains a given operation.
-! [ t ] [ \ car [ inline-test ] dataflow tree-contains? >boolean ] unit-test
+    [ 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

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

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
+[ t ] [ 1 [ 1 2 ] contains? >boolean ] unit-test
-[ [ 2 ]     ] [ 2 [ 1 2 ] contains? ] unit-test
+[ t ] [ 2 [ 1 2 ] contains? >boolean ] unit-test
 
 [ 1 ] [  -1 [ 1 2 ] nth ] unit-test
 [ 1 ] [  0  [ 1 2 ] nth ] unit-test

library/test/stream.factor

@@ -33,7 +33,7 @@ C: xyzzy-stream ( stream -- stream )
     "<xyzzy>"
 ] [
     [
-        "stdio" get <xyzzy-stream> [
+        stdio get <xyzzy-stream> [
             "xyzzy" write
         ] with-stream
     ] with-string

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 <jedit-stream> "stdio" set
+    stdio get <jedit-stream> stdio set
     print-banner ;
 
 : jedit-lookup ( word vocabs -- )

version.factor

@@ -1,2 +1,2 @@
 IN: kernel
-: version "0.69" ;
+: version "0.70" ;