First stage of stack effect declaration implementation

TODO.FACTOR.txt

@@ -16,17 +16,13 @@
 - the invalid recursion form case needs to be fixed, for inlines too
 - graphical module manager tool
 - see if alien calls can be made faster
-
-========================================================================
-
-+ ui:
-
-- fix ui listener delay
 - doc front page: document stack effect notation
 - better doc for accumulate, link from tree
+
++ 0.85:
+
+- fix ui listener delay
 - we have trouble drawing rectangles
-- the UI listener has a shitty design. perhaps it should not call out
-  to the real listener.
 - remaining walker tasks:
   - integrate walker with listener
   - <input> handled by walker itself
@@ -35,6 +31,32 @@
   - error handling is still screwy
   - continuation handling is also screwy
   - keyboard commands
+- editor:
+  - only redraw visible lines
+  - more efficient multi-line inserts
+  - editor should support stream output protocol
+- slider needs to be modelized
+- listener tab completion
+- track individual method usages
+- modularize core
+- track module files and modification times, and a list of assets loaded
+  from that file
+- 'changes' word, asks if files changed on disk from loaded modules
+  should be reloaded -- do this in the right order
+- more compact relocation info
+- UI dataflow visualizer
+- loading the image should not exhaust nursery space
+- problem if major gc happens during relocation
+  - in fact relocation should not cons at all
+
+========================================================================
+
++ ui:
+
+- figure out what goes in the .app and what doesn't
+- should be possible to drop an image file on the .app to run it
+- the UI listener has a shitty design. perhaps it should not call out
+  to the real listener.
 - add-gadget, model-changed, set-model should compile
 - shortcuts:
   - find a listener
@@ -50,9 +72,6 @@
   - autoscroll
   - page up/down
   - search and replace
-  - only redraw visible lines
-  - more efficient multi-line inserts
-  - editor should support stream output protocol
 - cocoa: windows are not updated while resizing
 - grid slows down with 2000 lines
 - ui uses too much cpu time idling
@@ -64,31 +83,22 @@
   - horizontal wheel scrolling
   - polish OS X menu bar code
 - variable width word wrap
-- slider needs to be modelized
 - structure editor
-- listener tab completion
+- loading space invaders slows the UI down
 
 + module system:
 
 - generic 'define ( asset def -- )'
-- track individual method usages
 - C types should be words
   - TYPEDEF: float { ... } { ... } ;   ==> \ float T{ c-type ... } "c-type" swp
   - TYPEDEF: float FTFloat ;  ==> \ float \ FTFloat "c-type" swp
   - make typedef aliasing explicit
 - seeing a C struct word should show its def
-- modularize core
 - TUPLE: module files tests articles article main ;
 - file out
-- track module files and modification times, and a list of assets loaded
-  from that file
-- 'changes' word, asks if files changed on disk from loaded modules
-  should be reloaded -- do this in the right order
 
 + compiler/ffi:
 
-- more compact relocation info
-- UI dataflow visualizer
 - ppc64 backend
 - we need to optimize  [ dup array? [ array? ] [ array? ] if ]
 - mac intel: struct returns from objc methods
@@ -105,10 +115,8 @@
 
 + misc:
 
-- loading the image should not exhaust nursery space
+- compiler tests are not as reliable now because of try-compile usage
-- compiler tests are not as reliable now
+  - we can just do [ t ] [ \ foo compiled? ] unit-test
-- problem if major gc happens during relocation
-  - in fact relocation should not cons at all
 - growable data heap
 - incremental GC
 - UDP
@@ -124,5 +132,6 @@
 [ 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 11 11 11 113 
 ]
 
+- prettier printing of hashtable literals, alists, cond, ...
 - httpd search tools
 - remaining HTML issues need fixing

library/bootstrap/image.factor

@@ -129,13 +129,13 @@ GENERIC: ' ( obj -- ptr )
     dup length 1+ emit-fixnum
     swap emit emit-seq ;
 
-M: bignum ' ( bignum -- tagged )
+M: bignum '
     #! This can only emit 0, -1 and 1.
     bignum-tag bignum-tag [ emit-bignum ] emit-object ;
 
 ( Fixnums )
 
-M: fixnum ' ( n -- tagged )
+M: fixnum '
     #! When generating a 32-bit image on a 64-bit system,
     #! some fixnums should be bignums.
     dup most-negative-fixnum most-positive-fixnum between?
@@ -143,7 +143,7 @@ M: fixnum ' ( n -- tagged )
 
 ( Floats )
 
-M: float ' ( float -- tagged )
+M: float '
     float-tag float-tag [
         align-here double>bits emit-64
     ] emit-object ;
@@ -154,7 +154,7 @@ M: float ' ( float -- tagged )
 
 : t, t t-offset fixup ;
 
-M: f ' ( obj -- ptr )
+M: f '
     #! f is #define F RETAG(0,OBJECT_TYPE)
     drop object-tag ;
 
@@ -183,7 +183,7 @@ M: f ' ( obj -- ptr )
     word-tag word-tag [ emit-seq ] emit-object
     swap objects get set-hash ;
 
