Making more code infer

basis/eval/eval-docs.factor

@@ -1,18 +1,23 @@
 IN: eval
-USING: help.markup help.syntax strings io ;
+USING: help.markup help.syntax strings io effects ;
 
 HELP: eval
-{ $values { "str" string } }
-{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
+{ $values { "str" string } { "effect" effect } }
+{ $description "Parses Factor source code from a string, and calls the resulting quotation, which must have the given stack effect." }
+{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
+
+HELP: eval(
+{ $syntax "eval( inputs -- outputs )" }
+{ $description "Parses Factor source code from the string at the top of the stack, and calls the resulting quotation, which must have the given stack effect." }
 { $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
 
 HELP: eval>string
 { $values { "str" string } { "output" string } }
-{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
+{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string. The code in the string must not take or leave any values on the stack." } ;
 
 ARTICLE: "eval" "Evaluating strings at runtime"
 "The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
-{ $subsection eval }
+{ $subsection POSTPONE: eval( }
 { $subsection eval>string } ;
 
 ABOUT: "eval"

basis/eval/eval.factor

@@ -1,23 +1,25 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: splitting parser compiler.units kernel namespaces
-debugger io.streams.string fry ;
+debugger io.streams.string fry combinators effects.parser ;
 IN: eval
 
 : parse-string ( str -- quot )
     [ string-lines parse-lines ] with-compilation-unit ;
 
-: (eval) ( str -- )
-    parse-string call ;
+: (eval) ( str effect -- )
+    [ parse-string ] dip call-effect ; inline
 
-: eval ( str -- )
-    [ (eval) ] with-file-vocabs ;
+: eval ( str effect -- )
+    [ (eval) ] with-file-vocabs ; inline
+
+SYNTAX: eval( \ eval parse-call( ;
 
 : (eval>string) ( str -- output )
     [
         "quiet" on
         parser-notes off
-        '[ _ (eval) ] try
+        '[ _ (( -- )) (eval) ] try
     ] with-string-writer ;
 
 : eval>string ( str -- output )

basis/persistent/deques/deques.factor

@@ -21,7 +21,7 @@ TUPLE: deque { front read-only } { back read-only } ;
     [ back>> ] [ front>> ] bi deque boa ;
 
 : flipped ( deque quot -- newdeque )
-    [ flip ] dip call flip ;
+    [ flip ] dip call flip ; inline
 PRIVATE>
 
 : deque-empty? ( deque -- ? )

basis/tools/deploy/shaker/shaker.factor

@@ -354,8 +354,6 @@ IN: tools.deploy.shaker
 
 : finish-deploy ( final-image -- )
     "Finishing up" show
-    [ { } set-datastack ] dip
-    { } set-retainstack
     V{ } set-namestack
     V{ } set-catchstack
     "Saving final image" show

basis/tools/deploy/test/11/11.factor

@@ -3,6 +3,6 @@
 USING: eval ;
 IN: tools.deploy.test.11
 
-: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval ;
+: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval( -- ) ;
 
 MAIN: foo

basis/tools/deploy/test/7/7.factor

@@ -9,7 +9,7 @@ GENERIC: my-generic ( x -- b )
 
 M: integer my-generic sq ;
 
-M: fixnum my-generic call-next-method my-var get call ;
+M: fixnum my-generic call-next-method my-var get call( a -- b ) ;
 
 : test-7 ( -- )
     [ 1 + ] my-var set-global

basis/ui/gadgets/slots/slots.factor

@@ -44,11 +44,8 @@ TUPLE: slot-editor < track ref close-hook update-hook text ;
     { +description+ "Parse the object being edited, and store the result back into the edited slot." }
 } define-command
 
-: eval-1 ( string -- object )
-    1array [ eval ] with-datastack first ;
-
 : com-eval ( slot-editor -- )
-    [ [ text>> editor-string eval-1 ] [ ref>> ] bi set-ref ]
+    [ [ text>> editor-string eval( -- result ) ] [ ref>> ] bi set-ref ]
     [ close-and-update ]
     bi ;
 

basis/x11/xim/xim.factor

@@ -22,7 +22,7 @@ SYMBOL: xim
     xim get-global XCloseIM drop f xim set-global ;
 
 : with-xim ( quot -- )
-    [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ;
+    [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ; inline
 
 : create-xic ( window classname -- xic )
     [

basis/x11/xlib/xlib.factor

@@ -1440,4 +1440,4 @@ SYMBOL: root
 : close-x ( -- ) dpy get XCloseDisplay drop ;
 
 : with-x ( display-string quot -- )
-    [ initialize-x ] dip [ close-x ] [ ] cleanup ;
+    [ initialize-x ] dip [ close-x ] [ ] cleanup ; inline

extra/4DNav/4DNav.factor

@@ -76,8 +76,6 @@ VAR: present-space
 
 ! namespace utilities
 
-: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;
-
 : closed-quot ( quot -- quot )
   namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
 
@@ -156,9 +154,9 @@ VAR: present-space
     3 model-projection <model> view4> (>>model) ;
 
 : camera-action ( quot -- quot ) 
-    [ drop [ ] observer3d>  
+    '[ drop _ observer3d>  
     with-self update-observer-projections ] 
-    make* closed-quot ;
+    closed-quot ;
 
 : win3D ( text gadget -- ) 
     "navigateur 4D : " rot append open-window ;
@@ -400,7 +398,7 @@ M: handler handle-gesture ( gesture gadget -- ? )
 
 : add-keyboard-delegate ( obj -- obj )
  <handler>
-{
+H{
         { T{ key-down f f "LEFT" }  
             [ [ rotation-step turn-left ] camera-action ] }
         { T{ key-down f f "RIGHT" } 
@@ -435,7 +433,7 @@ M: handler handle-gesture ( gesture gadget -- ? )
         { T{ key-down f f "3" } [ mvt-3D-3  camera-action ] }
         { T{ key-down f f "4" } [ mvt-3D-4  camera-action ] }
 
-    } [ make* ] map >hashtable >>table
+    } >>table
     ;    
 
 ! --------------------------------------------

extra/4DNav/file-chooser/file-chooser.factor

@@ -72,17 +72,17 @@ file-chooser H{
 : init-filelist-model ( file-chooser -- file-chooser )
     dup list-of-files <model> >>model ; 
 
-: (fc-go) ( file-chooser quot -- )
+: (fc-go) ( file-chooser button quot -- )
     [ [ file-chooser? ] find-parent dup path>> ] dip
     call
     normalize-path swap set-model
     update-filelist-model
-    drop ;
+    drop ; inline
 
-: fc-go-parent ( file-chooser -- )
+: fc-go-parent ( file-chooser button -- )
     [ dup value>> parent-directory ] (fc-go) ;
 
-: fc-go-home ( file-chooser -- )
+: fc-go-home ( file-chooser button -- )
     [ home ] (fc-go) ;
 
 : fc-change-directory ( file-chooser file -- )

extra/infix/infix.factor

@@ -40,7 +40,7 @@ M: ast-array infix-codegen
 M: ast-op infix-codegen
     [ left>> infix-codegen ] [ right>> infix-codegen ]
     [ op>> select-op ] tri
-    2over [ number? ] both? [ call ] [
+    2over [ number? ] both? [ call( a b -- c ) ] [
         [ [ prepare-operand ] bi@ ] dip '[ @ @ @ ]
     ] if ;
 

extra/key-caps/key-caps.factor

@@ -141,7 +141,7 @@ TUPLE: key-caps-gadget < gadget keys alarm ;
         swap [ 
             " " [ drop ] <border-button>
             swap [ first >>loc ] [ second >>dim ] bi
-        ] [ execute ] bi*
+        ] [ execute( -- value ) ] bi*
     ] dip set-nth ;
 
 : add-keys-gadgets ( gadget -- gadget )

extra/koszul/koszul.factor

@@ -165,7 +165,7 @@ DEFER: (d)
     swap call [ at 0 or ] curry map ; inline
 
 : op-matrix ( domain range quot -- matrix )
-    rot [ [ 2dup ] dip (op-matrix) ] map 2nip ; inline
+    rot [ (op-matrix) ] with with map ; inline
 
 : d-matrix ( domain range -- matrix )
     [ (d) ] op-matrix ;

extra/math/binpack/binpack.factor

@@ -18,5 +18,5 @@ IN: math.binpack
     [ dup zip ] dip binpack [ keys ] map ;
 
 : binpack! ( items quot n -- bins ) 
-    [ dupd map zip ] dip binpack [ keys ] map ;
+    [ dupd map zip ] dip binpack [ keys ] map ; inline
 

extra/parser-combinators/parser-combinators.factor

@@ -76,7 +76,7 @@ M: satisfy-parser parse ( input parser -- list )
     over empty? [
         2drop nil
     ] [
-        quot>> [ unclip-slice dup ] dip call
+        quot>> [ unclip-slice dup ] dip call( char -- ? )
         [ swap <parse-results> ] [ 2drop nil ] if
     ] if ;
 

extra/partial-continuations/partial-continuations.factor

@@ -4,7 +4,7 @@ IN: partial-continuations
 USING: kernel continuations arrays sequences quotations ;
 
 : breset ( quot -- )
-    [ 1array swap keep first continue-with ] callcc1 nip ;
+    [ 1array swap keep first continue-with ] callcc1 nip ; inline
 
 : (bshift) ( v r k -- obj )
     [ dup first -rot ] dip

extra/peg-lexer/peg-lexer.factor

@@ -43,7 +43,7 @@ M: lex-hash at*
 
 : parse* ( parser -- ast )
     compile
-    [ execute [ error-stack get first throw ] unless* ] with-global-lexer
+    [ execute( -- result ) [ error-stack get first throw ] unless* ] with-global-lexer
     ast>> ;
 
 : create-bnf ( name parser -- )

extra/project-euler/011/011.factor

@@ -95,7 +95,7 @@ PRIVATE>
 : euler011 ( -- answer )
     [
         { [ horizontal ] [ vertical ] [ diagonal/ ] [ diagonal\ ] }
-        [ call 4 max-product , ] each
+        [ call( -- matrix ) 4 max-product , ] each
     ] { } make supremum ;
 
 ! [ euler011 ] 100 ave-time

extra/shell/shell.factor

@@ -41,7 +41,7 @@ METHOD: expand { glob-expr }
     [ ]
   if ;
 
-METHOD: expand { factor-expr } expr>> eval unparse ;
+METHOD: expand { factor-expr } expr>> eval>string ;
 
 DEFER: expansion
 
@@ -64,7 +64,7 @@ METHOD: expand { object } ;
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : run-sword ( basic-expr -- )
-  command>> expansion unclip "shell" lookup execute ;
+  command>> expansion unclip "shell" lookup execute( arguments -- ) ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/ui/gadgets/lists/lists.factor

@@ -90,7 +90,7 @@ M: list focusable-child* drop t ;
 
 : invoke-value-action ( list -- )
     dup list-empty? [
-        dup hook>> call
+        dup hook>> call( list -- )
     ] [
         [ index>> ] keep nth-gadget invoke-secondary
     ] if ;

extra/update/util/util.factor

@@ -20,8 +20,8 @@ DEFER: to-strings
   dup class
     {
       { \ string    [ ] }
-      { \ quotation [ call ] }
-      { \ word      [ execute ] }
+      { \ quotation [ call( -- string ) ] }
+      { \ word      [ execute( -- string ) ] }
       { \ fixnum    [ number>string ] }
       { \ array     [ to-strings concat ] }
     }

extra/webapps/site-watcher/site-watcher.factor

@@ -79,8 +79,7 @@ site-watcher-db <alloy>
 main-responder set-global
 
 M: site-watcher-app init-user-profile
-    drop B
-    "username" value "email" value <account> insert-tuple ;
+    drop "username" value "email" value <account> insert-tuple ;
 
 : init-db ( -- )
     site-watcher-db [

extra/webapps/site-watcher/spidering/spidering.factor

@@ -12,7 +12,7 @@ CONSTANT: site-list-url URL" $site-watcher-app/spider-list"
         { site-watcher-app "spider-list" } >>template
         [
             ! Silly query
-            username B spidering-sites [ site>> ] map
+            username spidering-sites [ site>> ] map
             "sites" set-value
         ] >>init
     <protected>

extra/wordtimer/wordtimer.factor

@@ -58,7 +58,7 @@ SYMBOL: *calling*
   swap [ * - ] keep 2array ;
   
 : change-global ( variable quot -- )
-  global swap change-at ;
+  global swap change-at ; inline
 
 : (correct-for-timing-overhead) ( timingshash -- timingshash )
   time-dummy-word [ subtract-overhead ] curry assoc-map ;  
@@ -75,7 +75,7 @@ SYMBOL: *calling*
       correct-for-timing-overhead
       "total time:" write
   ] dip pprint nl
-  print-word-timings nl ;
+  print-word-timings nl ; inline
 
 : profile-vocab ( vocab quot -- )
   "annotating vocab..." print flush
@@ -88,4 +88,4 @@ SYMBOL: *calling*
       correct-for-timing-overhead
       "total time:" write
   ] dip pprint
-  print-word-timings ;
+  print-word-timings ; inline