various inference fixes; cond compiles now

TODO.FACTOR.txt

@@ -1,6 +1,7 @@
 - reader syntax for arrays, byte arrays, displaced aliens
 - out of memory error when printing global namespace
 - removing unneeded #label
+- pprint trailing space regression
 
 + ui:
 

library/collections/sequences-epilogue.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: sequences
-USING: generic kernel kernel-internals lists math strings
+USING: errors generic kernel kernel-internals lists math strings
 vectors words ;
 
 ! Combinators
@@ -234,12 +234,14 @@ IN: kernel
     #! Push the number of elements on the datastack.
     datastack length ;
 
+: no-cond "cond fall-through" throw ; inline
+
 : cond ( conditions -- )
     #! Conditions is a sequence of quotation pairs.
     #! { { [ X ] [ Y ] } { [ Z ] [ T ] } }
     #! => X [ Y ] [ Z [ T ] [ ] ifte ] ifte
     #! The last condition should be a catch-all 't'.
-    [ first call ] find nip second call ;
+    [ first call ] find nip [ second call ] [ no-cond ] ifte ;
 
 : with-datastack ( stack word -- stack )
     datastack >r >r set-datastack r> execute

library/errors.factor

@@ -9,7 +9,7 @@ IN: errors
 
 TUPLE: no-method object generic ;
 
-: no-method ( object generic -- ) <no-method> throw ;
+: no-method ( object generic -- ) <no-method> throw ; inline
 
 : catchstack ( -- cs ) 6 getenv ;
 : set-catchstack ( cs -- ) 6 setenv ;

library/generic/math-combination.factor

@@ -31,7 +31,7 @@ math namespaces sequences words ;
 TUPLE: no-math-method left right generic ;
 
 : no-math-method ( left right generic -- )