-: word-error ( word msg -- )
+: word-error ( word msg -- * )
     [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
 
 : transfer-word ( word -- word )
@@ -197,11 +197,11 @@ M: f ' ( obj -- ptr )
 : fixup-words ( -- )
     image get [ dup word? [ fixup-word ] when ] inject ;
 
-M: word ' ( word -- pointer ) ;
+M: word ' ;
 
 ( Wrappers )
 
-M: wrapper ' ( wrapper -- pointer )
+M: wrapper '
     wrapped ' wrapper-tag wrapper-tag [ emit ] emit-object ;
 
 ( Ratios and complexes )
@@ -209,10 +209,10 @@ M: wrapper ' ( wrapper -- pointer )
 : emit-pair
     [ [ emit ] 2apply ] emit-object ;
 
-M: ratio ' ( c -- tagged )
+M: ratio '
     >fraction [ ' ] 2apply ratio-tag ratio-tag emit-pair ;
 
-M: complex ' ( c -- tagged )
+M: complex '
     >rect [ ' ] 2apply complex-tag complex-tag emit-pair ;
 
 ( Strings )
@@ -231,7 +231,7 @@ M: complex ' ( c -- tagged )
         pack-string emit-chars
     ] emit-object ;
 
-M: string ' ( string -- pointer )
+M: string '
     #! We pool strings so that each string is only written once
     #! to the image
     objects get [ emit-string ] cache ;
@@ -249,24 +249,24 @@ M: string ' ( string -- pointer )
     dup first transfer-word 0 pick set-nth
     >tuple ;
 
-M: tuple ' ( tuple -- pointer )
+M: tuple '
     transfer-tuple
     objects get [ tuple>array tuple-type emit-array ] cache ;
 
-M: array ' ( array -- pointer )
+M: array '
     array-type emit-array ;
 
-M: quotation ' ( array -- pointer )
+M: quotation '
     quotation-type emit-array ;
 
-M: vector ' ( vector -- pointer )
+M: vector '
     dup underlying ' swap length
     vector-type object-tag [
         emit-fixnum ( length )
         emit ( array ptr )
     ] emit-object ;
 
-M: sbuf ' ( sbuf -- pointer )
+M: sbuf '
     dup underlying ' swap length
     sbuf-type object-tag [
         emit-fixnum ( length )
@@ -275,7 +275,7 @@ M: sbuf ' ( sbuf -- pointer )
 
 ( Hashes )
 
-M: hashtable ' ( hashtable -- pointer )
+M: hashtable '
     [ hash-array ' ] keep
     hashtable-type object-tag [
         dup hash-count emit-fixnum

library/collections/arrays.factor

@@ -21,12 +21,12 @@ M: byte-array clone (clone) ;
 M: byte-array length array-capacity ;
 M: byte-array resize resize-array ;
 
-: 1array ( x -- { x } ) 1 swap <array> ;
+: 1array ( x -- array ) 1 swap <array> ;
 
-: 2array ( x y -- { x y } )
+: 2array ( x y -- array )
     2 swap <array> [ 0 swap set-array-nth ] keep ;
 
-: 3array ( x y z -- { x y z } )
+: 3array ( x y z -- array )
     3 swap <array>
     [ 1 swap set-array-nth ] keep
     [ 0 swap set-array-nth ] keep ;

library/collections/growable.factor

@@ -31,7 +31,7 @@ GENERIC: set-fill
 
 TUPLE: bounds-error index seq ;
 
-: bounds-error <bounds-error> throw ;
+: bounds-error ( n seq -- * ) <bounds-error> throw ;
 
 : growable-check ( n seq -- n seq )
     over 0 < [ bounds-error ] when ; inline

library/collections/hashtables.factor

@@ -30,7 +30,7 @@ TUPLE: tombstone ;
 : key@ ( key hash -- n )
     hash-array 2dup hash@ (key@) ; inline
 
-: if-key ( key hash true false -- | true: index key hash -- )
+: if-key ( key hash true false -- ) | true ( index key hash -- )
     >r >r [ key@ ] 2keep pick -1 > r> r> if ; inline
 
 : <hash-array> ( n -- array )
@@ -75,10 +75,9 @@ TUPLE: tombstone ;
 : (set-hash) ( value key hash -- )
     2dup new-key@ swap
     [ hash-array 2dup array-nth ] keep
-    ( value key n hash-array old hash )
     swap change-size set-nth-pair ; inline
 
-: (each-pair) ( quot array i -- | quot: k v -- )
+: (each-pair) ( quot array i -- ) | quot ( k v -- )
     over array-capacity over eq? [
         3drop
     ] [
@@ -88,10 +87,10 @@ TUPLE: tombstone ;
         ] 3keep 2 fixnum+fast (each-pair)
     ] if ; inline
 
-: each-pair ( array quot -- | quot: k v -- )
+: each-pair ( array quot -- ) | quot ( k v -- )
     swap 0 (each-pair) ; inline
 
-: (all-pairs?) ( quot array i -- ? | quot: k v -- ? )
+: (all-pairs?) ( quot array i -- ? ) | quot ( k v -- ? )
     over array-capacity over eq? [
         3drop t
     ] [
@@ -106,7 +105,7 @@ TUPLE: tombstone ;
         ] if
     ] if ; inline
 
-: all-pairs? ( array quot -- ? | quot: k v -- ? )
+: all-pairs? ( array quot -- ? ) | quot ( k v -- ? )
     swap 0 (all-pairs?) ; inline
 
 : hash>seq ( i hash -- seq )
@@ -189,17 +188,17 @@ IN: hashtables
     [ length <hashtable> ] keep
     [ first2 swap pick (set-hash) ] each ;
 
-: hash-each ( hash quot -- | quot: k v -- )
+: hash-each ( hash quot -- ) | quot ( k v -- )
     >r hash-array r> each-pair ; inline
 
-: hash-each-with ( obj hash quot -- | quot: obj k v -- )
+: hash-each-with ( obj hash quot -- ) | quot ( obj k v -- )
     swap [ 2swap [ >r -rot r> call ] 2keep ] hash-each 2drop ;
     inline
 
-: hash-all? ( hash quot -- | quot: k v -- ? )
+: hash-all? ( hash quot -- ) | quot ( k v -- ? )
     >r hash-array r> all-pairs? ; inline
 
-: hash-all-with? ( obj hash quot -- | quot: obj k v -- ? )
+: hash-all-with? ( obj hash quot -- ) | quot ( obj k v -- ? )
     swap
     [ 2swap [ >r -rot r> call ] 2keep rot ] hash-all? 2nip ;
     inline
@@ -209,7 +208,7 @@ IN: hashtables
         >r swap hash* [ r> = ] [ r> 2drop f ] if
     ] hash-all-with? ;
 
-: hash-subset ( hash quot -- hash | quot: k v -- ? )
+: hash-subset ( hash quot -- hash ) | quot ( k v -- ? )
     over hash-size <hashtable> rot [
         2swap [
             >r pick pick >r >r call [
@@ -220,18 +219,18 @@ IN: hashtables
         ] 2keep
     ] hash-each nip ; inline
 
-: hash-subset-with ( obj hash quot -- hash | quot: obj { k v } -- ?  )
+: hash-subset-with ( obj hash quot -- hash ) | quot ( obj pair -- ?  )
     swap
     [ 2swap [ >r -rot r> call ] 2keep rot ] hash-subset 2nip ;
     inline
 
-M: hashtable clone ( hash -- hash )
+M: hashtable clone
     (clone) dup hash-array clone over set-hash-array ;
 
 : hashtable= ( hash hash -- ? )
     2dup subhash? >r swap subhash? r> and ;
 
-M: hashtable equal? ( obj hash -- ? )
+M: hashtable equal?
     {
         { [ over hashtable? not ] [ 2drop f ] }
         { [ 2dup [ hash-size ] 2apply number= not ] [ 2drop f ] }
@@ -243,7 +242,7 @@ M: hashtable equal? ( obj hash -- ? )
         hashcode >r hashcode -1 shift r> bitxor bitxor
     ] hash-each ;
 
-M: hashtable hashcode ( hash -- n )
+M: hashtable hashcode
     dup hash-size 1 number=
     [ hashtable-hashcode ] [ hash-size ] if ;
 
@@ -293,14 +292,14 @@ IN: hashtables
 : remove-all ( hash seq -- seq )
     [ swap hash-member? not ] subset-with ;
 
-: cache ( key hash quot -- value | quot: key -- value )
+: cache ( key hash quot -- value ) | quot ( key -- value )
     pick pick hash [
         >r 3drop r>
     ] [
         pick rot >r >r call dup r> r> set-hash
     ] if* ; inline
 
-: map>hash ( seq quot -- hash | quot: key -- key value )
+: map>hash ( seq quot -- hash ) | quot ( key -- key value )
     over length <hashtable> rot
     [ -rot [ >r call swap r> set-hash ] 2keep ] each nip ;
     inline

library/collections/namespaces.factor

@@ -4,8 +4,8 @@ IN: kernel-internals
 USING: vectors sequences ;
 
 : namestack* ( -- ns ) 3 getenv { vector } declare ; inline
-: >n ( namespace -- n:namespace ) namestack* push ;
+: >n ( namespace -- ) namestack* push ;
-: n> ( n:namespace -- namespace ) namestack* pop ;
+: n> ( -- namespace ) namestack* pop ;
 
 IN: namespaces
 USING: arrays hashtables kernel kernel-internals math strings
@@ -14,7 +14,7 @@ words ;
 : namestack ( -- ns ) namestack* clone ; inline
 : set-namestack ( ns -- ) >vector 3 setenv ; inline
 : namespace ( -- namespace ) namestack* peek ;
-: ndrop ( n:namespace -- ) namestack* pop* ;
+: ndrop ( -- ) namestack* pop* ;
 : global ( -- g ) 4 getenv { hashtable } declare ; inline
 : get ( variable -- value ) namestack* hash-stack ;
 : set ( value variable -- ) namespace set-hash ; inline

library/collections/queues.factor

@@ -34,7 +34,7 @@ C: queue ( -- queue ) ;
     ] if ;
 
 TUPLE: empty-queue ;
-: empty-queue <empty-queue> throw ;
+: empty-queue ( -- * ) <empty-queue> throw ;
 
 : deque ( queue -- obj )
     dup queue-empty? [

library/collections/sequences-epilogue.factor

@@ -4,13 +4,13 @@ IN: sequences
 USING: arrays errors generic kernel kernel-internals math
 sequences-internals strings vectors words ;
 
-: first2 ( { x y } -- x y )
+: first2 ( seq -- x y )
     1 swap bounds-check nip first2-unsafe ;
 
-: first3 ( { x y z } -- x y z )
+: first3 ( seq -- x y z )
     2 swap bounds-check nip first3-unsafe ;
 
-: first4 ( { x y z w } -- x y z w )
+: first4 ( seq -- x y z w )
     3 swap bounds-check nip first4-unsafe ;
 
 M: object like drop ;
@@ -129,21 +129,21 @@ M: object like drop ;
     2dup [ length ] 2apply tuck number=
     [ (mismatch) -1 number= ] [ 3drop f ] if ; inline
 
-M: array equal? ( obj seq -- ? )
+M: array equal?
     over array? [ sequence= ] [ 2drop f ] if ;
 
-M: quotation equal? ( obj seq -- ? )
+M: quotation equal?
     over quotation? [ sequence= ] [ 2drop f ] if ;
 
-M: sbuf equal? ( obj seq -- ? )
+M: sbuf equal?
     over sbuf? [ sequence= ] [ 2drop f ] if ;
 
-M: vector equal? ( obj seq -- ? )
+M: vector equal?
     over vector? [ sequence= ] [ 2drop f ] if ;
 
 UNION: sequence array string sbuf vector quotation ;
 
-M: sequence hashcode ( hash -- n )
+M: sequence hashcode
     dup empty? [ drop 0 ] [ first hashcode ] if ;
 
 IN: kernel
@@ -155,7 +155,7 @@ M: object <=>
 : depth ( -- n ) datastack length ;
 
 TUPLE: no-cond ;
-: no-cond <no-cond> throw ;
+: no-cond ( -- * ) <no-cond> throw ;
 
 : cond ( conditions -- )
     [ first call ] find nip dup [ second call ] [ no-cond ] if ;

library/collections/sequences.factor

@@ -6,7 +6,7 @@ USING: errors generic kernel math math-internals strings vectors ;
 GENERIC: length ( sequence -- n )
 GENERIC: set-length ( n sequence -- )
 GENERIC: nth ( n sequence -- obj )
-GENERIC: set-nth ( value n sequence -- obj )
+GENERIC: set-nth ( value n sequence -- )
 GENERIC: thaw ( seq -- mutable-seq )
 GENERIC: like ( seq seq -- seq )
 
@@ -33,8 +33,8 @@ IN: sequences-internals
 GENERIC: resize ( n seq -- seq )
 
 ! Unsafe sequence protocol for inner loops
-GENERIC: nth-unsafe
+GENERIC: nth-unsafe ( n sequence -- elt )
-GENERIC: set-nth-unsafe
+GENERIC: set-nth-unsafe ( elt n sequence -- )
 
 M: object nth-unsafe nth ;
 M: object set-nth-unsafe set-nth ;

library/collections/strings.factor

@@ -4,7 +4,7 @@ IN: strings
 USING: generic kernel kernel-internals math sequences
 sequences-internals ;
 
-M: string equal? ( obj str -- ? )
+M: string equal?
     over string? [
         over hashcode over hashcode number=
         [ sequence= ] [ 2drop f ] if
@@ -66,5 +66,5 @@ UNION: alpha Letter digit ;
 
 M: string thaw drop SBUF" " clone ;
 
-M: string like ( seq sbuf -- string )
+M: string like
     drop dup string? [ >string ] unless ;

library/collections/vectors.factor

@@ -4,17 +4,17 @@ IN: vectors
 USING: arrays errors generic kernel kernel-internals math
 math-internals sequences sequences-internals words ;
 
-M: vector set-length ( len vec -- )
+M: vector set-length
     grow-length ;
 
-M: vector nth-unsafe ( n vec -- obj ) underlying nth-unsafe ;
+M: vector nth-unsafe underlying nth-unsafe ;
 
-M: vector nth ( n vec -- obj ) bounds-check nth-unsafe ;
+M: vector nth bounds-check nth-unsafe ;
 
-M: vector set-nth-unsafe ( obj n vec -- )
+M: vector set-nth-unsafe
     underlying set-nth-unsafe ;
 
-M: vector set-nth ( obj n vec -- )
+M: vector set-nth
     growable-check 2dup ensure set-nth-unsafe ;
 
 : >vector ( seq -- vector )
@@ -22,7 +22,7 @@ M: vector set-nth ( obj n vec -- )
 
 M: object thaw drop V{ } clone ;
 
-M: vector clone ( vector -- vector ) clone-growable ;
+M: vector clone clone-growable ;
 
 M: vector like
     drop dup vector? [

library/collections/virtual-sequences.factor

@@ -8,20 +8,20 @@ TUPLE: reversed seq ;
 
 : reversed@ reversed-seq [ length swap - 1- ] keep ; inline
 
-M: reversed length ( seq -- n ) reversed-seq length ;
+M: reversed length reversed-seq length ;
 
-M: reversed nth ( n seq -- elt ) reversed@ nth ;
+M: reversed nth reversed@ nth ;
 
-M: reversed nth-unsafe ( n seq -- elt ) reversed@ nth-unsafe ;
+M: reversed nth-unsafe reversed@ nth-unsafe ;
 
-M: reversed set-nth ( elt n seq -- ) reversed@ set-nth ;
+M: reversed set-nth reversed@ set-nth ;
 
-M: reversed set-nth-unsafe ( elt n seq -- )
+M: reversed set-nth-unsafe
     reversed@ set-nth-unsafe ;
 
-M: reversed like ( seq reversed -- seq ) reversed-seq like ;
+M: reversed like reversed-seq like ;
 
-M: reversed thaw ( seq -- seq ) reversed-seq thaw ;
+M: reversed thaw reversed-seq thaw ;
 
 : reverse ( seq -- seq ) [ <reversed> ] keep like ;
 
@@ -32,7 +32,7 @@ TUPLE: slice seq from to ;
     dup slice-from swap slice-seq >r tuck + >r + r> r> ;
 
 TUPLE: slice-error reason ;
-: slice-error ( str -- ) <slice-error> throw ;
+: slice-error ( str -- * ) <slice-error> throw ;
 
 : check-slice ( from to seq -- )
     pick 0 < [ "start < 0" slice-error ] when
@@ -47,20 +47,20 @@ C: slice ( from to seq -- seq )
     [ set-slice-to ] keep
     [ set-slice-from ] keep ;
 
-M: slice length ( range -- n )
+M: slice length
     dup slice-to swap slice-from - ;
 
 : slice@ ( n slice -- n seq )
     [ slice-from + ] keep slice-seq ; inline
 
-M: slice nth ( n slice -- obj ) slice@ nth ;
+M: slice nth slice@ nth ;
 
-M: slice nth-unsafe ( n slice -- obj ) slice@ nth-unsafe ;
+M: slice nth-unsafe slice@ nth-unsafe ;
 
-M: slice set-nth ( obj n slice -- ) slice@ set-nth ;
+M: slice set-nth slice@ set-nth ;
 
-M: slice set-nth-unsafe ( n slice -- obj ) slice@ set-nth-unsafe ;
+M: slice set-nth-unsafe slice@ set-nth-unsafe ;
 
-M: slice like ( seq slice -- seq ) slice-seq like ;
+M: slice like slice-seq like ;
 
-M: slice thaw ( seq -- seq ) slice-seq thaw ;
+M: slice thaw slice-seq thaw ;

library/compiler/alien/alien-callback.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: alien
 USING: compiler errors generic hashtables inference inspector
-kernel namespaces sequences strings words ;
+kernel namespaces sequences strings words parser ;
 
 TUPLE: alien-callback return parameters quot xt ;
 C: alien-callback make-node ;
@@ -15,7 +15,7 @@ TUPLE: alien-callback-error ;
 : callback-bottom ( node -- )
     alien-callback-xt [ word-xt <alien> ] curry infer-quot ;
 
-\ alien-callback [ [ string object quotation ] [ alien ] ]
+\ alien-callback [ string object quotation ] [ alien ] <effect>
 "infer-effect" set-word-prop
 
 \ alien-callback [
@@ -55,7 +55,7 @@ TUPLE: alien-callback-error ;
         %return
     ] generate-1 ;
 
-M: alien-callback generate-node ( node -- )
+M: alien-callback generate-node
     end-basic-block compile-gc generate-callback iterate-next ;
 
 M: alien-callback stack-reserve*

library/compiler/alien/alien-invoke.factor

@@ -4,7 +4,7 @@ IN: alien
 USING: arrays assembler compiler compiler
 errors generic hashtables inference inspector
 io kernel kernel-internals math namespaces parser
-prettyprint sequences strings words ;
+prettyprint sequences strings words parser ;
 
 TUPLE: alien-invoke library function return parameters ;
 C: alien-invoke make-node ;
@@ -22,7 +22,7 @@ TUPLE: alien-invoke-error library symbol ;
 : alien-invoke ( ... return library function parameters -- ... )
     pick pick <alien-invoke-error> throw ;
 
-\ alien-invoke [ [ string object string object ] [ ] ]
+\ alien-invoke [ string object string object ] [ ] <effect>
 "infer-effect" set-word-prop
 
 \ alien-invoke [
@@ -60,7 +60,7 @@ TUPLE: alien-invoke-error library symbol ;
         alien-invoke-parameters stack-space %cleanup
     ] if ;
 
-M: alien-invoke generate-node ( node -- )
+M: alien-invoke generate-node
     end-basic-block compile-gc
     dup alien-invoke-parameters objects>registers
     dup alien-invoke-dlsym %alien-invoke

library/compiler/alien/aliens.factor

@@ -8,7 +8,7 @@ sequences ;
 
 UNION: c-ptr byte-array alien ;
 
-M: alien equal? ( obj obj -- ? )
+M: alien equal?
     over alien? [
         2dup [ expired? ] 2apply 2dup or [
             2swap 2drop

library/compiler/alien/objc/utilities.factor

@@ -119,7 +119,8 @@ H{ } clone objc-methods set-global
 
 \ (send) [ pop-literal nip infer-send ] "infer" set-word-prop
 
-\ (send) [ [ object object ] [ ] ] "infer-effect" set-word-prop
+\ (send) [ object object ] [ ] <effect>
+"infer-effect" set-word-prop
 
 : send ( ... selector -- ... ) f (send) ; inline
 

library/compiler/generator/generator.factor

@@ -66,14 +66,14 @@ GENERIC: generate-node ( node -- )
     [ [ generate-nodes ] with-node-iterator ] generate-1 ;
 
 ! node
-M: node generate-node ( node -- next ) drop iterate-next ;
+M: node generate-node drop iterate-next ;
 
 ! #label
 : generate-call ( label -- next )
     end-basic-block
     tail-call? [ %jump f ] [ %call iterate-next ] if ;
 
-M: #label generate-node ( node -- next )
+M: #label generate-node
     dup node-param dup generate-call >r
     swap node-child generate r> ;
 
@@ -87,7 +87,7 @@ M: #label generate-node ( node -- next )
         r> r> end-false-branch resolve-label generate-nodes
     ] keep resolve-label iterate-next ;
 
-M: #if generate-node ( node -- next )
+M: #if generate-node
     [
         end-basic-block
         <label> dup %jump-t
@@ -123,7 +123,7 @@ M: #if generate-node ( node -- next )
         drop r> if>boolean-intrinsic iterate-next
     ] if ;
 
-M: #call generate-node ( node -- next )
+M: #call generate-node
     {
         { [ dup if-intrinsic ] [ do-if-intrinsic ] }
         { [ dup intrinsic ] [ intrinsic call iterate-next ] }
@@ -131,7 +131,7 @@ M: #call generate-node ( node -- next )
     } cond ;
 
 ! #call-label
-M: #call-label generate-node ( node -- next )
+M: #call-label generate-node
     node-param generate-call ;
 
 ! #dispatch
@@ -150,7 +150,7 @@ M: #call-label generate-node ( node -- next )
         dup %jump-label
     ] each resolve-label ;
 
-M: #dispatch generate-node ( node -- next )
+M: #dispatch generate-node
     #! The parameter is a list of nodes, each one is a branch to
     #! take in case the top of stack has that type.
     dispatch-head dispatch-body iterate-next ;
@@ -164,7 +164,7 @@ UNION: immediate fixnum POSTPONE: f ;
     [ f spec>vreg [ load-literal ] keep ] map
     phantom-d get phantom-append ;
 
-M: #push generate-node ( #push -- )
+M: #push generate-node
     generate-push iterate-next ;
 
 ! #shuffle
@@ -193,7 +193,7 @@ M: #push generate-node ( #push -- )
     [ shuffle* ] keep adjust-shuffle
     (template-outputs) ;
 
-M: #shuffle generate-node ( #shuffle -- )
+M: #shuffle generate-node
     node-shuffle phantom-shuffle iterate-next ;
 
 ! #return

library/compiler/generator/templates.factor

@@ -87,7 +87,7 @@ M: phantom-callstack finalize-height
 
 GENERIC: cut-phantom ( n phantom -- seq )
 
-M: phantom-stack cut-phantom ( n phantom -- seq )
+M: phantom-stack cut-phantom
     [ delegate cut* swap ] keep set-delegate ;
 
 SYMBOL: phantom-d

library/compiler/generator/xt.factor

@@ -21,8 +21,7 @@ C: label ( -- label ) ;
 SYMBOL: compiled-xts
 
 : save-xt ( word xt -- )
-    over changed-words get remove-hash
+    swap dup unchanged-word compiled-xts get set-hash ;
-    swap compiled-xts get set-hash ;
 
 SYMBOL: literal-table
 
@@ -82,7 +81,7 @@ SYMBOL: label-table
 : compiling? ( word -- ? )
     {
         { [ dup compiled-xts get hash-member? ] [ drop t ] }
-        { [ dup changed-words get hash-member? ] [ drop f ] }
+        { [ dup word-changed? ] [ drop f ] }
         { [ t ] [ compiled? ] }
     } cond ;
 

library/compiler/inference/dataflow.factor

@@ -28,9 +28,9 @@ M: node equal? eq? ;
 : set-node-out-r node-shuffle set-shuffle-out-r ;
 
 : empty-node f { } { } { } { } ;
-: param-node ( label) { } { } { } { } ;
+: param-node { } { } { } { } ;
-: in-node ( inputs) >r f r> { } { } { } ;
+: in-node >r f r> { } { } { } ;
-: out-node ( outputs) >r f { } r> { } { } ;
+: out-node >r f { } r> { } { } ;
 : meta-d-node meta-d get clone in-node ;
 
 : d-tail ( n -- list )

library/compiler/inference/inference.factor

@@ -11,11 +11,11 @@ SYMBOL: base-case-continuation
 
 TUPLE: inference-error message rstate data-stack call-stack ;
 
-: inference-error ( msg -- )
+: inference-error ( msg -- * )
     recursive-state get meta-d get meta-r get
     <inference-error> throw ;
 
-M: object value-literal ( value -- )
+M: object value-literal
     "A literal value was expected where a computed value was found" inference-error ;
 
 ! Word properties that affect inference:
@@ -42,7 +42,7 @@ SYMBOL: d-in
 : ensure-values ( n -- )
     meta-d [ add-inputs ] change d-in [ + ] change ;
 
-: effect ( -- { in# out# } )
+: short-effect ( -- { in# out# } )
     #! After inference is finished, collect information.
     d-in get meta-d get length 2array ;
 
@@ -50,6 +50,13 @@ SYMBOL: d-in
 ! stack height is irrelevant and the branch will always unify?
 SYMBOL: terminated?
 
+: current-effect ( -- effect )
+    #! After inference is finished, collect information.
+    d-in get meta-d get length <effect>
+    terminated? get over set-effect-terminated? ;
+
+SYMBOL: recorded
+
 : init-inference ( recursive-state -- )
     terminated? off
     V{ } clone meta-r set
@@ -76,9 +83,9 @@ M: wrapper apply-object wrapped apply-literal ;
 
 GENERIC: infer-quot
 
-M: f infer-quot ( f -- ) drop ;
+M: f infer-quot drop ;
 
-M: quotation infer-quot ( quot -- )
+M: quotation infer-quot
     #! Recursive calls to this word are made for nested
     #! quotations.
     [ apply-object terminated? get not ] all? drop ;
@@ -97,16 +104,22 @@ M: quotation infer-quot ( quot -- )
 
 : with-infer ( quot -- )
     [
-        base-case-continuation off
+        [
-        { } recursive-state set
+            base-case-continuation off
-        f init-inference
+            { } recursive-state set
-        call
+            V{ } clone recorded set
-        check-return
+            f init-inference
+            call
+            check-return
+        ] [
+            recorded get dup . [ f "infer-effect" set-word-prop ] each
+            rethrow
+        ] recover
     ] with-scope ;
 
 : infer ( quot -- effect )
     #! Stack effect of a quotation.
-    [ infer-quot effect ] with-infer ;
+    [ infer-quot short-effect ] with-infer ;
 
 : (dataflow) ( quot -- dataflow )
     infer-quot f #return node, dataflow-graph get ;

library/compiler/inference/known-words.factor

@@ -10,49 +10,49 @@ sequences strings vectors words prettyprint ;
     dup #declare [ >r length d-tail r> set-node-in-d ] keep
     node,
 ] "infer" set-word-prop
-\ declare [ [ object ] [ ] ] "infer-effect" set-word-prop
+\ declare { object } { } <effect> "infer-effect" set-word-prop
 
-\ fixnum< [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ fixnum< { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
 \ fixnum< t "foldable" set-word-prop
 
-\ fixnum<= [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ fixnum<= { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
 \ fixnum<= t "foldable" set-word-prop
 
-\ fixnum> [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ fixnum> { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
 \ fixnum> t "foldable" set-word-prop
 
-\ fixnum>= [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ fixnum>= { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
 \ fixnum>= t "foldable" set-word-prop
 
-\ eq? [ [ object object ] [ object ] ] "infer-effect" set-word-prop
+\ eq? { object object } { object } <effect> "infer-effect" set-word-prop
 \ eq? t "foldable" set-word-prop
 
 ! Primitive combinators
-\ call [ [ object ] [ ] ] "infer-effect" set-word-prop
+\ call { object } { } <effect> "infer-effect" set-word-prop
 
 \ call [ pop-literal infer-quot-value ] "infer" set-word-prop
 
-\ execute [ [ word ] [ ] ] "infer-effect" set-word-prop
+\ execute { word } { } <effect> "infer-effect" set-word-prop
 
 \ execute [
     pop-literal unit infer-quot-value
 ] "infer" set-word-prop
 
-\ if [ [ object object object ] [ ] ] "infer-effect" set-word-prop
+\ if { object object object } { } <effect> "infer-effect" set-word-prop
 
 \ if [
     2 #drop node, pop-d pop-d swap 2array
     #if pop-d drop infer-branches
 ] "infer" set-word-prop
 
-\ cond [ [ object ] [ ] ] "infer-effect" set-word-prop
+\ cond { object } { } <effect> "infer-effect" set-word-prop
 
 \ cond [
     pop-literal <reversed>
     [ no-cond ] swap alist>quot infer-quot-value
 ] "infer" set-word-prop
 
-\ dispatch [ [ fixnum array ] [ ] ] "infer-effect" set-word-prop
+\ dispatch { fixnum array } { } <effect> "infer-effect" set-word-prop
 
 \ dispatch [
     pop-literal nip [ <value> ] map
@@ -60,343 +60,340 @@ sequences strings vectors words prettyprint ;
 ] "infer" set-word-prop
 
 ! Non-standard control flow
-\ throw [ [ object ] [ ] ] "infer-effect" set-word-prop
+\ throw { object } { } <effect>
-
+t over set-effect-terminated?
-\ throw [
+"infer-effect" set-word-prop
-    \ throw dup "infer-effect" word-prop consume/produce
-    terminate
-] "infer" set-word-prop
 
 ! Stack effects for all primitives
-\ <vector> [ [ integer ] [ vector ] ] "infer-effect" set-word-prop
+\ <vector> { integer } { vector } <effect> "infer-effect" set-word-prop
 
-\ rehash-string [ [ string ] [ ] ] "infer-effect" set-word-prop
+\ rehash-string { string } { } <effect> "infer-effect" set-word-prop
 
-\ <sbuf> [ [ integer ] [ sbuf ] ] "infer-effect" set-word-prop
+\ <sbuf> { integer } { sbuf } <effect> "infer-effect" set-word-prop
 
-\ >fixnum [ [ real ] [ fixnum ] ] "infer-effect" set-word-prop
+\ >fixnum { real } { fixnum } <effect> "infer-effect" set-word-prop
 \ >fixnum t "foldable" set-word-prop
 
-\ >bignum [ [ real ] [ bignum ] ] "infer-effect" set-word-prop
+\ >bignum { real } { bignum } <effect> "infer-effect" set-word-prop
 \ >bignum t "foldable" set-word-prop
 
-\ >float [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ >float { real } { float } <effect> "infer-effect" set-word-prop
 \ >float t "foldable" set-word-prop
 
-\ (fraction>) [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop
+\ (fraction>) { integer integer } { rational } <effect> "infer-effect" set-word-prop
 \ (fraction>) t "foldable" set-word-prop
 
-\ string>float [ [ string ] [ float ] ] "infer-effect" set-word-prop
+\ string>float { string } { float } <effect> "infer-effect" set-word-prop
 \ string>float t "foldable" set-word-prop
 
-\ float>string [ [ float ] [ string ] ] "infer-effect" set-word-prop
+\ float>string { float } { string } <effect> "infer-effect" set-word-prop
 \ float>string t "foldable" set-word-prop
 
-\ float>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop
+\ float>bits { real } { integer } <effect> "infer-effect" set-word-prop
 \ float>bits t "foldable" set-word-prop
 
-\ double>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop
+\ double>bits { real } { integer } <effect> "infer-effect" set-word-prop
 \ double>bits t "foldable" set-word-prop
 
-\ bits>float [ [ integer ] [ float ] ] "infer-effect" set-word-prop
+\ bits>float { integer } { float } <effect> "infer-effect" set-word-prop
 \ bits>float t "foldable" set-word-prop
 
-\ bits>double [ [ integer ] [ float ] ] "infer-effect" set-word-prop
+\ bits>double { integer } { float } <effect> "infer-effect" set-word-prop
 \ bits>double t "foldable" set-word-prop
 
-\ <complex> [ [ real real ] [ number ] ] "infer-effect" set-word-prop
+\ <complex> { real real } { number } <effect> "infer-effect" set-word-prop
 \ <complex> t "foldable" set-word-prop
 
-\ fixnum+ [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ fixnum+ { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
 \ fixnum+ t "foldable" set-word-prop
 
-\ fixnum+fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum+fast { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
 \ fixnum+fast t "foldable" set-word-prop
 
-\ fixnum- [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ fixnum- { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
 \ fixnum- t "foldable" set-word-prop
 
-\ fixnum-fast [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-fast { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
 \ fixnum-fast t "foldable" set-word-prop
 
-\ fixnum* [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ fixnum* { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
 \ fixnum* t "foldable" set-word-prop
 
-\ fixnum/i [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ fixnum/i { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
 \ fixnum/i t "foldable" set-word-prop
 
-\ fixnum/f [ [ fixnum fixnum ] [ float ] ] "infer-effect" set-word-prop
+\ fixnum/f { fixnum fixnum } { float } <effect> "infer-effect" set-word-prop
 \ fixnum/f t "foldable" set-word-prop
 
-\ fixnum-mod [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-mod { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
 \ fixnum-mod t "foldable" set-word-prop
 
-\ fixnum/mod [ [ fixnum fixnum ] [ integer fixnum ] ] "infer-effect" set-word-prop
+\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> "infer-effect" set-word-prop
 \ fixnum/mod t "foldable" set-word-prop
 
-\ fixnum-bitand [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
 \ fixnum-bitand t "foldable" set-word-prop
 
-\ fixnum-bitor [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
 \ fixnum-bitor t "foldable" set-word-prop
 
-\ fixnum-bitxor [ [ fixnum fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
 \ fixnum-bitxor t "foldable" set-word-prop
 
-\ fixnum-bitnot [ [ fixnum ] [ fixnum ] ] "infer-effect" set-word-prop
+\ fixnum-bitnot { fixnum } { fixnum } <effect> "infer-effect" set-word-prop
 \ fixnum-bitnot t "foldable" set-word-prop
 
-\ fixnum-shift [ [ fixnum fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ fixnum-shift { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
 \ fixnum-shift t "foldable" set-word-prop
 
-\ bignum= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
+\ bignum= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
 \ bignum= t "foldable" set-word-prop
 
-\ bignum+ [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum+ { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
 \ bignum+ t "foldable" set-word-prop
 
-\ bignum- [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum- { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
 \ bignum- t "foldable" set-word-prop
 
-\ bignum* [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum* { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
 \ bignum* t "foldable" set-word-prop
 
-\ bignum/i [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum/i { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
 \ bignum/i t "foldable" set-word-prop
 
-\ bignum/f [ [ bignum bignum ] [ float ] ] "infer-effect" set-word-prop
+\ bignum/f { bignum bignum } { float } <effect> "infer-effect" set-word-prop
 \ bignum/f t "foldable" set-word-prop
 
-\ bignum-mod [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-mod { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
 \ bignum-mod t "foldable" set-word-prop
 
-\ bignum/mod [ [ bignum bignum ] [ bignum bignum ] ] "infer-effect" set-word-prop
+\ bignum/mod { bignum bignum } { bignum bignum } <effect> "infer-effect" set-word-prop
 \ bignum/mod t "foldable" set-word-prop
 
-\ bignum-bitand [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-bitand { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
 \ bignum-bitand t "foldable" set-word-prop
 
-\ bignum-bitor [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-bitor { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
 \ bignum-bitor t "foldable" set-word-prop
 
-\ bignum-bitxor [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-bitxor { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
 \ bignum-bitxor t "foldable" set-word-prop
 
-\ bignum-bitnot [ [ bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-bitnot { bignum } { bignum } <effect> "infer-effect" set-word-prop
 \ bignum-bitnot t "foldable" set-word-prop
 
-\ bignum-shift [ [ bignum bignum ] [ bignum ] ] "infer-effect" set-word-prop
+\ bignum-shift { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
 \ bignum-shift t "foldable" set-word-prop
 
-\ bignum< [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
+\ bignum< { bignum bignum } { object } <effect> "infer-effect" set-word-prop
 \ bignum< t "foldable" set-word-prop
 
-\ bignum<= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
+\ bignum<= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
 \ bignum<= t "foldable" set-word-prop
 
-\ bignum> [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
+\ bignum> { bignum bignum } { object } <effect> "infer-effect" set-word-prop
 \ bignum> t "foldable" set-word-prop
 
-\ bignum>= [ [ bignum bignum ] [ object ] ] "infer-effect" set-word-prop
+\ bignum>= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
 \ bignum>= t "foldable" set-word-prop
 
-\ float+ [ [ float float ] [ float ] ] "infer-effect" set-word-prop
+\ float+ { float float } { float } <effect> "infer-effect" set-word-prop
 \ float+ t "foldable" set-word-prop
 
-\ float- [ [ float float ] [ float ] ] "infer-effect" set-word-prop
+\ float- { float float } { float } <effect> "infer-effect" set-word-prop
 \ float- t "foldable" set-word-prop
 
-\ float* [ [ float float ] [ float ] ] "infer-effect" set-word-prop
+\ float* { float float } { float } <effect> "infer-effect" set-word-prop
 \ float* t "foldable" set-word-prop
 
-\ float/f [ [ float float ] [ float ] ] "infer-effect" set-word-prop
+\ float/f { float float } { float } <effect> "infer-effect" set-word-prop
 \ float/f t "foldable" set-word-prop
 
-\ float< [ [ float float ] [ object ] ] "infer-effect" set-word-prop
+\ float< { float float } { object } <effect> "infer-effect" set-word-prop
 \ float< t "foldable" set-word-prop
 
-\ float-mod [ [ float float ] [ float ] ] "infer-effect" set-word-prop
+\ float-mod { float float } { float } <effect> "infer-effect" set-word-prop
 \ float-mod t "foldable" set-word-prop
 
-\ float<= [ [ float float ] [ object ] ] "infer-effect" set-word-prop
+\ float<= { float float } { object } <effect> "infer-effect" set-word-prop
 \ float<= t "foldable" set-word-prop
 
-\ float> [ [ float float ] [ object ] ] "infer-effect" set-word-prop
+\ float> { float float } { object } <effect> "infer-effect" set-word-prop
 \ float> t "foldable" set-word-prop
 
-\ float>= [ [ float float ] [ object ] ] "infer-effect" set-word-prop
+\ float>= { float float } { object } <effect> "infer-effect" set-word-prop
 \ float>= t "foldable" set-word-prop
 
-\ facos [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ facos { real } { float } <effect> "infer-effect" set-word-prop
 \ facos t "foldable" set-word-prop
 
-\ fasin [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fasin { real } { float } <effect> "infer-effect" set-word-prop
 \ fasin t "foldable" set-word-prop
 
-\ fatan [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fatan { real } { float } <effect> "infer-effect" set-word-prop
 \ fatan t "foldable" set-word-prop
 
-\ fatan2 [ [ real real ] [ float ] ] "infer-effect" set-word-prop
+\ fatan2 { real real } { float } <effect> "infer-effect" set-word-prop
 \ fatan2 t "foldable" set-word-prop
 
-\ fcos [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fcos { real } { float } <effect> "infer-effect" set-word-prop
 \ fcos t "foldable" set-word-prop
 
-\ fexp [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fexp { real } { float } <effect> "infer-effect" set-word-prop
 \ fexp t "foldable" set-word-prop
 
-\ fcosh [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fcosh { real } { float } <effect> "infer-effect" set-word-prop
 \ fcosh t "foldable" set-word-prop
 
-\ flog [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ flog { real } { float } <effect> "infer-effect" set-word-prop
 \ flog t "foldable" set-word-prop
 
-\ fpow [ [ real real ] [ float ] ] "infer-effect" set-word-prop
+\ fpow { real real } { float } <effect> "infer-effect" set-word-prop
 \ fpow t "foldable" set-word-prop
 
-\ fsin [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fsin { real } { float } <effect> "infer-effect" set-word-prop
 \ fsin t "foldable" set-word-prop
 
-\ fsinh [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fsinh { real } { float } <effect> "infer-effect" set-word-prop
 \ fsinh t "foldable" set-word-prop
 
-\ fsqrt [ [ real ] [ float ] ] "infer-effect" set-word-prop
+\ fsqrt { real } { float } <effect> "infer-effect" set-word-prop
 \ fsqrt t "foldable" set-word-prop
 
-\ (word) [ [ object object ] [ word ] ] "infer-effect" set-word-prop
+\ (word) { object object } { word } <effect> "infer-effect" set-word-prop
 
-\ update-xt [ [ word ] [ ] ] "infer-effect" set-word-prop
+\ update-xt { word } { } <effect> "infer-effect" set-word-prop
-\ compiled? [ [ word ] [ object ] ] "infer-effect" set-word-prop
+\ compiled? { word } { object } <effect> "infer-effect" set-word-prop
 
-\ getenv [ [ fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ getenv { fixnum } { object } <effect> "infer-effect" set-word-prop
-\ setenv [ [ object fixnum ] [ ] ] "infer-effect" set-word-prop
+\ setenv { object fixnum } { } <effect> "infer-effect" set-word-prop
-\ stat [ [ string ] [ object ] ] "infer-effect" set-word-prop
+\ stat { string } { object } <effect> "infer-effect" set-word-prop
-\ (directory) [ [ string ] [ array ] ] "infer-effect" set-word-prop
+\ (directory) { string } { array } <effect> "infer-effect" set-word-prop
-\ gc [ [ integer ] [ ] ] "infer-effect" set-word-prop
+\ gc { integer } { } <effect> "infer-effect" set-word-prop
-\ gc-time [ [ ] [ integer ] ] "infer-effect" set-word-prop
+\ gc-time { } { integer } <effect> "infer-effect" set-word-prop
-\ save-image [ [ string ] [ ] ] "infer-effect" set-word-prop
+\ save-image { string } { } <effect> "infer-effect" set-word-prop
-\ exit [ [ integer ] [ ] ] "infer-effect" set-word-prop
+\ exit { integer } { } <effect> "infer-effect" set-word-prop
-\ room [ [ ] [ integer integer integer integer array ] ] "infer-effect" set-word-prop
+\ room { } { integer integer integer integer array } <effect> "infer-effect" set-word-prop
-\ os-env [ [ string ] [ object ] ] "infer-effect" set-word-prop
+\ os-env { string } { object } <effect> "infer-effect" set-word-prop
-\ millis [ [ ] [ integer ] ] "infer-effect" set-word-prop
+\ millis { } { integer } <effect> "infer-effect" set-word-prop
 
-\ type [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
+\ type { object } { fixnum } <effect> "infer-effect" set-word-prop
 \ type t "foldable" set-word-prop
 
-\ tag [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
+\ tag { object } { fixnum } <effect> "infer-effect" set-word-prop
 \ tag t "foldable" set-word-prop
 
-\ cwd [ [ ] [ string ] ] "infer-effect" set-word-prop
+\ cwd { } { string } <effect> "infer-effect" set-word-prop
-\ cd [ [ string ] [ ] ] "infer-effect" set-word-prop
+\ cd { string } { } <effect> "infer-effect" set-word-prop
 
-\ add-compiled-block [ [ vector vector vector integer ] [ integer ] ] "infer-effect" set-word-prop
+\ add-compiled-block { vector vector vector integer } { integer } <effect> "infer-effect" set-word-prop
 
-\ dlopen [ [ string ] [ dll ] ] "infer-effect" set-word-prop
+\ dlopen { string } { dll } <effect> "infer-effect" set-word-prop
-\ dlsym [ [ string object ] [ integer ] ] "infer-effect" set-word-prop
+\ dlsym { string object } { integer } <effect> "infer-effect" set-word-prop
-\ dlclose [ [ dll ] [ ] ] "infer-effect" set-word-prop
+\ dlclose { dll } { } <effect> "infer-effect" set-word-prop
 
-\ <byte-array> [ [ integer ] [ byte-array ] ] "infer-effect" set-word-prop
+\ <byte-array> { integer } { byte-array } <effect> "infer-effect" set-word-prop
 
-\ <displaced-alien> [ [ integer c-ptr ] [ c-ptr ] ] "infer-effect" set-word-prop
+\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> "infer-effect" set-word-prop
 
-\ alien-signed-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-signed-cell { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
 
-\ set-alien-signed-cell [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-unsigned-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
 
-\ set-alien-unsigned-cell [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-signed-8 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-signed-8 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
 
-\ set-alien-signed-8 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-unsigned-8 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
 
-\ set-alien-unsigned-8 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-signed-4 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-signed-4 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
 
-\ set-alien-signed-4 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-unsigned-4 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
 
-\ set-alien-unsigned-4 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-signed-2 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-signed-2 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
 
-\ set-alien-signed-2 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-unsigned-2 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-unsigned-2 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
 
-\ set-alien-unsigned-2 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-signed-1 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-signed-1 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
 
-\ set-alien-signed-1 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-unsigned-1 [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-unsigned-1 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
 
-\ set-alien-unsigned-1 [ [ integer c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-float [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
+\ alien-float { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
 
-\ set-alien-float [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-float { float c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-float [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
+\ alien-float { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
 
-\ set-alien-double [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ set-alien-double { float c-ptr integer } { } <effect> "infer-effect" set-word-prop
-\ alien-double [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
+\ alien-double { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
 
-\ alien>char-string [ [ c-ptr ] [ string ] ] "infer-effect" set-word-prop
+\ alien>char-string { c-ptr } { string } <effect> "infer-effect" set-word-prop
 
-\ string>char-alien [ [ string ] [ byte-array ] ] "infer-effect" set-word-prop
+\ string>char-alien { string } { byte-array } <effect> "infer-effect" set-word-prop
 
-\ alien>u16-string [ [ c-ptr ] [ string ] ] "infer-effect" set-word-prop
+\ alien>u16-string { c-ptr } { string } <effect> "infer-effect" set-word-prop
 
-\ string>u16-alien [ [ string ] [ byte-array ] ] "infer-effect" set-word-prop
+\ string>u16-alien { string } { byte-array } <effect> "infer-effect" set-word-prop
 
-\ string>memory [ [ string integer ] [ ] ] "infer-effect" set-word-prop
+\ string>memory { string integer } { } <effect> "infer-effect" set-word-prop
-\ memory>string [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
+\ memory>string { integer integer } { string } <effect> "infer-effect" set-word-prop
 
-\ alien-address [ [ alien ] [ integer ] ] "infer-effect" set-word-prop
+\ alien-address { alien } { integer } <effect> "infer-effect" set-word-prop
 
-\ slot [ [ object fixnum ] [ object ] ] "infer-effect" set-word-prop
+\ slot { object fixnum } { object } <effect> "infer-effect" set-word-prop
 
-\ set-slot [ [ object object fixnum ] [ ] ] "infer-effect" set-word-prop
+\ set-slot { object object fixnum } { } <effect> "infer-effect" set-word-prop
 
-\ integer-slot [ [ object fixnum ] [ integer ] ] "infer-effect" set-word-prop
+\ integer-slot { object fixnum } { integer } <effect> "infer-effect" set-word-prop
 
-\ set-integer-slot [ [ integer object fixnum ] [ ] ] "infer-effect" set-word-prop
+\ set-integer-slot { integer object fixnum } { } <effect> "infer-effect" set-word-prop
 
-\ char-slot [ [ fixnum object ] [ fixnum ] ] "infer-effect" set-word-prop
+\ char-slot { fixnum object } { fixnum } <effect> "infer-effect" set-word-prop
 
-\ set-char-slot [ [ fixnum fixnum object ] [ ] ] "infer-effect" set-word-prop
+\ set-char-slot { fixnum fixnum object } { } <effect> "infer-effect" set-word-prop
-\ resize-array [ [ integer array ] [ array ] ] "infer-effect" set-word-prop
+\ resize-array { integer array } { array } <effect> "infer-effect" set-word-prop
-\ resize-string [ [ integer string ] [ string ] ] "infer-effect" set-word-prop
+\ resize-string { integer string } { string } <effect> "infer-effect" set-word-prop
 
-\ (hashtable) [ [ ] [ hashtable ] ] "infer-effect" set-word-prop
+\ (hashtable) { } { hashtable } <effect> "infer-effect" set-word-prop
 
-\ <array> [ [ integer object ] [ array ] ] "infer-effect" set-word-prop
+\ <array> { integer object } { array } <effect> "infer-effect" set-word-prop
 
-\ <tuple> [ [ integer word ] [ tuple ] ] "infer-effect" set-word-prop
+\ <tuple> { integer word } { tuple } <effect> "infer-effect" set-word-prop
 
-\ begin-scan [ [ ] [ ] ] "infer-effect" set-word-prop
+\ begin-scan { } { } <effect> "infer-effect" set-word-prop
-\ next-object [ [ ] [ object ] ] "infer-effect" set-word-prop
+\ next-object { } { object } <effect> "infer-effect" set-word-prop
-\ end-scan [ [ ] [ ] ] "infer-effect" set-word-prop
+\ end-scan { } { } <effect> "infer-effect" set-word-prop
 
-\ size [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop
+\ size { object } { fixnum } <effect> "infer-effect" set-word-prop
 
-\ die [ [ ] [ ] ] "infer-effect" set-word-prop
+\ die { } { } <effect> "infer-effect" set-word-prop
-\ fopen [ [ string string ] [ alien ] ] "infer-effect" set-word-prop
+\ fopen { string string } { alien } <effect> "infer-effect" set-word-prop
-\ fgetc [ [ alien ] [ object ] ] "infer-effect" set-word-prop
+\ fgetc { alien } { object } <effect> "infer-effect" set-word-prop
-\ fwrite [ [ string alien ] [ ] ] "infer-effect" set-word-prop
+\ fwrite { string alien } { } <effect> "infer-effect" set-word-prop
-\ fflush [ [ alien ] [ ] ] "infer-effect" set-word-prop
+\ fflush { alien } { } <effect> "infer-effect" set-word-prop
-\ fclose [ [ alien ] [ ] ] "infer-effect" set-word-prop
+\ fclose { alien } { } <effect> "infer-effect" set-word-prop
-\ expired? [ [ object ] [ object ] ] "infer-effect" set-word-prop
+\ expired? { object } { object } <effect> "infer-effect" set-word-prop
 
-\ <wrapper> [ [ object ] [ wrapper ] ] "infer-effect" set-word-prop
+\ <wrapper> { object } { wrapper } <effect> "infer-effect" set-word-prop
 \ <wrapper> t "foldable" set-word-prop
 
-\ (clone) [ [ object ] [ object ] ] "infer-effect" set-word-prop
+\ (clone) { object } { object } <effect> "infer-effect" set-word-prop
 
-\ array>tuple [ [ array ] [ tuple ] ] "infer-effect" set-word-prop
+\ array>tuple { array } { tuple } <effect> "infer-effect" set-word-prop
 
-\ tuple>array [ [ tuple ] [ array ] ] "infer-effect" set-word-prop
+\ tuple>array { tuple } { array } <effect> "infer-effect" set-word-prop
 
-\ array>vector [ [ array ] [ vector ] ] "infer-effect" set-word-prop
+\ array>vector { array } { vector } <effect> "infer-effect" set-word-prop
 
-\ finalize-compile [ [ array ] [ ] ] "infer-effect" set-word-prop
+\ finalize-compile { array } { } <effect> "infer-effect" set-word-prop
 
-\ <string> [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
+\ <string> { integer integer } { string } <effect> "infer-effect" set-word-prop
 
-\ <quotation> [ [ integer ] [ quotation ] ] "infer-effect" set-word-prop
+\ <quotation> { integer } { quotation } <effect> "infer-effect" set-word-prop

library/compiler/inference/shuffle.factor

@@ -51,7 +51,7 @@ TUPLE: shuffle in-d in-r out-d out-r ;
     #! the shuffle.
     [ split-shuffle ] keep shuffle* join-shuffle ;
 
-M: shuffle clone ( shuffle -- shuffle )
+M: shuffle clone
     [ shuffle-in-d clone ] keep
     [ shuffle-in-r clone ] keep
     [ shuffle-out-d clone ] keep

library/compiler/inference/stack.factor

@@ -1,6 +1,6 @@
 IN: inference
 USING: arrays generic interpreter kernel math namespaces
-sequences words ;
+sequences words parser ;
 
 : infer-shuffle-inputs ( shuffle node -- )
     >r dup shuffle-in-d length swap shuffle-in-r length r>
@@ -22,8 +22,7 @@ sequences words ;
     node, ;
 
 : shuffle>effect ( shuffle -- effect )
-    dup shuffle-in-d [ drop object ] map
+    dup shuffle-in-d swap shuffle-out-d <effect> ;
-    swap shuffle-out-d [ drop object ] map 2array ;
 
 : define-shuffle ( word shuffle -- )
     [ shuffle>effect "infer-effect" set-word-prop ] 2keep

library/compiler/inference/words.factor

@@ -18,16 +18,16 @@ IN: inference
     #! Add a node to the dataflow graph that consumes and
     #! produces a number of values.
     swap #call
-    over first length over consume-values
+    over effect-in length over consume-values
-    swap second length over produce-values
+    over effect-out length over produce-values
-    node, ;
+    node, effect-terminated? [ terminate ] when ;
 
 : no-effect ( word -- )
     "Stack effect inference of the word " swap word-name
     " was already attempted, and failed" append3
     inference-error ;
 
-TUPLE: rstate label base-case? ;
+TUPLE: rstate label count ;
 
 : nest-node ( -- ) #entry node, ;
 
@@ -35,10 +35,10 @@ TUPLE: rstate label base-case? ;
     dup node-param #return node,
     dataflow-graph get 1array over set-node-children ;
 
-: add-recursive-state ( word label base-case -- )
+: add-recursive-state ( word label count -- )
     <rstate> 2array recursive-state [ swap add ] change ;
 
-: inline-block ( word base-case -- node-block variables )
+: inline-block ( word count -- node-block variables )
     [
         copy-inference nest-node
         >r gensym 2dup r> add-recursive-state
@@ -52,9 +52,9 @@ TUPLE: rstate label base-case? ;
 
 GENERIC: collect-recursion* ( label node -- )
 
-M: node collect-recursion* ( label node -- ) 2drop ;
+M: node collect-recursion* 2drop ;
 
-M: #call-label collect-recursion* ( label node -- )
+M: #call-label collect-recursion*
     tuck node-param eq? [ node-in-d , ] [ drop ] if ;
 
 : collect-recursion ( #label -- seq )
@@ -84,15 +84,15 @@ M: #call-label collect-recursion* ( label node -- )
     #! closure under recursive value substitution.
     #! If the block does not call itself, there is no point in
     #! having the block node in the IR. Just add its contents.
-    dup f inline-block over recursive-label? [
+    dup 0 inline-block over recursive-label? [
         meta-d get >r
-        drop join-values f inline-block apply-infer
+        drop join-values 0 inline-block apply-infer
         r> over set-node-in-d node,
     ] [
         apply-infer node-child node-successor splice-node drop
     ] if ;
 
-: infer-compound ( word base-case -- terminates? effect )
+: infer-compound ( word count -- effect )
     #! Infer a word's stack effect in a separate inferencer
     #! instance. Outputs a true boolean if the word terminates
     #! control flow by throwing an exception or restoring a
@@ -100,22 +100,29 @@ M: #call-label collect-recursion* ( label node -- )
     [
         recursive-state get init-inference
         over >r inline-block nip
-        [ terminated? get effect ] bind r>
+        [ current-effect ] bind r>
-    ] with-scope over consume/produce over [ terminate ] when ;
+    ] with-scope over consume/produce ;
 
 GENERIC: apply-word
 
-M: object apply-word ( word -- )
+M: object apply-word
     #! A primitive with an unknown stack effect.
     no-effect ;
 
-: save-effect ( word terminates effect prop -- )
+TUPLE: effect-error word effect ;
-    rot [ 3drop ] [ set-word-prop ] if ;
 
-M: compound apply-word ( word -- )
+: effect-error ( -- * ) <effect-error> throw ;
+
+: check-effect ( word effect -- )
+    over recorded get push
+    dup pick "declared-effect" word-prop dup
+    [ effect<= [ effect-error ] unless ] [ 2drop ] if
+    "infer-effect" set-word-prop ;
+
+M: compound apply-word
     #! Infer a compound word's stack effect.
     [
-        dup f infer-compound "infer-effect" save-effect
+        dup 0 infer-compound check-effect
     ] [
         swap t "no-effect" set-word-prop rethrow
     ] recover ;
@@ -124,7 +131,7 @@ M: compound apply-word ( word -- )
     dup "no-effect" word-prop [ no-effect ] when
     dup "infer-effect" word-prop [
         over "infer" word-prop [
-            swap first length ensure-values call drop
+            swap effect-in length ensure-values call drop
         ] [
             consume/produce
         ] if*
@@ -132,46 +139,28 @@ M: compound apply-word ( word -- )
         apply-word
     ] if* ;
 
-M: word apply-object ( word -- )
+M: word apply-object apply-default ;
-    apply-default ;
 
-M: symbol apply-object ( word -- )
+M: symbol apply-object apply-literal ;
-    apply-literal ;
 
-: inline-base-case ( word label -- )
+: declared-effect ( word -- effect )
-    meta-d get clone >r over t inline-block apply-infer drop
+    dup "declared-effect" word-prop [ ] [
-    [ #call-label ] [ #call ] ?if r> over set-node-in-d node, ;
+        "The recursive word " swap word-name
+        " does not declare a stack effect" append3
+        inference-error
+    ] ?if ;
 
-: base-case ( word label -- )
+: recursive-effect ( word -- effect )
-    over "inline" word-prop [
-        inline-base-case
-    ] [
-        drop dup t infer-compound "base-case" save-effect
-    ] if ;
-
-: recursive-word ( word rstate -- )
     #! Handle a recursive call, by either applying a previously
     #! inferred base case, or raising an error. If the recursive
     #! call is to a local block, emit a label call node.
-    over "infer-effect" word-prop [
+    dup "infer-effect" word-prop [ ] [ declared-effect ] if ;
-        nip consume/produce
-    ] [
-        over "base-case" word-prop [
-            nip consume/produce
-        ] [
-            dup rstate-base-case? [
-                notify-base-case
-            ] [
-                rstate-label base-case
-            ] if
-        ] if*
-    ] if* ;
 
-M: compound apply-object ( word -- )
+M: compound apply-object
     #! Apply the word's stack effect to the inferencer state.
     dup recursive-state get <reversed> assoc [
-        recursive-word
+        dup recursive-effect consume/produce
     ] [
         dup "inline" word-prop
         [ inline-closure ] [ apply-default ] if
-    ] if* ;
+    ] if ;

library/compiler/optimizer/call-optimizers.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
 USING: arrays errors generic hashtables inference kernel
-math math-internals sequences words ;
+math math-internals sequences words parser ;
 
 ! A system for associating dataflow optimizers with words.
 
@@ -58,7 +58,8 @@ math math-internals sequences words ;
 
 : useless-coerce? ( node -- )
     dup 0 node-class#
-    swap node-param "infer-effect" word-prop second first eq? ;
+    swap node-param "infer-effect" word-prop effect-out first
+    eq? ;
 
 { >fixnum >bignum >float } [
     {
@@ -171,7 +172,7 @@ SYMBOL: @
     { { @ @ } [ 2drop t ] }
 } define-identities
 
-M: #call optimize-node* ( node -- node/t )
+M: #call optimize-node*
     {
         { [ dup partial-eval? ] [ partial-eval ] }
         { [ dup find-identity nip ] [ apply-identities ] }

library/compiler/optimizer/class-infer.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
 USING: arrays generic hashtables inference kernel
-kernel-internals math namespaces sequences words ;
+kernel-internals math namespaces sequences words parser ;
 
 ! Infer possible classes of values in a dataflow IR.
 : node-class# ( node n -- class )
@@ -21,7 +21,7 @@ SYMBOL: ties
 
 GENERIC: apply-tie ( tie -- )
 
-M: f apply-tie ( f -- ) drop ;
+M: f apply-tie drop ;
 
 TUPLE: class-tie value class ;
 
@@ -29,7 +29,7 @@ TUPLE: class-tie value class ;
     2dup swap <class-tie> ties get hash [ apply-tie ] when*
     value-classes get set-hash ;
 
-M: class-tie apply-tie ( tie -- )
+M: class-tie apply-tie
     dup class-tie-class swap class-tie-value
     set-value-class* ;
 
@@ -40,18 +40,18 @@ TUPLE: literal-tie value literal ;
     2dup swap <literal-tie> ties get hash [ apply-tie ] when*
     value-literals get set-hash ;
 
-M: literal-tie apply-tie ( tie -- )
+M: literal-tie apply-tie
     dup literal-tie-literal swap literal-tie-value
     set-value-literal* ;
 
 GENERIC: infer-classes* ( node -- )
 
-M: node infer-classes* ( node -- ) drop ;
+M: node infer-classes* drop ;
 
 ! For conditionals, a map of child node # --> possibility
 GENERIC: child-ties ( node -- seq )
 
-M: node child-ties ( node -- seq )
+M: node child-ties
     node-children length f <array> ;
 
 : value-class* ( value -- class )
@@ -119,27 +119,27 @@ M: node child-ties ( node -- seq )
     dup node-param "output-classes" word-prop [
         call
     ] [
-        node-param "infer-effect" word-prop second
+        node-param "infer-effect" word-prop effect-out
-        dup integer? [ drop f ] when
+        dup [ word? ] all? [ drop f ] unless
     ] if* ;
 
-M: #call infer-classes* ( node -- )
+M: #call infer-classes*
     dup create-ties dup output-classes
     [ swap node-out-d intersect-classes ] [ drop ] if* ;
 
-M: #push infer-classes* ( node -- )
+M: #push infer-classes*
     node-out-d
     [ [ value-literal ] keep set-value-literal* ] each ;
 
-M: #if child-ties ( node -- seq )
+M: #if child-ties
     node-in-d first dup general-t <class-tie>
     swap f <literal-tie> 2array ;
 
-M: #dispatch child-ties ( node -- seq )
+M: #dispatch child-ties
     dup node-in-d first
     swap node-children length [ <literal-tie> ] map-with ;
 
-M: #declare infer-classes* ( node -- )
+M: #declare infer-classes*
     dup node-param swap node-in-d [ set-value-class* ] 2each ;
 
 DEFER: (infer-classes)

library/compiler/optimizer/kill-literals.factor

@@ -34,16 +34,16 @@ GENERIC: live-values* ( node -- seq )
     dup live-values over literals hash-diff swap kill-node ;
 
 ! Generic nodes
-M: node literals* ( node -- ) drop { } ;
+M: node literals* drop { } ;
 
-M: node live-values* ( node -- seq )
+M: node live-values*
     node-in-d [ value? ] subset ;
 
 ! #push
-M: #push literals* ( node -- seq ) node-out-d ;
+M: #push literals* node-out-d ;
 
 ! #return
-M: #return live-values* ( node -- seq )
+M: #return live-values*
     #! Values returned by local labels can be killed.
     dup node-param [ drop { } ] [ delegate live-values* ] if ;
 
@@ -51,7 +51,7 @@ M: #return live-values* ( node -- seq )
 UNION: #killable
     #push #shuffle #call-label #merge #values #entry ;
 
-M: #killable live-values* ( node -- seq ) drop { } ;
+M: #killable live-values* drop { } ;
 
 : purge-invariants ( stacks -- seq )
     #! Output a sequence of values which are not present in the
@@ -59,14 +59,14 @@ M: #killable live-values* ( node -- seq ) drop { } ;
     unify-lengths flip [ all-eq? not ] subset concat ;
 
 ! #label
-M: #label live-values* ( node -- seq )
+M: #label live-values*
     dup node-child node-in-d over node-in-d 2array
     swap collect-recursion append purge-invariants ;
 
 ! branching
 UNION: #branch #if #dispatch ;
 
-M: #branch live-values* ( node -- )
+M: #branch live-values*
     #! This assumes that the last element of each branch is a
     #! #return node.
     dup delegate live-values* >r

library/compiler/optimizer/optimizer.factor

@@ -31,18 +31,18 @@ GENERIC: optimize-node* ( node -- node/t )
 ! Generic nodes
 M: f optimize-node* drop t ;
 
-M: node optimize-node* ( node -- t ) drop t ;
+M: node optimize-node* drop t ;
 
 ! #shuffle
-M: #shuffle optimize-node*  ( node -- node/t )
+M: #shuffle optimize-node* 
     [ node-values empty? ] prune-if ;
 
 ! #push
-M: #push optimize-node*  ( node -- node/t )
+M: #push optimize-node* 
     [ node-out-d empty? ] prune-if ;
 
 ! #return
-M: #return optimize-node* ( node -- node/t )
+M: #return optimize-node*
     node-successor [ node-successor ] [ t ] if* ;
 
 ! Some utilities for splicing in dataflow IR subtrees
@@ -96,12 +96,12 @@ M: #return optimize-node* ( node -- node/t )
         } cond
     ] if ;
 
-M: #if optimize-node* ( node -- node/t )
+M: #if optimize-node*
     dup dup node-in-d first known-boolean-value?
     [ 0 1 ? fold-branch ] [ 2drop t ] if ;
 
 ! #dispatch
-M: #dispatch optimize-node* ( node -- node/t )
+M: #dispatch optimize-node*
     dup dup node-in-d first 2dup node-literal? [
         node-literal fold-branch
     ] [

library/compiler/optimizer/print-dataflow.factor

@@ -9,7 +9,7 @@ GENERIC: node>quot ( node -- )
 
 TUPLE: comment node text ;
 
-M: comment pprint* ( ann -- )
+M: comment pprint*
     "( " over comment-text " )" append3
     swap comment-node presented associate
     styled-text ;
@@ -36,10 +36,10 @@ M: comment pprint* ( ann -- )
         " r: " swap node-out-r values%
     ] "" make 1 tail ;
 
-M: #shuffle node>quot ( ? node -- )
+M: #shuffle node>quot
     >r drop t r> dup effect-str "#shuffle: " swap append comment, ;
 
-M: #push node>quot ( ? node -- ) nip >#push< % ;
+M: #push node>quot nip >#push< % ;
 
 DEFER: dataflow>quot
 
@@ -47,26 +47,26 @@ DEFER: dataflow>quot
     dup node-param dup
     [ , dup effect-str comment, ] [ 3drop ] if ;
 
-M: #call node>quot ( ? node -- ) #call>quot ;
+M: #call node>quot #call>quot ;
 
-M: #call-label node>quot ( ? node -- ) #call>quot ;
+M: #call-label node>quot #call>quot ;
 
-M: #label node>quot ( ? node -- )
+M: #label node>quot
     [ "#label: " over node-param word-name append comment, ] 2keep
     node-child swap dataflow>quot , \ call ,  ;
 
-M: #if node>quot ( ? node -- )
+M: #if node>quot
     [ "#if" comment, ] 2keep
     node-children [ swap dataflow>quot ] map-with % \ if , ;
 
-M: #dispatch node>quot ( ? node -- )
+M: #dispatch node>quot
     [ "#dispatch" comment, ] 2keep
     node-children [ swap dataflow>quot ] map-with , \ dispatch , ;
 
-M: #return node>quot ( ? node -- )
+M: #return node>quot
     dup node-param unparse "#return " swap append comment, ;
 
-M: object node>quot ( ? node -- ) dup class word-name comment, ;
+M: object node>quot dup class word-name comment, ;
 
 : (dataflow>quot) ( ? node -- )
     dup [

library/compiler/ppc/architecture.factor

@@ -30,10 +30,10 @@ GENERIC: loc>operand
 M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
 M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;
 
-M: immediate load-literal ( literal vreg -- )
+M: immediate load-literal
     [ v>operand ] 2apply LOAD ;
 
-M: object load-literal ( literal vreg -- )
+M: object load-literal
     v>operand
     [ 0 swap LOAD32 rel-absolute-2/2 rel-literal ] keep
     dup 0 LWZ ;
@@ -91,14 +91,14 @@ M: object load-literal ( literal vreg -- )
 : compile-dlsym ( symbol dll register -- )
     0 swap LOAD32 rel-absolute-2/2 rel-dlsym ;
 
-M: int-regs (%peek) ( vreg loc -- )
+M: int-regs (%peek)
     drop >r v>operand r> loc>operand LWZ ;
 
-M: float-regs (%peek) ( vreg loc -- )
+M: float-regs (%peek)
     drop fp-scratch v>operand swap loc>operand LWZ
     fp-scratch [ v>operand ] 2apply float-offset LFD ;
 
-M: int-regs (%replace) ( vreg loc -- )
+M: int-regs (%replace)
     drop >r v>operand r> loc>operand STW ;
 
 : %move-int>int ( dst src -- )
@@ -124,7 +124,7 @@ M: int-regs (%replace) ( vreg loc -- )
         r> call 12 12 \ size get call ADDI
     ] bind save-allot-ptr ; inline
 
-M: float-regs (%replace) ( vreg loc reg-class -- )
+M: float-regs (%replace)
     drop swap
     [ v>operand 12 8 STFD ]
     [ 11 swap loc>operand STW ] H{

library/compiler/x86/architecture.factor

@@ -87,13 +87,13 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
 
 : prepare-division CDQ ; inline
 
-M: immediate load-literal ( literal vreg -- )
+M: immediate load-literal
     v>operand swap v>operand MOV ;
 
 : load-indirect ( literal reg -- )
     0 [] MOV rel-absolute-cell rel-literal ;
 
-M: object load-literal ( literal vreg -- )
+M: object load-literal
     v>operand load-indirect ;
 
 : (%call) ( label -- label )
@@ -150,6 +150,6 @@ M: int-regs (%replace) drop swap %move-int>int ;
 
 : %inc-r ( n -- ) cs-reg (%inc) ;
 
-M: object %stack>freg ( n reg reg-class -- ) 3drop ;
+M: object %stack>freg 3drop ;
 
-M: object %freg>stack ( n reg reg-class -- ) 3drop ;
+M: object %freg>stack 3drop ;

library/compiler/x86/assembler.factor

@@ -140,7 +140,7 @@ C: indirect ( base index scale displacement -- indirect )
 
 GENERIC: sib-present?
 
-M: indirect sib-present? ( indirect -- ? )
+M: indirect sib-present?
     dup indirect-base { ESP RSP } memq?
     over indirect-index rot indirect-scale or or ;
 
@@ -148,11 +148,11 @@ M: register sib-present? drop f ;
 
 GENERIC: r/m
 
-M: indirect r/m ( indirect -- r/m )
+M: indirect r/m
     dup sib-present?
     [ drop ESP reg-code ] [ indirect-base* ] if ;
 
-M: register r/m ( reg -- r/m ) reg-code ;
+M: register r/m reg-code ;
 
 : byte? -128 127 between? ;
 
@@ -299,8 +299,8 @@ M: operand CALL BIN: 010 t HEX: ff 1-operand ;
 
 G: JUMPcc ( addr opcode -- ) 1 standard-combination ;
 : (JUMPcc) HEX: 0f , , 0 4, rel-relative ;
-M: callable JUMPcc ( addr opcode -- ) (JUMPcc) rel-word ;
+M: callable JUMPcc (JUMPcc) rel-word ;
-M: label JUMPcc ( addr opcode -- ) (JUMPcc) rel-label ;
+M: label JUMPcc (JUMPcc) rel-label ;
 
 : JO  HEX: 80 JUMPcc ;
 : JNO HEX: 81 JUMPcc ;

library/compiler/x86/intrinsics-sse2.factor

@@ -4,7 +4,7 @@ USING: alien arrays assembler generic kernel kernel-internals
 math math-internals memory namespaces sequences words ;
 IN: compiler
 
-M: float-regs (%peek) ( vreg loc reg-class -- )
+M: float-regs (%peek)
     drop
     fp-scratch swap %move-int>int
     fp-scratch %move-int>float ;
@@ -32,7 +32,7 @@ M: float-regs (%peek) ( vreg loc reg-class -- )
         alloc-tmp-reg POP
     ] bind ; inline
 
-M: float-regs (%replace) ( vreg loc reg-class -- )
+M: float-regs (%replace)
     drop
     [ alloc-tmp-reg 8 [+] rot v>operand MOVSD ]
     [ v>operand alloc-tmp-reg MOV ] H{

library/generic/classes.factor

@@ -123,7 +123,6 @@ SYMBOL: class<cache
 
 : define-class ( class -- )
     dup t "class" set-word-prop
-    dup H{ } clone "class<" set-word-prop
     dup flatten-class typemap get set-hash ;
 
 ! Predicate classes for generalized predicate dispatch.

library/generic/math-combination.factor

@@ -41,8 +41,8 @@ math namespaces sequences words ;
 
 TUPLE: no-math-method left right generic ;
 
-: no-math-method ( left right generic -- )
+: no-math-method ( left right generic -- * )
-    3dup <no-math-method> throw ;
+    <no-math-method> throw ;
 
 : applicable-method ( generic class -- quot )
     over method [ ] [ [ no-math-method ] curry ] ?if ;

library/generic/slots.factor

@@ -9,21 +9,29 @@ parser sequences strings words ;
     over define-generic -rot define-method ;
 
 : define-slot-word ( class slot word quot -- )
-    over [
+    rot >fixnum add* define-typecheck ;
-        rot >fixnum add* define-typecheck
+
+: reader-effect 1 1 <effect> ; inline
+
+: define-reader ( class slot decl reader -- )
+    dup [
+        dup reader-effect "declared-effect" set-word-prop
+        [ slot ] rot dup object eq?
+        [ drop ] [ 1array [ declare ] swap add* append ] if
+        define-slot-word
     ] [
         2drop 2drop
     ] if ;
 
-: define-reader ( class slot decl reader -- )
+: writer-effect 2 0 <effect> ; inline
-    [ slot ] rot dup object eq? [
-        drop
-    ] [
-        1array [ declare ] swap add* append
-    ] if define-slot-word ;
 
 : define-writer ( class slot writer -- )
-    [ set-slot ] define-slot-word ;
+    dup [
+        dup writer-effect "declared-effect" set-word-prop
+        [ set-slot ] define-slot-word
+    ] [
+        3drop
+    ] if ;
 
 : define-slot ( class slot decl reader writer -- )
     >r >r >r 2dup r> r> define-reader r> define-writer ;

library/generic/standard-combination.factor

@@ -12,7 +12,7 @@ IN: generic
 
 TUPLE: no-method object generic ;
 
-: no-method ( object generic -- ) <no-method> throw ;
+: no-method ( object generic -- * ) <no-method> throw ;
 
 : error-method ( dispatch# word -- method )
     >r picker r> [ no-method ] curry append ;

library/generic/tuple.factor

@@ -77,12 +77,12 @@ TUPLE: check-tuple class ;
     dup r> tuple-slots
     default-constructor ;
 
-M: tuple clone ( tuple -- tuple )
+M: tuple clone
     (clone) dup delegate clone over set-delegate ;
 
-M: tuple hashcode ( tuple -- n ) 2 slot hashcode ;
+M: tuple hashcode 2 slot hashcode ;
 
-M: tuple equal? ( obj tuple -- ? )
+M: tuple equal?
     over tuple? [ tuple= ] [ 2drop f ] if ;
 
 : (delegates) ( obj -- )

library/help/topics.factor

@@ -13,7 +13,7 @@ SYMBOL: articles
 TUPLE: article title content loc ;
 
 TUPLE: no-article name ;
-: no-article ( name -- ) <no-article> throw ;
+: no-article ( name -- * ) <no-article> throw ;
 
 : article ( name -- article )
     dup articles get hash [ ] [ no-article ] ?if ;

library/io/c-streams.factor

@@ -11,19 +11,19 @@ USING: errors kernel kernel-internals namespaces io strings ;
 
 TUPLE: c-stream in out ;
 
-M: c-stream stream-write1 ( char stream -- )
+M: c-stream stream-write1
     >r ch>string r> stream-write ;
 
-M: c-stream stream-write ( str stream -- )
+M: c-stream stream-write
     c-stream-out fwrite ;
 
-M: c-stream stream-read1 ( stream -- char/f )
+M: c-stream stream-read1
     c-stream-in dup [ fgetc ] when ;
 
-M: c-stream stream-flush ( stream -- )
+M: c-stream stream-flush
     c-stream-out [ fflush ] when* ;
 
-M: c-stream stream-close ( stream -- )
+M: c-stream stream-close
     dup c-stream-in [ fclose ] when*
     c-stream-out [ fclose ] when* ;
 
@@ -47,7 +47,7 @@ IN: io
 TUPLE: client-stream host port ;
 
 TUPLE: c-stream-error ;
-: c-stream-error <c-stream-error> throw ;
+: c-stream-error ( -- * ) <c-stream-error> throw ;
 
 : <client> c-stream-error ;
 : <server> c-stream-error ;

library/io/lines.factor

@@ -26,11 +26,11 @@ C: line-reader ( stream -- line ) [ set-delegate ] keep ;
         2drop
     ] if ;
 
-M: line-reader stream-readln ( line -- string )
+M: line-reader stream-readln
     [ f swap (readln) ] "" make
     dup empty? [ f ? ] [ nip ] if ;
 
-M: line-reader stream-read ( count line -- string )
+M: line-reader stream-read
     [ delegate stream-read ] keep dup cr> [
         over empty? [
             drop

library/io/nested-style.factor

@@ -31,7 +31,7 @@ M: nested-style-stream stream-write1
     3array >quotation
     r> r> do-nested-style ;
 
-M: nested-style-stream with-stream-style ( quot style stream -- )
+M: nested-style-stream with-stream-style
     do-nested-style with-stream-style ;
 
 M: nested-style-stream with-nested-stream

library/io/plain-stream.factor

@@ -10,11 +10,11 @@ C: plain-writer ( stream -- stream ) [ set-delegate ] keep ;
 
 M: plain-writer stream-terpri CHAR: \n swap stream-write1 ;
 
-M: plain-writer stream-format ( string style stream -- )
+M: plain-writer stream-format
     highlight rot hash [ >r >upper r> ] when stream-write ;
 
-M: plain-writer with-nested-stream ( quot style stream -- )
+M: plain-writer with-nested-stream
     nip swap with-stream* ;
 
-M: plain-writer with-stream-style ( quot style stream -- )
+M: plain-writer with-stream-style
     (with-stream-style) ;

library/io/string-streams.factor

@@ -26,7 +26,7 @@ M: sbuf stream-flush drop ;
     swap dup length <reversed>
     [ zero? rot [ call ] keep swap ] 2map nip ; inline
 
-M: plain-writer with-stream-table ( grid quot style stream -- )
+M: plain-writer with-stream-table
     [
         drop swap
         [ [ swap string-out ] map-with ] map-with
@@ -36,10 +36,10 @@ M: plain-writer with-stream-table ( grid quot style stream -- )
     ] with-stream* ;
 
 ! Reversed string buffers support the stream input protocol.
-M: sbuf stream-read1 ( sbuf -- char/f )
+M: sbuf stream-read1
     dup empty? [ drop f ] [ pop ] if ;
 
-M: sbuf stream-read ( count sbuf -- string )
+M: sbuf stream-read
     dup empty? [
         2drop f
     ] [

library/io/unix/io.factor

@@ -35,7 +35,7 @@ SYMBOL: write-tasks
 ! Some general stuff
 : file-mode OCT: 0600 ;
 
-: (io-error) err_no strerror throw ;
+: (io-error) ( -- * ) err_no strerror throw ;
 
 : check-null ( n -- ) zero? [ (io-error) ] when ;
 
@@ -69,7 +69,7 @@ C: port ( handle buffer -- port )
     dup port-timeout dup zero?
     [ 2drop ] [ millis + swap set-port-cutoff ] if ;
 
-M: port set-timeout ( timeout port -- )
+M: port set-timeout
     [ set-port-timeout ] keep touch-port ;
 
 : buffered-port 32768 <buffer> <port> ;
@@ -183,7 +183,7 @@ TUPLE: read1-task ;
 C: read1-task ( port -- task )
     [ >r <io-task> r> set-delegate ] keep ;
 
-M: read1-task do-io-task ( task -- ? )
+M: read1-task do-io-task
     io-task-port dup refill [
         [
             dup buffer-empty?
@@ -198,7 +198,7 @@ M: read1-task task-container drop read-tasks get-global ;
         [ swap <read1-task> add-io-task stop ] callcc0
     ] when pending-error ;
 
-M: input-port stream-read1 ( stream -- char/f )
+M: input-port stream-read1
     dup wait-to-read1
     dup port-eof? [ drop f ] [ buffer-pop ] if ;
 
@@ -222,7 +222,7 @@ C: read-task ( count port -- task )
 
 : >read-task< dup read-task-count swap io-task-port ;
 
-M: read-task do-io-task ( task -- ? )
+M: read-task do-io-task
     >read-task< dup refill [
         dup buffer-empty? [
             reader-eof drop t
@@ -240,7 +240,7 @@ M: read-task task-container drop read-tasks get-global ;
         [ -rot <read-task> add-io-task stop ] callcc0
     ] unless pending-error drop ;
 
-M: input-port stream-read ( count stream -- string )
+M: input-port stream-read
     [ wait-to-read ] keep dup port-eof?
     [ drop f ] [ port-sbuf >string ] if ;
 
@@ -287,19 +287,19 @@ M: write-task task-container drop write-tasks get-global ;
 : port-flush ( port -- )
     [ swap <write-task> add-write-io-task stop ] callcc0 drop ;
 
-M: output-port stream-flush ( stream -- )
+M: output-port stream-flush
     dup port-flush pending-error ;
 
 : wait-to-write ( len port -- )
     tuck can-write? [ drop ] [ stream-flush ] if ;
 
-M: output-port stream-write1 ( char writer -- )
+M: output-port stream-write1
     1 over wait-to-write ch>buffer ;
 
-M: output-port stream-write ( string writer -- )
+M: output-port stream-write
     over length over wait-to-write >buffer ;
 
-M: port stream-close ( stream -- )
+M: port stream-close
     dup port-type closed eq? [
         dup port-type >r closed over set-port-type r>
         output eq? [ dup port-flush ] when dup port-handle close

library/io/unix/sockets.factor

@@ -47,7 +47,7 @@ TUPLE: connect-task ;
 C: connect-task ( port -- task )
     [ >r <io-task> r> set-delegate ] keep ;
 
-M: connect-task do-io-task ( task -- )
+M: connect-task do-io-task
     io-task-port dup port-handle 0 0 write
     0 < [ defer-error ] [ drop t ] if ;
 
@@ -104,7 +104,7 @@ C: accept-task ( port -- task )
         swap sockaddr-in-port ntohs
     ] keep <client-stream> swap set-server-client ;
 
-M: accept-task do-io-task ( task -- ? )
+M: accept-task do-io-task
     io-task-port "sockaddr-in" <c-object>
     over port-handle over "sockaddr-in" c-size <int> accept
     dup 0 >= [

library/io/windows/errors.factor

@@ -24,6 +24,6 @@ USING: alien errors io-internals kernel math parser sequences words ;
 
 FUNCTION: char* error_message ( DWORD id ) ;
 
-: win32-throw-error ( -- )
+: win32-throw-error ( -- * )
     GetLastError error_message throw ;
 

library/io/windows/server.factor

@@ -65,13 +65,13 @@ C: win32-server ( port -- server )
         dup stream set
     ] make-hash over set-win32-server-this ;
 
-M: win32-server stream-close ( server -- )
+M: win32-server stream-close
     win32-server-this [ socket get CloseHandle drop ] bind ;
 
-M: win32-server set-timeout ( timeout server -- )
+M: win32-server set-timeout
     win32-server-this [ timeout set ] bind ;
 
-M: win32-server expire ( -- )
+M: win32-server expire
     win32-server-this [
         timeout get [ millis cutoff get > [ socket get CancelIo ] when ] when
     ] bind ;

library/io/windows/stream.factor

@@ -49,11 +49,11 @@ SYMBOL: cutoff
 : maybe-flush-output ( -- )
     out-buffer get buffer-length 0 > [ flush-output ] when ;
 
-M: integer do-write ( int -- )
+M: integer do-write
     out-buffer get [ buffer-capacity zero? [ flush-output ] when ] keep
     >r ch>string r> >buffer ;
 
-M: string do-write ( str -- )
+M: string do-write
     dup length out-buffer get buffer-capacity <= [
         out-buffer get >buffer
     ] [
@@ -97,30 +97,30 @@ M: string do-write ( str -- )
 : peek-input ( -- str )
     1 in-buffer get buffer-first-n ;
 
-M: win32-stream stream-write ( str stream -- )
+M: win32-stream stream-write
     win32-stream-this [ do-write ] bind ;
 
-M: win32-stream stream-write1 ( char stream -- )
+M: win32-stream stream-write1
     win32-stream-this [ >fixnum do-write ] bind ;
 
-M: win32-stream stream-read ( count stream -- str )
+M: win32-stream stream-read
     win32-stream-this [ dup <sbuf> swap do-read-count ] bind ;
 
-M: win32-stream stream-read1 ( stream -- str )
+M: win32-stream stream-read1
     win32-stream-this [
         1 consume-input dup length zero? [ drop f ] when first 
     ] bind ;
 
-M: win32-stream stream-readln ( stream -- str )
+M: win32-stream stream-readln
     win32-stream-this [ readln ] bind ;
 
 M: win32-stream stream-terpri
     win32-stream-this [ CHAR: \n do-write ] bind ;
 
-M: win32-stream stream-flush ( stream -- )
+M: win32-stream stream-flush
     win32-stream-this [ maybe-flush-output ] bind ;
 
-M: win32-stream stream-close ( stream -- )
+M: win32-stream stream-close
     win32-stream-this [
         maybe-flush-output
         handle get CloseHandle drop 
@@ -128,21 +128,21 @@ M: win32-stream stream-close ( stream -- )
         out-buffer get buffer-free
     ] bind ;
 
-M: win32-stream stream-format ( string style stream -- )
+M: win32-stream stream-format
     win32-stream-this [ drop do-write ] bind ;
 
-M: win32-stream win32-stream-handle ( stream -- handle )
+M: win32-stream win32-stream-handle
     win32-stream-this [ handle get ] bind ;
 
-M: win32-stream set-timeout ( timeout stream -- )
+M: win32-stream set-timeout
     win32-stream-this [ timeout set ] bind ;
 
-M: win32-stream expire ( stream -- )
+M: win32-stream expire
     win32-stream-this [
         timeout get [ millis cutoff get > [ handle get CancelIo ] when ] when
     ] bind ;
 
-M: win32-stream with-nested-stream ( quot style stream -- )
+M: win32-stream with-nested-stream
     win32-stream-this [ drop stream get swap with-stream* ] bind ;
 
 C: win32-stream ( handle -- stream )

library/math/complex.factor

@@ -13,7 +13,7 @@ UNION: number real complex ;
 M: real real ;
 M: real imaginary drop 0 ;
 
-M: number equal? ( n n -- ? ) number= ;
+M: number equal? number= ;
 
 : rect> ( xr xi -- x )
     over real? over real? and [
@@ -42,7 +42,7 @@ IN: math-internals
 : 2>rect ( x y -- xr yr xi yi )
     [ [ real ] 2apply ] 2keep [ imaginary ] 2apply ; inline
 
-M: complex number= ( x y -- ? )
+M: complex number=
     2>rect number= [ number= ] [ 2drop f ] if ;
 
 : *re ( x y -- xr*yr xi*ri ) 2>rect * >r * r> ; inline
@@ -50,16 +50,16 @@ M: complex number= ( x y -- ? )
 
 M: complex + 2>rect + >r + r> (rect>) ;
 M: complex - 2>rect - >r - r> (rect>) ;
-M: complex * ( x y -- x*y ) 2dup *re - -rot *im + (rect>) ;
+M: complex * 2dup *re - -rot *im + (rect>) ;
 
 : complex/ ( x y -- r i m )
     #! r = xr*yr+xi*yi, i = xi*yr-xr*yi, m = yr*yr+yi*yi
     dup absq >r 2dup *re + -rot *im - r> ; inline
 
-M: complex / ( x y -- x/y ) complex/ tuck / >r / r> (rect>) ;
+M: complex / complex/ tuck / >r / r> (rect>) ;
-M: complex /f ( x y -- x/y ) complex/ tuck /f >r /f r> (rect>) ;
+M: complex /f complex/ tuck /f >r /f r> (rect>) ;
 
-M: complex abs ( z -- |z| ) absq fsqrt ;
+M: complex abs absq fsqrt ;
 
-M: complex hashcode ( n -- n )
+M: complex hashcode
     >rect >fixnum swap >fixnum bitxor ;

library/math/float.factor

@@ -14,13 +14,13 @@ UNION: real rational float ;
 M: real abs dup 0 < [ neg ] when ;
 M: real absq sq ;
 
-M: real hashcode ( n -- n ) >fixnum ;
+M: real hashcode >fixnum ;
 M: real <=> - ;
 
 : fp-nan? ( float -- ? )
     double>bits -51 shift BIN: 111111111111 [ bitand ] keep = ;
 
-M: float zero? ( float -- ? )
+M: float zero?
     dup 0.0 float= swap -0.0 float= or ;
 
 M: float < float< ;

library/math/integer.factor

@@ -42,9 +42,9 @@ IN: math-internals
     dup 1 number= [ drop ] [ (fraction>) ] if ; inline
 
 TUPLE: /0 ;
-: /0 ( -- ) </0> throw ;
+: /0 ( -- * ) </0> throw ;
 
-M: integer / ( x y -- x/y )
+M: integer /
     dup zero? [
         /0
     ] [

library/math/parse-numbers.factor

@@ -6,7 +6,7 @@ strings ;
 
 DEFER: base>
 
-: string>ratio ( "a/b" radix -- a/b )
+: string>ratio ( str radix -- a/b )
     >r "/" split1 r> tuck base> >r base> r>
     2dup and [ / ] [ 2drop f ] if ;
 
@@ -51,7 +51,7 @@ M: object digit> drop f ;
 
 G: >base ( num radix -- string ) 1 standard-combination ;
 
-M: integer >base ( num radix -- string )
+M: integer >base
     [
         over 0 < [
             swap neg swap integer, CHAR: - ,
@@ -60,7 +60,7 @@ M: integer >base ( num radix -- string )
         ] if
     ] "" make reverse ;
 
-M: ratio >base ( num radix -- string )
+M: ratio >base
     [
         over numerator over >base %
         CHAR: / ,
@@ -70,7 +70,7 @@ M: ratio >base ( num radix -- string )
 : fix-float
     CHAR: . over member? [ ".0" append ] unless ;
 
-M: float >base ( num radix -- string )
+M: float >base
     drop {
         { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
         { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }

library/math/pow.factor

@@ -27,7 +27,7 @@ GENERIC: (^) ( z w -- z^w ) foldable
 : ^theta ( w abs arg -- theta )
     >r >r >rect r> flog * swap r> * + ; inline
 
-M: number (^) ( z w -- z^w )
+M: number (^)
     swap >polar 3dup ^theta >r ^mag r> polar> ;
 
 : ^n ( z w -- z^w )
@@ -37,7 +37,7 @@ M: number (^) ( z w -- z^w )
         { [ t ] [ over sq over 2 /i ^n -rot 2 mod ^n * ] }
     } cond ; inline
 
-M: integer (^) ( z w -- z^w )
+M: integer (^)
     dup 0 < [ neg ^n recip ] [ ^n ] if ;
 
 : power-of-2? ( n -- ? )

library/math/ratio.factor

@@ -16,7 +16,7 @@ IN: math-internals
 : 2>fraction ( a/b c/d -- a c b d )
     [ >fraction ] 2apply swapd ; inline
 
-M: ratio number= ( a/b c/d -- ? )
+M: ratio number=
     2>fraction number= [ number= ] [ 2drop f ] if ;
 
 : scale ( a/b c/d -- a*d b*c )
@@ -30,9 +30,9 @@ M: ratio <= scale <= ;
 M: ratio > scale > ;
 M: ratio >= scale >= ;
 
-M: ratio + ( x y -- x+y ) 2dup scale + -rot ratio+d / ;
+M: ratio + 2dup scale + -rot ratio+d / ;
-M: ratio - ( x y -- x-y ) 2dup scale - -rot ratio+d / ;
+M: ratio - 2dup scale - -rot ratio+d / ;
-M: ratio * ( x y -- x*y ) 2>fraction * >r * r> / ;
+M: ratio * 2>fraction * >r * r> / ;
 M: ratio / scale / ;
 M: ratio /i scale /i ;
 M: ratio mod 2dup >r >r /i r> r> rot * - ;

library/quotations.factor

@@ -22,7 +22,7 @@ M: quotation like drop dup quotation? [ >quotation ] unless ;
 : make-dip ( quot n -- quot )
     dup \ >r <array> -rot \ r> <array> append3 >quotation ;
 
-: unit ( a -- [ a ] ) 1array >quotation ;
+: unit ( a -- quot ) 1array >quotation ;
 
 GENERIC: literalize ( obj -- obj )
 M: object literalize ;

library/syntax/early-parser.factor

@@ -50,3 +50,22 @@ C: parse-error ( error -- error )
     column get over set-parse-error-col
     line-text get over set-parse-error-text
     [ set-delegate ] keep ;
+
+TUPLE: effect in out declarations terminated? ;
+
+C: effect
+    [
+        over { "*" } sequence=
+        [ nip t swap set-effect-terminated? ]
+        [ set-effect-out ] if
+    ] keep
+    [ set-effect-in ] keep
+    H{ } clone over set-effect-declarations ;
+
+: effect-height ( effect -- n )
+    dup effect-out length swap effect-in length - ;
+
+: effect<= ( eff1 eff2 -- ? )
+    2dup [ effect-terminated? ] 2apply = >r
+    2dup [ effect-in length ] 2apply <= >r
+    [ effect-height ] 2apply number= r> and r> and ;

library/syntax/parse-syntax.factor

@@ -11,12 +11,6 @@ USING: alien arrays compiler definitions errors generic
 hashtables kernel math modules namespaces parser sequences
 strings vectors words ;
 
-: !(
-    CHAR: ) column [
-        line-text get index* dup -1 =
-        [ "Unterminated (" throw ] when 1+
-    ] change ; parsing
-
 : !! line-text get length column set ; parsing
 : !#! POSTPONE: ! ; parsing
 : !IN: scan set-in ; parsing
@@ -83,3 +77,15 @@ DEFER: !PRIMITIVE: parsing
 : !REQUIRES:
     string-mode on
     [ string-mode off [ (require) ] each ] f ; parsing
+
+: !(
+    word parse-effect dup 1array >vector effect-stack set
+    "declared-effect" set-word-prop ; parsing
+
+: !|
+    scan scan-word \ ( eq? [
+        parse-effect dup effect-stack get push
+        swap add-declaration
+    ] [
+        "Expected (" throw
+    ] if ; parsing

library/syntax/parser.factor

@@ -57,7 +57,7 @@ TUPLE: no-word name ;
 : (parse) ( str -- ) line-text set 0 column set parse-loop ;
 
 TUPLE: bad-escape ;
-: bad-escape ( -- ) <bad-escape> throw ;
+: bad-escape ( -- * ) <bad-escape> throw ;
 
 ! Parsing word utilities
 : escape ( ch -- esc )
@@ -90,6 +90,24 @@ TUPLE: bad-escape ;
     column
     [ [ line-text get (parse-string) ] "" make swap ] change ;
 
+SYMBOL: effect-stack
+
+: (parse-effect)
+    scan [
+        dup ")" = [ drop ] [ , (parse-effect) ] if
+    ] [
+        "Unexpected EOL" throw
+    ] if* ;
+
+: parse-effect ( -- effect )
+    [ (parse-effect) column get ] { } make swap column set
+    { "--" } split1 <effect> ;
+
+: add-declaration ( effect name -- )
+    effect-stack get [
+        2dup effect-in member? >r dupd effect-out member? r> or
+    ] find nip effect-declarations set-hash ;
+
 global [
     {
         "scratchpad" "syntax" "arrays" "compiler" "definitions"

library/syntax/prettyprint.factor

@@ -122,7 +122,7 @@ TUPLE: newline ;
 C: newline ( -- section )
     H{ } 0 <section> over set-delegate ;
 
-M: newline pprint-section* ( newline -- )
+M: newline pprint-section*
     section-start fresh-line ;
 
 : newline ( -- ) <newline> add-section ;
@@ -138,7 +138,7 @@ M: newline pprint-section* ( newline -- )
 
 : style> stdio [ delegate ] change ;
 
-M: block pprint-section* ( block -- )
+M: block pprint-section*
     dup <style
     f swap block-sections [
         over [ dup advance ] when pprint-section drop t
@@ -175,11 +175,11 @@ GENERIC: pprint* ( obj -- )
 : pprint-word ( obj -- )
     dup word-name swap word-style styled-text ;
 
-M: object pprint* ( obj -- )
+M: object pprint*
     "( unprintable object: " swap class word-name " )" append3
     text ;
 
-M: real pprint* ( obj -- ) number>string text ;
+M: real pprint* number>string text ;
 
 : ch>ascii-escape ( ch -- esc )
     H{
@@ -213,18 +213,18 @@ M: real pprint* ( obj -- ) number>string text ;
     [ % [ unparse-ch ] each CHAR: " , ] "" make
     do-string-limit text ;
 
-M: string pprint* ( str -- str ) "\"" pprint-string ;
+M: string pprint* "\"" pprint-string ;
 
-M: sbuf pprint* ( str -- str ) "SBUF\" " pprint-string ;
+M: sbuf pprint* "SBUF\" " pprint-string ;
 
-M: word pprint* ( word -- )
+M: word pprint*
     dup "pprint-close" word-prop [ block> ] when
     dup pprint-word
     "pprint-open" word-prop [ H{ } <block ] when ;
 
 M: f pprint* drop \ f pprint-word ;
 
-M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
+M: dll pprint* dll-path "DLL\" " pprint-string ;
 
 : nesting-limit? ( -- ? )
     nesting-limit get dup [ pprinter-stack get length < ] when ;
@@ -273,22 +273,22 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
 : pprint-sequence ( seq start end -- )
     swap pprint* swap pprint-elements pprint* ;
 
-M: complex pprint* ( num -- )
+M: complex pprint*
     >rect 2array \ C{ \ } pprint-sequence ;
 
-M: quotation pprint* ( list -- )
+M: quotation pprint*
     [ \ [ \ ] pprint-sequence ] check-recursion ;
 
-M: array pprint* ( vector -- )
+M: array pprint*
     [ \ { \ } pprint-sequence ] check-recursion ;
 
-M: vector pprint* ( vector -- )
+M: vector pprint*
     [ \ V{ \ } pprint-sequence ] check-recursion ;
 
-M: hashtable pprint* ( hashtable -- )
+M: hashtable pprint*
     [ hash>alist \ H{ \ } pprint-sequence ] check-recursion ;
 
-M: tuple pprint* ( tuple -- )
+M: tuple pprint*
     [
         \ T{ pprint*
         tuple>array dup first pprint*
@@ -296,14 +296,14 @@ M: tuple pprint* ( tuple -- )
         \ } pprint*
     ] check-recursion ;
 
-M: alien pprint* ( alien -- )
+M: alien pprint*
     dup expired? [
         drop "( alien expired )"
     ] [
         \ ALIEN: pprint-word alien-address number>string
     ] if text ;
 
-M: wrapper pprint* ( wrapper -- )
+M: wrapper pprint*
     dup wrapped word? [
         \ \ pprint-word wrapped pprint-word
     ] [

library/test/inference.factor

@@ -1,7 +1,7 @@
-IN: temporary
 USING: arrays errors generic inference kernel kernel-internals
 math math-internals namespaces parser sequences strings test
-vectors ;
+vectors words ;
+IN: temporary
 
 [ f ] [ f [ [ ] map-nodes ] with-node-iterator ] unit-test
 
@@ -66,22 +66,22 @@ vectors ;
 : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
 [ [ no-base-case-1 ] infer ] unit-test-fails
 
-: simple-recursion-1
+: simple-recursion-1 ( obj -- obj )
     dup [ simple-recursion-1 ] [ ] if ;
 
 [ { 1 1 } ] [ [ simple-recursion-1 ] infer ] unit-test
 
-: simple-recursion-2
+: simple-recursion-2 ( obj -- obj )
     dup [ ] [ simple-recursion-2 ] if ;
 
 [ { 1 1 } ] [ [ simple-recursion-2 ] infer ] unit-test
 
-: bad-recursion-2
+: bad-recursion-2 ( obj -- obj )
     dup [ dup first swap second bad-recursion-2 ] [ ] if ;
 
 [ [ bad-recursion-2 ] infer ] unit-test-fails
 
-: funny-recursion
+: funny-recursion ( obj -- obj )
     dup [ funny-recursion 1 ] [ 2 ] if drop ;
 
 [ { 1 1 } ] [ [ funny-recursion ] infer ] unit-test
@@ -122,7 +122,7 @@ DEFER: foe
 
 [ { 0 0 } ] [ [ nested-when ] infer ] unit-test
 
-: nested-when* ( -- )
+: nested-when* ( obj -- )
     [
         [
             drop
@@ -144,7 +144,7 @@ SYMBOL: sym-test
 
 [ { 1 1 } ] [ [ terminator-branch ] infer ] unit-test
 
-: recursive-terminator
+: recursive-terminator ( obj -- )
     dup [
         recursive-terminator
     ] [
@@ -153,49 +153,48 @@ SYMBOL: sym-test
 
 [ { 1 0 } ] [ [ recursive-terminator ] infer ] unit-test
 
-GENERIC: potential-hang
+GENERIC: potential-hang ( obj -- obj )
 M: fixnum potential-hang dup [ potential-hang ] when ;
 
 [ ] [ [ 5 potential-hang ] infer drop ] unit-test
 
 TUPLE: funny-cons car cdr ;
-GENERIC: iterate
+GENERIC: iterate ( obj -- )
 M: funny-cons iterate funny-cons-cdr iterate ;
 M: f iterate drop ;
 M: real iterate drop ;
 
 [ { 1 0 } ] [ [ iterate ] infer ] unit-test
 
-DEFER: agent
+DEFER: agent ( a b -- c d )
 : smith 1+ agent ; inline
 : agent dup 0 = [ [ swap call ] 2keep smith ] when ; inline
 [ { 0 2 } ]
 [ [ [ drop ] 0 agent ] infer ] unit-test
 
-: no-base-case-2 no-base-case-2 ;
-[ [ no-base-case-2 ] infer ] unit-test-fails
-
 ! Regression
-: cat dup [ throw ] [ throw ] if ;
+: cat ( obj -- * ) dup [ throw ] [ throw ] if ;
-: dog dup [ cat ] [ 3drop ] if ;
+: dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
 [ { 3 0 } ] [ [ dog ] infer ] unit-test
 
 ! Regression
 DEFER: monkey
-: friend dup [ friend ] [ monkey ] if ;
+: friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
-: monkey dup [ 3drop ] [ friend ] if ;
+: monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
 [ { 3 0 } ] [ [ friend ] infer ] unit-test
 
 ! Regression -- same as above but we infer the second word first
 DEFER: blah2
-: blah dup [ blah ] [ blah2 ] if ;
+: blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
-: blah2 dup [ blah ] [ 3drop ] if ;
+: blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
 [ { 3 0 } ] [ [ blah2 ] infer ] unit-test
 
 ! Regression
 DEFER: blah4
-: blah3 dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
+: blah3 ( a b c -- )
-: blah4 dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
+    dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
+: blah4 ( a b c -- )
+    dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
 [ { 3 0 } ] [ [ blah4 ] infer ] unit-test
 
 ! Regression
@@ -206,7 +205,7 @@ DEFER: blah4
         [ swap slip ] keep swap bad-combinator
     ] if ; inline
 
-[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
+! [ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
 
 ! Regression
 : bad-input#
@@ -219,18 +218,19 @@ DEFER: blah4
 
 ! This order of branches works
 DEFER: do-crap
-: more-crap dup [ drop ] [ dup do-crap call ] if ;
+: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
-: do-crap dup [ more-crap ] [ do-crap ] if ;
+: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
 [ [ do-crap ] infer ] unit-test-fails
 
 ! This one does not
 DEFER: do-crap*
-: more-crap* dup [ drop ] [ dup do-crap* call ] if ;
+: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
-: do-crap* dup [ do-crap* ] [ more-crap* ] if ;
+: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
 [ [ do-crap* ] infer ] unit-test-fails
 
 ! Regression
-: too-deep dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
+: too-deep ( a b -- c )
+    dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
 [ { 2 1 } ] [ [ too-deep ] infer ] unit-test
 
 ! Error reporting is wrong
@@ -247,7 +247,7 @@ DEFER: A
 DEFER: B
 DEFER: C
 
-: A
+: A ( a -- )
     dup {
         [ drop ]
         [ A ]
@@ -255,7 +255,7 @@ DEFER: C
         [ dup C A ]
     } dispatch ;
 
-: B
+: B ( b -- )
     dup {
         [ C ]
         [ B ]
@@ -263,7 +263,7 @@ DEFER: C
         [ dup B B ]
     } dispatch ;
 
-: C
+: C ( c -- )
     dup {
         [ A ]
         [ C ]
@@ -277,16 +277,26 @@ DEFER: C
 
 ! I found this bug by thinking hard about the previous one
 DEFER: Y
-: X dup [ swap Y ] [ ] if ;
+: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
-: Y X ;
+: Y ( a b -- c d ) X ;
 
 [ { 2 2 } ] [ [ X ] infer ] unit-test
 [ { 2 2 } ] [ [ Y ] infer ] unit-test
 
+! This one comes from UI code
+DEFER: #1
+: #2 ( a b -- ) dup [ call ] [ 2drop ] if ; inline
+: #3 ( a -- ) [ #1 ] #2 ;
+: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
+: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
+
+[ \ #4 word-def infer ] unit-test-fails
+[ [ #1 ] infer ] unit-test-fails
+
 ! Similar
 DEFER: bar
-: foo dup [ 2drop f f bar ] [ ] if ;
+: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
-: bar [ 2 2 + ] t foo drop call drop ;
+: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
 
 [ [ foo ] infer ] unit-test-fails
 
@@ -297,12 +307,12 @@ DEFER: bar
 
 ! This form should not have a stack effect
 
-: bad-recursion-1
+: bad-recursion-1 ( a -- b )
     dup [ drop bad-recursion-1 5 ] [ ] if ;
 
 [ [ bad-recursion-1 ] infer ] unit-test-fails
 
-: bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
+: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
 [ [ bad-bin ] infer ] unit-test-fails
 
 ! Test some random library words

library/test/parser.factor

@@ -1,9 +1,5 @@
+USING: arrays errors math parser test kernel generic words ;
 IN: temporary
-USE: parser
-USE: test
-USE: kernel
-USE: generic
-USE: words
 
 [ 1 CHAR: a ]
 [ 0 "abcd" next-char ] unit-test
@@ -43,10 +39,6 @@ unit-test
 [ "! This is a comment, people." parse call ]
 unit-test
 
-[ ]
-[ "( This is a comment, people. )" parse call ]
-unit-test
-
 ! Test escapes
 
 [ [ " " ] ]
@@ -63,3 +55,34 @@ unit-test
 [ [ "Hello" ] ] [ "#! This calls until-eol.\n\"Hello\"" parse ] unit-test 
 
 [ word ] [ \ f class ] unit-test
+
+! Test stack effect parsing
+
+: foo ( a b -- c ) + ;
+
+[ T{ effect f { "a" "b" } { "c" } H{ } f } ]
+[ \ foo "declared-effect" word-prop ] unit-test
+
+: bar ( a quot -- b ) | quot ( u -- v ) call ;
+
+[
+    T{ effect f
+        { "a" "quot" }
+        { "b" }
+        H{ { "quot" T{ effect f { "u" } { "v" } H{ } } } }
+        f
+    }
+]
+[ \ bar "declared-effect" word-prop ] unit-test
+
+[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
+[ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
+[ t ] [ 2 2 <effect> 2 2 <effect> effect<= ] unit-test
+[ f ] [ 3 3 <effect> 2 2 <effect> effect<= ] unit-test
+[ f ] [ 2 3 <effect> 2 2 <effect> effect<= ] unit-test
+
+: baz ( a b -- * ) 2array throw ;
+
+[ t ]
+[ \ baz "declared-effect" word-prop effect-terminated? ]
+unit-test

library/test/test.factor

@@ -6,7 +6,7 @@ memory namespaces parser prettyprint sequences strings words
 vectors ;
 
 TUPLE: assert got expect ;
-: assert ( got expect -- ) <assert> throw ;
+: assert ( got expect -- * ) <assert> throw ;
 
 : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
 

library/tools/debugger.factor

@@ -11,13 +11,13 @@ PREDICATE: array kernel-error ( obj -- ? )
 GENERIC: error. ( error -- )
 GENERIC: error-help ( error -- topic )
 
-M: object error. ( error -- ) . ;
+M: object error. . ;
-M: object error-help ( error -- topic ) drop f ;
+M: object error-help drop f ;
 
-M: tuple error. ( error -- ) describe ;
+M: tuple error. describe ;
-M: tuple error-help ( error -- topic ) class ;
+M: tuple error-help class ;
 
-M: string error. ( error -- ) print ;
+M: string error. print ;
 
 SYMBOL: restarts
 

library/tools/describe.factor

@@ -12,9 +12,9 @@ GENERIC: sheet ( obj -- sheet )
         dup third -rot first slot 2array
     ] map-with ;
 
-M: object sheet ( obj -- sheet ) slot-sheet ;
+M: object sheet slot-sheet ;
 
-M: tuple sheet ( tuple -- sheet )
+M: tuple sheet
     dup slot-sheet swap delegate [ 1 tail ] unless ;
 
 M: sequence summary

library/tools/errors.factor

@@ -80,14 +80,14 @@ DEFER: objc-error. ( alien -- )
         callstack-overflow.
     } nth ;
 
-M: kernel-error error. ( error -- ) dup kernel-error execute ;
+M: kernel-error error. dup kernel-error execute ;
 
-M: kernel-error error-help ( error -- topic ) kernel-error ;
+M: kernel-error error-help kernel-error ;
 
 M: no-method summary
     drop "No suitable method" ;
 
-M: no-method error. ( error -- )
+M: no-method error.
     "Generic word " write
     dup no-method-generic pprint
     " does not define a method for the " write
@@ -150,7 +150,7 @@ M: no-word summary
     parse-error-col [ 0 ] unless*
     CHAR: \s <string> write "^" print ;
 
-M: parse-error error. ( error -- )
+M: parse-error error.
     dup parse-dump  delegate error. ;
 
 M: bounds-error summary drop "Sequence index out of bounds" ;
@@ -159,15 +159,15 @@ M: condition error. delegate error. ;
 
 M: condition error-help drop f ;
 
-M: alien-callback-error summary ( error -- )
+M: alien-callback-error summary
     drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
 
-M: alien-invoke-error summary ( error -- )
+M: alien-invoke-error summary
     drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ;
 
 M: assert summary drop "Assertion failed" ;
 
-M: inference-error error. ( error -- )
+M: inference-error error.
     "Inference error:" print
     dup inference-error-message print
     "Recursive state:" print

library/tools/interpreter.factor

@@ -120,23 +120,23 @@ SYMBOL: callframe-end
 
 GENERIC: do-1 ( object -- )
 
-M: word do-1 ( word -- )
+M: word do-1
     dup "meta-word" word-prop [ call ] [ host-word ] ?if ;
 
-M: wrapper do-1 ( wrapper -- ) wrapped push-d ;
+M: wrapper do-1 wrapped push-d ;
 
-M: object do-1 ( object -- ) push-d ;
+M: object do-1 push-d ;
 
 GENERIC: do ( obj -- )
 
-M: word do ( word -- )
+M: word do
     dup "meta-word" word-prop [
         call
     ] [
         dup compound? [ word-def meta-call ] [ host-word ] if
     ] ?if ;
 
-M: object do ( object -- ) do-1 ;
+M: object do do-1 ;
 
 ! The interpreter loses object identity of the name and catch
 ! stacks -- they are copied after each step -- so we execute

library/tools/summary.factor

@@ -9,7 +9,7 @@ GENERIC: summary ( object -- string )
 M: object summary
     "an instance of the " swap class word-name " class" append3 ;
 
-M: word summary ( word -- )
+M: word summary
     dup word-vocabulary [
         dup interned?
         "a word in the " "a word orphaned from the " ?
@@ -18,11 +18,11 @@ M: word summary ( word -- )
         drop "a uniquely generated symbol"
     ] if ;
 
-M: input summary ( input -- )
+M: input summary
     "Input: " swap input-string
     dup string? [ unparse-short ] unless append ;
 
-M: vocab-link summary ( vocab-link -- )
+M: vocab-link summary
     [
         vocab-link-name dup %
         " vocabulary (" %

library/ui/cocoa/pasteboard-utils.factor

@@ -23,10 +23,10 @@ sequences ;
 
 TUPLE: pasteboard handle ;
 
-M: pasteboard clipboard-contents ( pb -- str )
+M: pasteboard clipboard-contents
     pasteboard-handle pasteboard-string ;
 
-M: pasteboard set-clipboard-contents ( str pb -- )
+M: pasteboard set-clipboard-contents
     pasteboard-handle set-pasteboard-string ;
 
 : init-clipboard ( -- )

library/ui/gadgets.factor

@@ -67,8 +67,7 @@ M: gadget user-input* 2drop t ;
 
 GENERIC: children-on ( rect/point gadget -- list )
 
-M: gadget children-on ( rect/point gadget -- list )
+M: gadget children-on nip gadget-children ;
-    nip gadget-children ;
 
 : inside? ( bounds gadget -- ? )
     dup gadget-visible?

library/ui/gadgets/books.factor

@@ -20,9 +20,9 @@ C: book ( pages -- book )
 : <book-control> ( model pages -- book )
     <book> [ show-page ] <control> ;
 
-M: book pref-dim* ( book -- dim ) book-page pref-dim ;
+M: book pref-dim* book-page pref-dim ;
 
-M: book layout* ( book -- )
+M: book layout*
     dup rect-dim swap book-page set-layout-dim ;
 
 : make-book ( model obj quots -- assoc )

library/ui/gadgets/borders.factor

@@ -20,11 +20,11 @@ C: border ( child gap -- border )
     dup rect-dim over border-size 2 v*n v-
     swap gadget-child set-layout-dim ;
 
-M: border pref-dim* ( border -- dim )
+M: border pref-dim*
     [ border-size 2 v*n ] keep
     gadget-child pref-dim v+ ;
 
-M: border layout* ( border -- )
+M: border layout*
     dup layout-border-loc layout-border-dim ;
 
 : <spacing> ( -- gadget )

library/ui/gadgets/buttons.factor

@@ -70,7 +70,7 @@ C: repeat-button ( gadget quot -- button )
     #! the mouse is held down.
     [ >r <bevel-button> r> set-gadget-delegate ] keep ;
 
-M: repeat-button tick ( ms object -- ) nip button-clicked ;
+M: repeat-button tick nip button-clicked ;
 
 TUPLE: button-paint plain rollover pressed selected ;
 
@@ -82,10 +82,10 @@ TUPLE: button-paint plain rollover pressed selected ;
         { [ t ] [ button-paint-plain ] }
     } cond ;
 
-M: button-paint draw-interior ( button paint -- )
+M: button-paint draw-interior
     button-paint draw-interior ;
 
-M: button-paint draw-boundary ( button paint -- )
+M: button-paint draw-boundary
     button-paint draw-boundary ;
 
 : <radio-control> ( model value gadget -- gadget )

library/ui/gadgets/controls.factor

@@ -18,7 +18,7 @@ M: control graft*
 M: control ungraft*
     dup control-self swap control-model remove-connection ;
 
-M: control model-changed ( gadget -- )
+M: control model-changed
     [ control-model model-value ] keep
     [ dup control-self swap control-quot call ] keep
     control-self relayout ;

library/ui/gadgets/frames.factor

@@ -32,7 +32,7 @@ C: frame ( -- frame )
 : fill-center ( horiz vert dim -- )
     tuck (fill-center) (fill-center) ;
 
-M: frame layout* ( frame -- dim )
+M: frame layout*
     dup [
         [ rot rect-dim fill-center ] 2keep grid-layout
     ] with-grid ;

library/ui/gadgets/grid-lines.factor

@@ -20,7 +20,7 @@ SYMBOL: grid-dim
     swap grid-positions grid get rect-dim { 1 0 } v- add
     [ grid-line-from/to gl-line ] each-with ;
 
-M: grid-lines draw-boundary ( gadget paint -- )
+M: grid-lines draw-boundary
     #! Clean this up later.
     GL_MODELVIEW [
         grid-lines-color gl-color [

library/ui/gadgets/grids.factor

@@ -39,7 +39,7 @@ C: grid ( children -- grid )
 : (pair-up) ( horiz vert -- dim )
     >r first r> second 2array ;
 
-M: grid pref-dim* ( grid -- dim )
+M: grid pref-dim*
     [
         [ gap [ v+ gap v+ ] reduce ] 2apply (pair-up)
     ] with-grid ;
@@ -65,7 +65,7 @@ M: grid pref-dim* ( grid -- dim )
 : grid-layout ( horiz vert -- )
     2dup position-grid resize-grid ;
 
-M: grid layout* ( frame -- dim )
+M: grid layout*
     [ grid-layout ] with-grid ;
 
 : build-grid ( grid specs -- )

library/ui/gadgets/incremental.factor

@@ -19,7 +19,7 @@ C: incremental ( pack -- incremental )
     [ set-gadget-delegate ] keep
     dup delegate pref-dim over set-incremental-cursor ;
 
-M: incremental pref-dim* ( incremental -- dim )
+M: incremental pref-dim*
     dup gadget-state [
         dup delegate pref-dim over set-incremental-cursor
     ] when incremental-cursor ;

library/ui/gadgets/labels.factor

@@ -17,13 +17,13 @@ C: label ( text -- label )
     dup label-font lookup-font dup font-height >r
     swap label-text string-width r> 2array ;
 
-M: label pref-dim* ( label -- dim ) label-size ;
+M: label pref-dim* label-size ;
 
 : draw-label ( label -- )
     dup label-color gl-color
     dup label-font swap label-text draw-string ;
 
-M: label draw-gadget* ( label -- ) draw-label ;
+M: label draw-gadget* draw-label ;
 
 : <label-control> ( model -- gadget )
     "" <label> [ set-label-text ] <control> ;

library/ui/gadgets/outliner.factor

@@ -8,7 +8,7 @@ gadgets-theme generic io kernel math opengl sequences styles ;
 ! Vertical line.
 TUPLE: guide color ;
 
-M: guide draw-interior ( gadget interior -- )
+M: guide draw-interior
     guide-color gl-color
     rect-dim dup { 0.5 0 0 } v* swap { 0.5 1 0 } v* gl-line ;
 

library/ui/gadgets/panes.factor

@@ -43,11 +43,11 @@ C: pane ( -- pane )
 
 GENERIC: write-gadget ( gadget stream -- )
 
-M: pane write-gadget ( gadget pane -- )
+M: pane write-gadget
     #! Print a gadget to the given pane.
     pane-current add-gadget ;
 
-M: duplex-stream write-gadget ( gadget stream -- )
+M: duplex-stream write-gadget
     duplex-stream-out write-gadget ;
 
 : print-gadget ( gadget pane -- )
@@ -58,29 +58,29 @@ M: duplex-stream write-gadget ( gadget stream -- )
     stdio get print-gadget ;
 
 ! Panes are streams.
-M: pane stream-flush ( pane -- ) drop ;
+M: pane stream-flush drop ;
 
 : scroll-pane ( pane -- )
     dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;
 
-M: pane stream-terpri ( pane -- )
+M: pane stream-terpri
     dup pane-current prepare-print
     over pane-output add-incremental
     dup prepare-line
     scroll-pane ;
 
-M: pane stream-write1 ( char pane -- )
+M: pane stream-write1
     [ pane-current stream-write1 ] keep scroll-pane ;
 
-M: pane stream-write ( string pane -- )
+M: pane stream-write
     [ swap "\n" split pane-write ] keep scroll-pane ;
 
-M: pane stream-format ( string style pane -- )
+M: pane stream-format
     [ rot "\n" split pane-format ] keep scroll-pane ;
 
-M: pane stream-close ( pane -- ) drop ;
+M: pane stream-close drop ;
 
-M: pane with-stream-style ( quot style pane -- )
+M: pane with-stream-style
     (with-stream-style) ;
 
 : ?terpri

library/ui/gadgets/paragraphs.factor

@@ -10,7 +10,7 @@ TUPLE: word-break-gadget ;
 C: word-break-gadget ( gadget -- gadget )
     [ set-delegate ] keep ;
 
-M: word-break-gadget draw-gadget* ( gadget -- ) drop ;
+M: word-break-gadget draw-gadget* drop ;
 
 ! A gadget that arranges its children in a word-wrap style.
 TUPLE: paragraph margin ;
@@ -61,8 +61,8 @@ SYMBOL: margin
         [ wrap-step ] each-child-with wrap-dim
     ] with-scope ; inline
 
-M: paragraph pref-dim* ( paragraph -- dim )
+M: paragraph pref-dim*
     [ 2drop ] do-wrap ;
 
-M: paragraph layout* ( paragraph -- )
+M: paragraph layout*
     [ swap dup prefer set-rect-loc ] do-wrap drop ;

library/ui/gadgets/presentations.factor

@@ -18,7 +18,7 @@ C: object-button ( gadget object -- button )
         r> set-gadget-delegate
     ] keep ;
 
-M: object-button gadget-help ( button -- string )
+M: object-button gadget-help
     object-button-object dup word? [ synopsis ] [ summary ] if ;
 
 ! Character styles
@@ -107,26 +107,26 @@ M: object-button gadget-help ( button -- string )
         [ pick pick >r >r -rot styled-pane r> r> rot ] map
     ] map styled-grid nip ;
 
-M: pane with-stream-table ( grid quot style pane -- )
+M: pane with-stream-table
     >r rot <pane-grid> r> print-gadget ;
 
-M: pane with-nested-stream ( quot style stream -- )
+M: pane with-nested-stream
     >r styled-pane r> write-gadget ;
 
 ! Stream utilities
-M: pack stream-close ( stream -- ) drop ;
+M: pack stream-close drop ;
 
-M: paragraph stream-close ( stream -- ) drop ;
+M: paragraph stream-close drop ;
 
 : gadget-write ( string gadget -- )
     over empty? [ 2drop ] [ >r <label> r> add-gadget ] if ;
 
-M: pack stream-write ( string stream -- ) gadget-write ;
+M: pack stream-write gadget-write ;
 
 : gadget-bl ( style stream -- )
     >r " " <presentation> <word-break-gadget> r> add-gadget ;
 
-M: paragraph stream-write ( string stream -- )
+M: paragraph stream-write
     swap " " split
     [ over gadget-write ] [ H{ } over gadget-bl ] interleave
     drop ;
@@ -134,9 +134,9 @@ M: paragraph stream-write ( string stream -- )
 : gadget-write1 ( char gadget -- )
     >r ch>string r> stream-write ;
 
-M: pack stream-write1 ( char stream -- ) gadget-write1 ;
+M: pack stream-write1 gadget-write1 ;
 
-M: paragraph stream-write1 ( char stream -- )
+M: paragraph stream-write1
     over CHAR: \s =
     [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
 
@@ -144,10 +144,10 @@ M: paragraph stream-write1 ( char stream -- )
     pick empty?
     [ 3drop ] [ >r swap <presentation> r> add-gadget ] if ;
 
-M: pack stream-format ( string style stream -- )
+M: pack stream-format
     gadget-format ;
 
-M: paragraph stream-format ( string style stream -- )
+M: paragraph stream-format
     presented pick hash [
         gadget-format
     ] [

library/ui/gadgets/scrolling.factor

@@ -85,10 +85,10 @@ C: scroller ( gadget -- scroller )
         dup scroller-origin scroll
     ] if ;
 
-M: scroller layout* ( scroller -- )
+M: scroller layout*
     dup delegate layout*
     dup layout-children
     update-scroller ;
 
-M: scroller focusable-child* ( scroller -- viewport )
+M: scroller focusable-child*
     scroller-viewport ;

library/ui/gadgets/sliders.factor

@@ -116,7 +116,7 @@ C: elevator ( vector -- elevator )
 : layout-thumb ( slider -- )
     dup layout-thumb-loc layout-thumb-dim ;
 
-M: elevator layout* ( elevator -- )
+M: elevator layout*
     find-slider layout-thumb ;
 
 : slide-by-line ( -1/1 slider -- ) >r 32 * r> slide-by ;

library/ui/gadgets/tracks.factor

@@ -32,14 +32,14 @@ C: track ( orientation -- track )
     [ [ over n*v , ] [ divider-size , ] interleave ] { } make
     nip ;
 
-M: track layout* ( track -- )
+M: track layout*
     dup track-layout packed-layout ;
 
 : track-pref-dims ( dims sizes -- dims )
     [ [ dup zero? [ nip ] [ v/n ] if ] 2map max-dim ] keep
     divider-sizes v+ [ >fixnum ] map ;
 
-M: track pref-dim* ( track -- dim )
+M: track pref-dim*
     [
         dup gadget-children
         2 group [ first ] map pref-dims

library/ui/gadgets/viewports.factor

@@ -15,13 +15,13 @@ C: viewport ( content -- viewport )
     [ >r 3 <border> r> add-gadget ] keep
     t over set-gadget-clipped? ;
 
-M: viewport layout* ( viewport -- )
+M: viewport layout*
     dup gadget-child dup pref-dim rot rect-dim vmax
     swap set-layout-dim ;
 
-M: viewport focusable-child* ( viewport -- gadget )
+M: viewport focusable-child*
     gadget-child ;
 
-M: viewport pref-dim* ( viewport -- dim ) viewport-dim ;
+M: viewport pref-dim* viewport-dim ;
 
 : viewport-rect ( rect -- rect ) { 3 3 } offset-rect ;

library/ui/layouts.factor

@@ -141,16 +141,16 @@ C: pack ( vector -- pack )
     [ >r [ max-dim ] keep r> pack-gap swap gap-dims ] keep
     gadget-orientation set-axis ;
 
-M: pack pref-dim* ( pack -- dim )
+M: pack pref-dim*
     [ gadget-children pref-dims ] keep pack-pref-dim ;
 
-M: pack layout* ( pack -- )
+M: pack layout*
     dup gadget-children pref-dims packed-layout ;
 
 : fast-children-on ( dim axis gadgets -- i )
     swapd [ rect-loc v- over v. ] binsearch nip ;
 
-M: pack children-on ( rect pack -- list )
+M: pack children-on
     dup gadget-orientation swap gadget-children [
         3dup
         >r >r dup rect-loc swap rect-dim v+ origin get v- r> r> fast-children-on 1+

library/ui/models.factor

@@ -56,7 +56,7 @@ GENERIC: model-changed ( observer -- )
 
 GENERIC: set-model ( value model -- )
 
-M: model set-model ( value model -- )
+M: model set-model
     [ set-model-value ] keep
     model-connections [ model-changed ] each ;
 
@@ -84,7 +84,7 @@ C: filter ( model quot -- filter )
     [ add-dependency ] keep
     dup model-changed ;
 
-M: filter model-changed ( filter -- )
+M: filter model-changed
     dup filter-model model-value over filter-quot call
     swap set-model ;
 
@@ -97,7 +97,7 @@ C: validator ( model quot -- filter )
     [ add-dependency ] keep
     dup model-changed ;
 
-M: validator model-changed ( validator -- )
+M: validator model-changed
     dup validator-model model-value dup
     pick validator-quot call [
         swap delegate set-model
@@ -105,7 +105,7 @@ M: validator model-changed ( validator -- )
         2drop
     ] if ;
 
-M: validator set-model ( value validator -- )
+M: validator set-model
     2dup validator-quot call [
         validator-model set-model
     ] [
@@ -119,11 +119,11 @@ C: compose ( models -- compose )
     [ set-model-dependencies ] keep
     dup model-changed ;
 
-M: compose model-changed ( compose -- )
+M: compose model-changed
     dup model-dependencies [ model-value ] map
     swap delegate set-model ;
 
-M: compose set-model ( value compose -- )
+M: compose set-model
     model-dependencies [ set-model ] 2each ;
 
 TUPLE: history back forward ;
@@ -136,7 +136,7 @@ C: history ( value -- history )
 G: (add-history) ( history vector -- )
     1 standard-combination ;
 
-M: history (add-history) ( history vector -- )
+M: history (add-history)
     swap model-value dup [ swap push ] [ 2drop ] if ;
 
 : go-back/forward ( history to from -- )
@@ -152,6 +152,6 @@ M: history (add-history) ( history vector -- )
 
 GENERIC: add-history ( history -- )
 
-M: history add-history ( history -- )
+M: history add-history
     dup history-forward delete-all
     dup history-back (add-history) ;

library/ui/paint.factor

@@ -25,7 +25,7 @@ SYMBOL: clip
 
 GENERIC: draw-gadget* ( gadget -- )
 
-M: gadget draw-gadget* ( gadget -- ) drop ;
+M: gadget draw-gadget* drop ;
 
 GENERIC: draw-interior ( gadget interior -- )
 
@@ -94,7 +94,7 @@ M: solid draw-boundary
 ! Gradient pen
 TUPLE: gradient colors ;
 
-M: gradient draw-interior ( gadget gradient -- )
+M: gradient draw-interior
     over gadget-orientation swap gradient-colors rot rect-dim
     gl-gradient ;
 
@@ -104,10 +104,10 @@ TUPLE: polygon color points ;
 : draw-polygon ( polygon quot -- )
     >r dup polygon-color gl-color polygon-points r> each ; inline
 
-M: polygon draw-boundary ( gadget polygon -- )
+M: polygon draw-boundary
     [ gl-poly ] draw-polygon drop ;
 
-M: polygon draw-interior ( gadget polygon -- )
+M: polygon draw-interior
     [ gl-fill-poly ] draw-polygon drop ;
 
 : arrow-up    { { { 3 0 } { 6 6 } { 0 6 } } } ;

library/ui/text/document.factor

@@ -128,11 +128,11 @@ C: document ( -- document )
 : clear-doc ( document -- )
     "" swap set-doc-text ;
 
-M: document (add-history) ( document vector -- )
+M: document (add-history)
     >r model-value dup { "" } sequence=
     [ r> 2drop ] [ r> push-new ] if ;
 
-M: document add-history ( document -- )
+M: document add-history
     #! Add the new entry at the end of the history, and avoid
     #! duplicates.
     dup history-back dup

library/ui/text/editor.factor

@@ -32,17 +32,17 @@ C: editor ( document -- editor )
 : deactivate-editor-model ( editor model -- )
     dup deactivate-model swap control-model remove-loc ;
 
-M: editor graft* ( editor -- )
+M: editor graft*
     dup dup editor-caret activate-editor-model
     dup dup editor-mark activate-editor-model
     dup control-self swap control-model add-connection ;
 
-M: editor ungraft* ( editor -- )
+M: editor ungraft*
     dup dup editor-caret deactivate-editor-model
     dup dup editor-mark deactivate-editor-model
     dup control-self swap control-model remove-connection ;
 
-M: editor model-changed ( editor -- )
+M: editor model-changed
     control-self dup control-model
     over editor-caret [ over validate-loc ] (change-model)
     over editor-mark [ over validate-loc ] (change-model)
@@ -124,7 +124,7 @@ M: editor model-changed ( editor -- )
 : scroll>caret ( editor -- )
     dup caret-rect swap scroll>rect ;
 
-M: loc-monitor model-changed ( obj -- )
+M: loc-monitor model-changed
     loc-monitor-editor dup scroll>caret
     control-self relayout ;
 
@@ -182,7 +182,7 @@ M: loc-monitor model-changed ( obj -- )
         ] each-line 2drop
     ] do-matrix ;
 
-M: editor draw-gadget* ( gadget -- )
+M: editor draw-gadget*
     [ draw-caret draw-selection draw-lines ] with-editor ;
 
 : editor-height ( editor -- n )
@@ -192,20 +192,20 @@ M: editor draw-gadget* ( gadget -- )
     0 swap dup editor-font* swap editor-lines
     [ string-width max ] each-with ;
 
-M: editor pref-dim* ( editor -- dim )
+M: editor pref-dim*
     dup editor-width swap editor-height 2array ;
 
-M: editor gadget-selection? ( editor -- ? )
+M: editor gadget-selection?
     selection-start/end = not ;
 
-M: editor gadget-selection ( editor -- str )
+M: editor gadget-selection
     [ selection-start/end ] keep control-model doc-range ;
 
 : remove-editor-selection ( editor -- )
     [ selection-start/end ] keep control-model
     remove-doc-range ;
 
-M: editor user-input* ( str editor -- ? )
+M: editor user-input*
     [ selection-start/end ] keep control-model set-doc-range t ;
 
 : editor-text ( editor -- str )

library/ui/text/interactor.factor

@@ -11,7 +11,7 @@ C: interactor ( output -- gadget )
     f <field> over set-gadget-delegate
     dup dup set-control-self ;
 
-M: interactor graft* ( interactor -- )
+M: interactor graft*
     f over set-interactor-busy? delegate graft* ;
 
 : interactor-eval ( string interactor -- )
@@ -55,6 +55,6 @@ interactor H{
     { T{ key-down f { C+ } "d" } [ f swap interactor-eval ] }
 } set-gestures
 
-M: interactor stream-readln ( interactor -- line )
+M: interactor stream-readln
     f over set-interactor-busy?
     [ over set-interactor-continuation stop ] callcc1 nip ;

library/ui/tools/browser.factor

@@ -164,6 +164,6 @@ M: browser gadget-title drop "Browser" <model> ;
 
 : browser-tool [ browser? ] [ <browser> ] [ browse ] ;
 
-M: word show ( word -- ) browser-tool call-tool ;
+M: word show browser-tool call-tool ;
 
-M: vocab-link show ( vocab -- ) browser-tool call-tool ;
+M: vocab-link show browser-tool call-tool ;

library/ui/tools/help.factor

@@ -47,4 +47,4 @@ M: help-gadget pref-dim*
     [ <help-gadget> ]
     [ show-help ] ;
 
-M: link show ( link -- ) help-tool call-tool ;
+M: link show help-tool call-tool ;

library/ui/tools/listener.factor

@@ -51,7 +51,7 @@ C: listener-gadget ( -- gadget )
 M: listener-gadget pref-dim*
     delegate pref-dim* { 500 600 } vmax ;
 
-M: listener-gadget focusable-child* ( listener -- gadget )
+M: listener-gadget focusable-child*
     listener-gadget-input ;
 
 M: listener-gadget gadget-title drop "Listener" <model> ;
@@ -81,8 +81,8 @@ M: listener-gadget gadget-title drop "Listener" <model> ;
         [ [ run-file ] each ] curry listener-tool call-tool
     ] if ;
 
-M: input show ( input -- )
+M: input show
     input-string listener-tool call-tool ;
 
-M: object show ( object -- )
+M: object show
     [ inspect ] curry listener-tool call-tool ;

library/ui/tools/walker.factor

@@ -87,7 +87,7 @@ M: walker-gadget gadget-title
 M: walker-gadget pref-dim*
     delegate pref-dim* { 600 600 } vmax ;
 
-M: walker-gadget focusable-child* ( listener -- gadget )
+M: walker-gadget focusable-child*
     walker-gadget-input ;
 
 : walker-continuation ( -- continuation )

library/ui/ui.factor

@@ -153,7 +153,7 @@ C: world-error ( error world -- error )
     [ set-world-error-world ] keep
     [ set-delegate ] keep ;
 
-M: world-error error. ( world-error -- )
+M: world-error error.
     "An error occurred while drawing the world " write
     dup world-error-world pprint-short "." print
     "This world has been deactivated to prevent cascading errors." print

library/ui/windows/clipboard.factor

@@ -45,8 +45,8 @@ IN: win32
     CloseClipboard drop ;
 
 TUPLE: pasteboard ;
-M: pasteboard clipboard-contents ( pb -- str ) drop paste ;
+M: pasteboard clipboard-contents drop paste ;
-M: pasteboard set-clipboard-contents ( str pb -- ) drop copy ;
+M: pasteboard set-clipboard-contents drop copy ;
 
 : init-clipboard ( -- )
     <pasteboard> clipboard set-global ;