-    3dup <no-math-method> throw ;
+    3dup <no-math-method> throw ; inline
 
 : applicable-method ( generic class -- quot )
     over "methods" word-prop hash [ ] [

library/inference/branches.factor

@@ -74,10 +74,14 @@ namespaces parser prettyprint sequences strings vectors words ;
     #! meta-d, meta-r, d-in. They are set to f if
     #! terminate was called.
     [
+        [
+            base-case-continuation set
             copy-inference
             dup value-recursion recursive-state set
-        literal-value dup infer-quot handle-terminator
+            dup literal-value infer-quot
             active? [ #values node, ] when
+            f
+        ] callcc1 [ terminate ] when drop
     ] make-hash ;
 
 : (infer-branches) ( branchlist -- list )

library/inference/inference.factor

@@ -7,11 +7,15 @@ namespaces parser prettyprint sequences strings vectors words ;
 ! This variable takes a boolean value.
 SYMBOL: inferring-base-case
 
+! Called when a recursive call during base case inference is
+! found. Either tries to infer another branch, or gives up.
+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
-    <inference-error> throw ;
+    <inference-error> throw ; inline
 
 M: inference-error error. ( error -- )
     "! Inference error:" print
@@ -22,10 +26,9 @@ M: inference-error error. ( error -- )
 M: value literal-value ( value -- )
     {
         "A literal value was expected where a computed value was found.\n"
-        "This means that an attempt was made to compile a word that\n"
-        "applies 'call' or 'execute' to a value that is not known\n"
-        "at compile time. The value might become known if the word\n"
-        "is marked 'inline'. See the handbook for details."
+        "This means the word you are inferring applies 'call' or 'execute'\n"
+        "to a value that is not known at compile time.\n"
+        "See the handbook for details."
     } concat inference-error ;
 
 ! Word properties that affect inference:
@@ -63,6 +66,13 @@ SYMBOL: d-in
     d-in get length object <repeated> >list
     meta-d get length object <repeated> >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 ;
+
 : init-inference ( recursive-state -- )
     init-interpreter
     { } clone d-in set
@@ -89,25 +99,14 @@ M: wrapper apply-object wrapped apply-literal ;
     #! Ignore this branch's stack effect.
     meta-d off meta-r off d-in off ;
 
-: terminator? ( obj -- ? )
-    #! Does it throw an error?
-    dup word? [ "terminator" word-prop ] [ drop f ] ifte ;
-
-: handle-terminator ( quot -- )
-    #! If the quotation throws an error, do not count its stack
-    #! effect.
-    [ terminator? ] contains? [ terminate ] when ;
-
 : infer-quot ( quot -- )
     #! Recursive calls to this word are made for nested
     #! quotations.
     [ active? [ apply-object t ] [ drop f ] ifte ] all? drop ;
 
 : infer-quot-value ( rstate quot -- )
-    recursive-state get >r
-    swap recursive-state set
-    dup infer-quot handle-terminator
-    r> recursive-state set ;
+    recursive-state get >r swap recursive-state set
+    infer-quot r> recursive-state set ;
 
 : check-return ( -- )
     #! Raise an error if word leaves values on return stack.
@@ -120,6 +119,7 @@ M: wrapper apply-object wrapped apply-literal ;
 : with-infer ( quot -- )
     [
         inferring-base-case off
+        [ no-base-case ] base-case-continuation set
         f init-inference
         call
         check-return

library/inference/known-words.factor

@@ -4,25 +4,42 @@ io-internals kernel kernel-internals lists math math-internals
 memory parser sequences strings vectors words prettyprint ;
 
 ! Primitive combinators
+\ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop
+
 \ call [
     pop-literal infer-quot-value
 ] "infer" set-word-prop
 
+\ execute [ [ word ] [ ] ] "infer-effect" set-word-prop
+
 \ execute [
     pop-literal unit infer-quot-value
 ] "infer" set-word-prop
 
+\ ifte [ [ object general-list general-list ] [ ] ] "infer-effect" set-word-prop
+
 \ ifte [
     2 #drop node, pop-d pop-d swap 2vector
     #ifte pop-d drop infer-branches
 ] "infer" set-word-prop
 
+\ cond [ [ object ] [ ] ] "infer-effect" set-word-prop
+
+\ cond [
+    pop-literal [ 2unseq cons ] map
+    [ no-cond ] swap alist>quot infer-quot-value
+] "infer" set-word-prop
+
+\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop
+
 \ dispatch [
     pop-literal nip [ <literal> ] map
     #dispatch pop-d drop infer-branches
 ] "infer" set-word-prop
 
 ! Stack manipulation
+\ >r [ [ object ] [ ] ] "infer-effect" set-word-prop
+
 \ >r [
     \ >r #call
     1 0 pick node-inputs
@@ -31,6 +48,8 @@ memory parser sequences strings vectors words prettyprint ;
     node,
 ] "infer" set-word-prop
 
+\ r> [ [ ] [ object ] ] "infer-effect" set-word-prop
+
 \ r> [
     \ r> #call
     0 1 pick node-inputs
@@ -40,57 +59,25 @@ memory parser sequences strings vectors words prettyprint ;
 ] "infer" set-word-prop
 
 \ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop
-\ dup  [ \ dup  infer-shuffle ] "infer" set-word-prop
-\ swap [ \ swap infer-shuffle ] "infer" set-word-prop
-\ over [ \ over infer-shuffle ] "infer" set-word-prop
-\ pick [ \ pick infer-shuffle ] "infer" set-word-prop
+\ drop [ [ object ] [ ] ] "infer-effect" set-word-prop
 
-! These hacks will go away soon
-\ delegate [ [ object ] [ object ] ] "infer-effect" set-word-prop
-\ no-method t "terminator" set-word-prop
-\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop
-\ <no-method> [ [ object object ] [ tuple ] ] "infer-effect" set-word-prop
-\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
-\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop
-\ no-math-method t "terminator" set-word-prop
-\ not-a-number t "terminator" set-word-prop
-\ inference-error t "terminator" set-word-prop
-\ throw t "terminator" set-word-prop
-\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
-\ hash-contained? [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
-\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
-\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
-\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
-\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
-\ number= [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
-\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop
-\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
-\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
-\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop
-\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
-\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop
+\ dup  [ \ dup  infer-shuffle ] "infer" set-word-prop
+\ dup [ [ object ] [ object object ] ] "infer-effect" set-word-prop
+
+\ swap [ \ swap infer-shuffle ] "infer" set-word-prop
+\ swap [ [ object object ] [ object object ] ] "infer-effect" set-word-prop
+
+\ over [ \ over infer-shuffle ] "infer" set-word-prop
+\ over [ [ object object ] [ object object object ] ] "infer-effect" set-word-prop
+
+\ pick [ \ pick infer-shuffle ] "infer" set-word-prop
+\ pick [ [ object object object ] [ object object object object ] ] "infer-effect" set-word-prop
+
+! Non-standard control flow
+\ throw [ [ object ] [ ] ] "infer-effect" set-word-prop
+\ throw [ terminate ] "infer" set-word-prop
 
 ! Stack effects for all primitives
-\ execute [ [ word ] [ ] ] "infer-effect" set-word-prop
-
-\ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop
-
-\ ifte [ [ object general-list general-list ] [ ] ] "infer-effect" set-word-prop
-
-\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop
-
 \ cons [ [ object object ] [ cons ] ] "infer-effect" set-word-prop
 \ cons t "foldable" set-word-prop
 \ cons t "flushable" set-word-prop
@@ -371,13 +358,6 @@ memory parser sequences strings vectors words prettyprint ;
 
 \ update-xt [ [ word ] [ ] ] "infer-effect" set-word-prop
 \ compiled? [ [ word ] [ boolean ] ] "infer-effect" set-word-prop
-\ drop [ [ object ] [ ] ] "infer-effect" set-word-prop
-\ dup [ [ object ] [ object object ] ] "infer-effect" set-word-prop
-\ swap [ [ object object ] [ object object ] ] "infer-effect" set-word-prop
-\ over [ [ object object ] [ object object object ] ] "infer-effect" set-word-prop
-\ pick [ [ object object object ] [ object object object object ] ] "infer-effect" set-word-prop
-\ >r [ [ object ] [ ] ] "infer-effect" set-word-prop
-\ r> [ [ ] [ object ] ] "infer-effect" set-word-prop
 
 \ eq? [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
 \ eq? t "flushable" set-word-prop
@@ -395,6 +375,7 @@ memory parser sequences strings vectors words prettyprint ;
 \ os-env [ [ string ] [ object ] ] "infer-effect" set-word-prop
 \ millis [ [ ] [ integer ] ] "infer-effect" set-word-prop
 \ (random-int) [ [ ] [ integer ] ] "infer-effect" set-word-prop
+
 \ type [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
 \ type t "flushable" set-word-prop
 \ type t "foldable" set-word-prop
@@ -484,7 +465,6 @@ memory parser sequences strings vectors words prettyprint ;
 \ alien-c-string t "flushable" set-word-prop
 
 \ set-alien-c-string [ [ string c-ptr integer ] [ ] ] "infer-effect" set-word-prop
-\ throw [ [ object ] [ ] ] "infer-effect" set-word-prop
 \ string>memory [ [ string integer ] [ ] ] "infer-effect" set-word-prop
 \ memory>string [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
 \ alien-address [ [ alien ] [ integer ] ] "infer-effect" set-word-prop

library/inference/words.factor

@@ -112,7 +112,7 @@ M: symbol apply-object ( word -- )
             nip consume/produce
         ] [
             inferring-base-case get [
-                2drop terminate
+                t base-case-continuation get call
             ] [
                 car base-case
             ] ifte

library/syntax/parse-numbers.factor

@@ -5,7 +5,7 @@ USING: errors generic kernel math namespaces sequences strings ;
 
 ! Number parsing
 
-: not-a-number "Not a number" throw ;
+: not-a-number "Not a number" throw ; inline
 
 GENERIC: digit> ( ch -- n )
 M: digit  digit> CHAR: 0 - ;

library/test/compiler/ifte.factor

@@ -1,4 +1,5 @@
 IN: temporary
+USING: alien strings ;
 USE: compiler
 USE: test
 USE: math
@@ -94,3 +95,32 @@ DEFER: countdown-b
 
 [ 3 ] [ f dummy-unless-3 ] unit-test
 [ 4 ] [ 4 dummy-unless-3 ] unit-test
+
+[ "even" ] [
+    [
+        2 {
+            { [ dup 2 mod 0 = ] [ drop "even" ] }
+            { [ dup 2 mod 1 = ] [ drop "odd" ] }
+        } cond
+    ] compile-1
+] unit-test
+
+[ "odd" ] [
+    [
+        3 {
+            { [ dup 2 mod 0 = ] [ drop "even" ] }
+            { [ dup 2 mod 1 = ] [ drop "odd" ] }
+        } cond
+    ] compile-1
+] unit-test
+
+[ "neither" ] [
+    [
+        3 {
+            { [ dup string? ] [ drop "string" ] }
+            { [ dup float? ] [ drop "float" ] }
+            { [ dup alien? ] [ drop "alien" ] }
+            { [ t ] [ drop "neither" ] }
+        } cond
+    ] compile-1
+] unit-test

library/test/inference.factor

@@ -155,9 +155,11 @@ DEFER: agent
 [ [ [ ] [ object object ] ] ]
 [ [ [ drop ] 0 agent ] infer ] unit-test
 
-! : no-base-case dup [ no-base-case ] [ no-base-case ] ifte ;
-! 
-! [ [ no-base-case ] infer simple-effect ] unit-test-fails
+: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] ifte ;
+[ [ no-base-case-1 ] infer ] unit-test-fails
+
+: no-base-case-2 no-base-case-2 ;
+[ [ no-base-case-2 ] infer ] unit-test-fails
 
 [ { 2 1 } ] [ [ 2vector ] infer simple-effect ] unit-test
 [ { 3 1 } ] [ [ 3vector ] infer simple-effect ] unit-test

library/tools/jedit.factor

@@ -76,12 +76,11 @@ sequences strings unparser vectors words ;
     #! required word info.
     dup [
         [
-            "vocabulary"
-            "name"
-            "stack-effect"
-        ] [
-            dupd word-prop
-        ] map >r definer r> cons
+            dup definer ,
+            dup word-vocabulary ,
+            dup word-name ,
+            "stack-effect" word-prop ,
+        ] [ ] make
     ] when ;
 
 : completions ( str pred -- list | pred: str word -- ? )