Stack effect declaration fixes

library/bootstrap/image.factor

@@ -15,7 +15,7 @@ namespaces parser prettyprint sequences sequences-internals
 strings vectors words ;
 IN: image
 
-( Constants )
+! Constants
 
 : image-magic HEX: 0f0e0d0c ; inline
 : image-version 2 ; inline
@@ -87,26 +87,26 @@ SYMBOL: architecture
 : emit-object ( header tag quot -- addr )
     swap here-as >r swap tag-header emit call align-here r> ;
 
-( Image header )
+! Image header
 
 : header ( -- )
     image-magic emit
     image-version emit
-    ( relocation base at end of header ) data-base emit
+     data-base emit ! relocation base at end of header
-    ( bootstrap quotation set later ) 0 emit
+     0 emit ! bootstrap quotation set later
-    ( global namespace set later ) 0 emit
+     0 emit ! global namespace set later
-    ( pointer to t object ) 0 emit
+     0 emit ! pointer to t object
-    ( pointer to bignum 0 ) 0 emit
+     0 emit ! pointer to bignum 0
-    ( pointer to bignum 1 ) 0 emit
+     0 emit ! pointer to bignum 1
-    ( pointer to bignum -1 ) 0 emit
+     0 emit ! pointer to bignum -1
-    ( size of data heap set later ) 0 emit
+     0 emit ! size of data heap set later
-    ( size of code heap is 0 ) 0 emit
+     0 emit ! size of code heap is 0
-    ( reloc base of code heap is 0 ) 0 emit ;
+     0 emit ; ! reloc base of code heap is 0
 
 GENERIC: ' ( obj -- ptr )
 #! Write an object to the image.
 
-( Bignums )
+! Bignums
 
 : bignum-bits bootstrap-cell-bits 2 - ;
 
@@ -133,7 +133,7 @@ M: bignum '
     #! This can only emit 0, -1 and 1.
     bignum-tag bignum-tag [ emit-bignum ] emit-object ;
 
-( Fixnums )
+! Fixnums
 
 M: fixnum '
     #! When generating a 32-bit image on a 64-bit system,
@@ -141,14 +141,14 @@ M: fixnum '
     dup most-negative-fixnum most-positive-fixnum between?
     [ fixnum-tag tag-address ] [ >bignum ' ] if ;
 
-( Floats )
+! Floats
 
 M: float '
     float-tag float-tag [
         align-here double>bits emit-64
     ] emit-object ;
 
-( Special objects )
+! Special objects
 
 ! Padded with fixnums for 8-byte alignment
 
@@ -162,13 +162,13 @@ M: f '
 :  1,  1 >bignum '  1-offset fixup ;
 : -1, -1 >bignum ' -1-offset fixup ;
 
-( Beginning of the image )
+! Beginning of the image
 ! The image begins with the header, then T,
 ! and the bignums 0, 1, and -1.
 
 : begin-image ( -- ) header t, 0, 1, -1, ;
 
-( Words )
+! Words
 
 : emit-word ( word -- )
     [
@@ -199,12 +199,12 @@ M: f '
 
 M: word ' ;
 
-( Wrappers )
+! Wrappers
 
 M: wrapper '
     wrapped ' wrapper-tag wrapper-tag [ emit ] emit-object ;
 
-( Ratios and complexes )
+! Ratios and complexes
 
 : emit-pair
     [ [ emit ] 2apply ] emit-object ;
@@ -215,7 +215,7 @@ M: ratio '
 M: complex '
     >rect [ ' ] 2apply complex-tag complex-tag emit-pair ;
 
-( Strings )
+! Strings
 
 : emit-chars ( seq -- )
     big-endian get [ [ <reversed> ] map ] unless
@@ -236,7 +236,7 @@ M: string '
     #! to the image
     objects get [ emit-string ] cache ;
 
-( Arrays and vectors )
+! Arrays and vectors
 
 : emit-array ( list type -- pointer )
     >r [ ' ] map r> object-tag [
@@ -273,7 +273,7 @@ M: sbuf '
         emit ( array ptr )
     ] emit-object ;
 
-( Hashes )
+! Hashes
 
 M: hashtable '
     [ hash-array ' ] keep
@@ -283,7 +283,7 @@ M: hashtable '
         emit ( array ptr )
     ] emit-object ;
 
-( End of the image )
+! End of the image
 
 : words, ( -- )
     all-words [ emit-word ] each ;
@@ -315,7 +315,7 @@ M: hashtable '
     "Object cache size: " write objects get hash-size .
     \ word global remove-hash ;
 
-( Image output )
+! Image output
 
 : (write-image) ( image -- )
     bootstrap-cell swap big-endian get [

library/collections/hashtables.factor

@@ -249,7 +249,7 @@ M: hashtable hashcode
 : ?hash ( key hash/f -- value/f )
     dup [ hash ] [ 2drop f ] if ;
 
-: ?hash* ( key hash/f -- value/f )
+: ?hash* ( key hash/f -- value/f ? )
     dup [ hash* ] [ 2drop f f ] if ;
 
 IN: hashtables-internals

library/collections/sequence-combinators.factor

@@ -4,7 +4,7 @@ IN: sequences-internals
 USING: arrays generic kernel kernel-internals math sequences
 vectors ;
 
-: collect ( n generator -- array | quot: n -- value )
+: collect ( n quot -- array ) | quot ( n -- value )
     >r [ f <array> ] keep r> swap [
         [ rot >r [ swap call ] keep r> set-array-nth ] 3keep
     ] repeat drop ; inline
@@ -32,36 +32,36 @@ vectors ;
 
 IN: sequences
 
-: each ( seq quot -- | quot: elt -- )
+: each ( seq quot -- ) | quot ( elt -- )
     swap dup length [
         [ swap nth-unsafe swap call ] 3keep
     ] repeat 2drop ; inline
 
-: each-with ( obj seq quot -- | quot: obj elt -- )
+: each-with ( obj seq quot -- ) | quot (  obj elt -- )
     swap [ with ] each 2drop ; inline
 
-: reduce ( seq identity quot -- value | quot: x y -- z )
+: reduce ( seq identity quot -- value ) | quot ( x y -- z )
     swapd each ; inline
 
-: map ( seq quot -- seq | quot: elt -- elt )
+: map ( seq quot -- seq ) | quot ( elt -- elt )
     over >r over length [ (map) ] collect r> like 2nip ;
     inline
 
-: map-with ( obj list quot -- list | quot: obj elt -- elt )
+: map-with ( obj list quot -- list ) | quot ( obj elt -- elt )
     swap [ with rot ] map 2nip ; inline
 
-: accumulate ( seq identity quot -- values | quot: x y -- z )
+: accumulate ( seq identity quot -- values ) | quot ( x y -- z )
     rot [ pick >r swap call r> ] map-with nip ; inline
 
 : change-nth ( i seq quot -- )
     -rot [ nth swap call ] 2keep set-nth ; inline
 
-: inject ( seq quot -- | quot: elt -- elt )
+: inject ( seq quot -- ) | quot ( elt -- elt )
     over length
     [ [ -rot change-nth ] 3keep ] repeat 2drop ;
     inline
 
-: inject-with ( obj seq quot -- | quot: obj elt -- elt )
+: inject-with ( obj seq quot -- ) | quot ( obj elt -- elt )
     swap [ with rot ] inject 2drop ; inline
 
 : min-length ( seq seq -- n )
@@ -73,7 +73,7 @@ IN: sequences
 : 2each ( seq seq quot -- )
     -rot 2dup min-length [ (2each) ] repeat 3drop ; inline
 
-: 2reduce ( seq seq identity quot -- value | quot: e x y -- z )
+: 2reduce ( seq seq identity quot -- value ) | quot ( e x y -- z )
     >r -rot r> 2each ; inline
 
 : 2map ( seq seq quot -- seq )
@@ -93,13 +93,13 @@ IN: sequences
         ] if
     ] if-bounds ; inline
 
-: find-with* ( obj i seq quot -- i elt | quot: elt -- ? )
+: find-with* ( obj i seq quot -- i elt ) | quot ( elt -- ? )
     -rot [ with rot ] find* 2swap 2drop ; inline
 
-: find ( seq quot -- i elt | quot: elt -- ? )
+: find ( seq quot -- i elt ) | quot ( elt -- ? )
     0 -rot find* ; inline
 
-: find-with ( obj seq quot -- i elt | quot: elt -- ? )
+: find-with ( obj seq quot -- i elt ) | quot ( elt -- ? )
     swap [ with rot ] find 2swap 2drop ; inline
 
 : find-last* ( i seq quot -- i elt )
@@ -111,13 +111,13 @@ IN: sequences
         ] if
     ] if-bounds ; inline
 
-: find-last-with* ( obj i seq quot -- i elt | quot: elt -- ? )
+: find-last-with* ( obj i seq quot -- i elt ) | quot ( elt -- ? )
     -rot [ with rot ] find-last* 2swap 2drop ; inline
 
 : find-last ( seq quot -- i elt )
     >r [ length 1- ] keep r> find-last* ; inline
 
-: find-last-with ( obj seq quot -- i elt | quot: elt -- ? )
+: find-last-with ( obj seq quot -- i elt ) | quot ( elt -- ? )
     swap [ with rot ] find-last 2swap 2drop ; inline
 
 : contains? ( seq quot -- ? )
@@ -129,20 +129,20 @@ IN: sequences
 : all? ( seq quot -- ? )
     swap [ swap call not ] contains-with? not ; inline
 
-: all-with? ( obj seq quot -- ? | quot: elt -- ? )
+: all-with? ( obj seq quot -- ? ) | quot ( elt -- ? )
     swap [ with rot ] all? 2nip ; inline
 
-: subset ( seq quot -- seq | quot: elt -- ? )
+: subset ( seq quot -- seq ) | quot ( elt -- ? )
     over >r over length <vector> rot [
         -rot [
             >r over >r call [ r> r> push ] [ r> r> 2drop ] if
         ] 2keep
     ] each r> like nip ; inline
 
-: subset-with ( obj seq quot -- seq | quot: obj elt -- ? )
+: subset-with ( obj seq quot -- seq ) | quot ( obj elt -- ? )
     swap [ with rot ] subset 2nip ; inline
 
-: monotonic? ( seq quot -- ? | quot: elt elt -- ? )
+: monotonic? ( seq quot -- ? ) | quot ( elt elt -- ? )
     swap dup length 1- [
         pick pick >r >r (monotonic) r> r> rot
     ] all? 2nip ; inline
@@ -154,7 +154,7 @@ IN: sequences
         if
     ] 2each 2drop ; inline
 
-: cache-nth ( i seq quot -- elt | quot: i -- elt )
+: cache-nth ( i seq quot -- elt ) | quot ( i -- elt )
     pick pick ?nth dup [
         >r 3drop r>
     ] [

library/collections/sequences-epilogue.factor

@@ -47,7 +47,7 @@ M: object like drop ;
     pick pick number=
     [ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
 
-: (delete) ( elt store scan seq -- )
+: (delete) ( elt store scan seq -- elt store scan seq )
     2dup length < [
         3dup move
         [ nth pick = ] 2keep rot

library/compiler/alien/compiler.factor

@@ -22,7 +22,7 @@ kernel-internals math namespaces sequences words ;
 : fastcall-param ( reg-class -- n reg-class )
     [ dup class get swap inc-reg-class ] keep ;
 
-: alloc-parameter ( parameter -- n reg reg-class )
+: alloc-parameter ( parameter -- reg reg-class )
     #! Allocate a register and stack frame location.
     #! n is a stack location, and the value of the class
     #! variable is a register number.

library/compiler/alien/structs.factor

@@ -31,7 +31,6 @@ sequences strings words ;
 : define-field ( offset type name -- offset )
     >r dup >r c-align align r> r>
     "struct-name" get swap "-" swap append3
-    ( offset type name -- )
     3dup define-getter 3dup define-setter
     drop c-size + ;
 

library/compiler/generator/architecture.factor

@@ -133,7 +133,7 @@ M: float-regs inc-reg-class
     dup (inc-reg-class)
     macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
 
-GENERIC: v>operand
+GENERIC: v>operand ( obj -- operand )
 M: integer v>operand tag-bits shift ;
 M: vreg v>operand dup vreg-n swap vregs nth ;
 M: f v>operand drop object-tag ;

library/compiler/generator/generator.factor

@@ -4,7 +4,7 @@ IN: compiler
 USING: arrays assembler errors generic hashtables inference
 kernel kernel-internals math namespaces sequences words ;
 
-GENERIC: stack-reserve*
+GENERIC: stack-reserve* ( node -- n )
 
 M: object stack-reserve* drop 0 ;
 
@@ -44,7 +44,7 @@ UNION: #terminal
     V{ } clone literal-table set
     V{ } clone label-table set ;
 
-: generate-1 ( word node quot -- | quot: node -- )
+: generate-1 ( word node quot -- ) | quot ( node -- )
     #! Generate the code, then dump three vectors to pass to
     #! add-compiled-block.
     pick f save-xt [
@@ -99,10 +99,10 @@ M: #if generate-node
 : [with-template] ( quot template -- quot )
     2array >quotation [ with-template ] append ;
 
-: define-intrinsic ( word quot template -- | quot: -- )
+: define-intrinsic ( word quot template -- ) | quot ( -- )
     [with-template] "intrinsic" set-word-prop ;
 
-: define-if-intrinsic ( word quot template -- | quot: label -- )
+: define-if-intrinsic ( word quot template -- ) | quot ( label -- )
     [with-template] "if-intrinsic" set-word-prop ;
 
 : if>boolean-intrinsic ( label -- )

library/compiler/generator/templates.factor

@@ -37,7 +37,7 @@ C: phantom-stack ( -- stack )
     0 over set-phantom-stack-height
     V{ } clone over set-delegate ;
 
-GENERIC: finalize-height ( n stack -- )
+GENERIC: finalize-height ( stack -- )
 
 GENERIC: <loc> ( n stack -- loc )
 
@@ -240,7 +240,7 @@ SYMBOL: +clobber
 : requested-vregs ( template -- int# float# )
     dup length swap [ float eq? ] subset length [ - ] keep ;
 
-: (requests-class?) ( class template -- )
+: (requests-class?) ( class template -- ? )
     [ second reg-spec>class eq? ] contains-with? ;
 
 : requests-class? ( class -- ? )

library/compiler/generator/xt.factor

@@ -43,7 +43,7 @@ SYMBOL: label-table
 : rel-relative-2 5 ;
 : rel-relative-3 6 ;
 
-: (rel) ( arg class type offset -- { type offset } )
+: (rel) ( arg class type offset -- pair )
     #! Write a relocation instruction for the runtime image
     #! loader.
     pick rel-absolute-cell = cell 4 ? -

library/compiler/inference/branches.factor

@@ -7,7 +7,7 @@ namespaces parser prettyprint sequences strings vectors words ;
 : unify-lengths ( seq -- seq )
     #! Pad all vectors to the same length. If one vector is
     #! shorter, pad it with unknown results at the bottom.
-    dup 0 [ length max ] reduce
+    dup [ length ] map supremum
     swap [ add-inputs nip ] map-with ;
 
 : unify-values ( seq -- value )
@@ -25,7 +25,7 @@ namespaces parser prettyprint sequences strings vectors words ;
     [ swap unparse " " rot length unparse append3 ] 2map
     "Unbalanced branches:" add* "\n" join inference-error ;
 
-: unify-inputs ( max-d-in meta-d -- meta-d )
+: unify-inputs ( max-d-in d-in meta-d -- meta-d )
     dup [
         [ >r - r> length + ] keep add-inputs nip
     ] [
@@ -72,42 +72,16 @@ namespaces parser prettyprint sequences strings vectors words ;
     dataflow-graph off
     current-node off ;
 
-: no-base-case ( -- )
-    "Cannot infer base case" inference-error ;
-
-: recursive-branch ( hash ? -- obj )
-    #! If the branch made an unresolved recursive call, and we
-    #! are inferring the base case, ignore the branch (the base
-    #! case being the stack effect of the branches not making
-    #! recursive calls). Otherwise, raise an error.
-    [
-        base-case-continuation get
-        [ drop f ] [ no-base-case ] if
-    ] when ;
-
 : infer-branch ( value -- namespace )
-    #! Return a namespace with inferencer variables:
-    #! meta-d, meta-r, d-in. They are set to f if
-    #! terminate was called.
     [
-        [
-            base-case-continuation set
         copy-inference
         dup value-recursion recursive-state set
-            dup value-literal infer-quot
+        value-literal infer-quot
         terminated? get [ #values node, ] unless
-            f
+    ] make-hash ;
-        ] callcc1 nip
-    ] make-hash swap recursive-branch ;
-
-: notify-base-case ( -- )
-    base-case-continuation get
-    [ t swap continue-with ] [ no-base-case ] if* ;
 
 : (infer-branches) ( branchlist -- list )
-    [ infer-branch ] map [ ] subset
+    [ infer-branch ] map dup unify-effects unify-dataflow ;
-    dup empty? [ notify-base-case ] when
-    dup unify-effects unify-dataflow ;
 
 : infer-branches ( branches node -- )
     #! Recursive stack effect inference is done here. If one of

library/compiler/inference/dataflow.factor

@@ -144,7 +144,7 @@ SYMBOL: current-node
 : #drop ( n -- #shuffle )
     d-tail in-node <#shuffle> ;
 
-: each-node ( node quot -- | quot: node -- )
+: each-node ( node quot -- ) | quot ( node -- )
     over [
         [ call ] 2keep swap
         [ node-children [ swap each-node ] each-with ] 2keep
@@ -153,10 +153,10 @@ SYMBOL: current-node
         2drop
     ] if ; inline
 
-: each-node-with ( obj node quot -- | quot: obj node -- )
+: each-node-with ( obj node quot -- ) | quot ( obj node -- )
     swap [ with ] each-node 2drop ; inline
 
-: all-nodes? ( node quot -- ? | quot: node -- ? )
+: all-nodes? ( node quot -- ? ) | quot ( node -- ? )
     over [
         [ call ] 2keep rot [
             [
@@ -173,7 +173,7 @@ SYMBOL: current-node
         2drop t
     ] if ; inline
 
-: all-nodes-with? ( obj node quot -- ? | quot: obj node -- ? )
+: all-nodes-with? ( obj node quot -- ? ) | quot ( obj node -- ? )
     swap [ with rot ] all-nodes? 2nip ; inline
 
 : remember-node ( word node -- )
@@ -237,20 +237,20 @@ DEFER: (map-nodes)
         drop
     ] if* ; inline
 
-: (map-nodes) ( prev quot -- | quot: node -- node )
+: (map-nodes) ( prev quot -- ) | quot ( node -- node )
     node@
     [ [ map-node ] keep map-next ]
     [ drop f swap ?set-node-successor ] if ; inline
 
-: map-first ( node quot -- node | quot: node -- node )
+: map-first ( node quot -- node ) | quot ( node -- node )
     call node> drop dup >node ; inline
 
-: map-nodes ( node quot -- node | quot: node -- node )
+: map-nodes ( node quot -- node ) | quot ( node -- node )
     over [
         over >node [ map-first ] keep map-next node>
     ] when drop ; inline
 
-: map-children ( quot -- | quot: node -- node )
+: map-children ( quot -- ) | quot ( node -- node )
     node@ [ node-children [ swap map-nodes ] map-with ] keep
     set-node-children ; inline
 

library/compiler/inference/inference.factor

@@ -5,10 +5,6 @@ USING: arrays errors generic inspector interpreter io kernel
 math namespaces parser prettyprint sequences strings
 vectors words ;
 
-! Called when a recursive call during base case inference is
-! found. Either tries to infer another branch, or gives up.
-SYMBOL: base-case-continuation
-
 TUPLE: inference-error message rstate data-stack call-stack ;
 
 : inference-error ( msg -- * )
@@ -81,7 +77,7 @@ M: wrapper apply-object wrapped apply-literal ;
     #! Ignore this branch's stack effect.
     terminated? on #terminate node, ;
 
-GENERIC: infer-quot
+GENERIC: infer-quot ( quot -- )
 
 M: f infer-quot drop ;
 
@@ -105,14 +101,13 @@ M: quotation infer-quot
 : with-infer ( quot -- )
     [
         [
-            base-case-continuation off
             { } recursive-state set
             V{ } clone recorded set
             f init-inference
             call
             check-return
         ] [
-            recorded get dup . [ f "infer-effect" set-word-prop ] each
+            recorded get [ f "infer-effect" set-word-prop ] each
             rethrow
         ] recover
     ] with-scope ;

library/compiler/inference/words.factor

@@ -14,12 +14,23 @@ IN: inference
     >r [ drop <computed> ] map dup r> set-node-out-d
     meta-d get swap nappend ;
 
+: recursing? ( word -- label/f )
+    recursive-state get <reversed> assoc ;
+
+: make-call-node ( word -- node )
+    dup "inline" word-prop
+    [ dup recursing? [ #call-label ] [ #call ] ?if ]
+    [ #call ]
+    if ;
+
 : consume/produce ( word effect -- )
     #! Add a node to the dataflow graph that consumes and
     #! produces a number of values.
-    swap #call
+    meta-d get clone >r
+    swap make-call-node
     over effect-in length over consume-values
     over effect-out length over produce-values
+    r> over #call-label? [ over set-node-in-d ] [ drop ] if
     node, effect-terminated? [ terminate ] when ;
 
 : no-effect ( word -- )
@@ -27,21 +38,19 @@ IN: inference
     " was already attempted, and failed" append3
     inference-error ;
 
-TUPLE: rstate label count ;
-
 : nest-node ( -- ) #entry node, ;
 
 : unnest-node ( new-node -- new-node )
     dup node-param #return node,
     dataflow-graph get 1array over set-node-children ;
 
-: add-recursive-state ( word label count -- )
+: add-recursive-state ( word label -- )
-    <rstate> 2array recursive-state [ swap add ] change ;
+    2array recursive-state [ swap add ] change ;
 
-: inline-block ( word count -- node-block variables )
+: inline-block ( word -- node-block variables )
     [
         copy-inference nest-node
-        >r gensym 2dup r> add-recursive-state
+        gensym 2dup add-recursive-state
         #label >r word-def infer-quot r>
         unnest-node
     ] make-hash ;
@@ -69,7 +78,7 @@ M: #call-label collect-recursion*
     #! and which don't (loop indices, etc). The latter cannot
     #! be folded.
     collect-recursion meta-d get add unify-lengths unify-stacks
-    meta-d [ length tail* ] change ;
+    meta-d [ length tail* >vector ] change ;
 
 : splice-node ( node -- )
     #! Labels which do not call themselves are just spliced into
@@ -84,23 +93,18 @@ M: #call-label collect-recursion*
     #! 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 0 inline-block over recursive-label? [
+    dup inline-block over recursive-label? [
         meta-d get >r
-        drop join-values 0 inline-block apply-infer
+        drop join-values inline-block apply-infer
         r> over set-node-in-d node,
     ] [
         apply-infer node-child node-successor splice-node drop
     ] if ;
 
-: infer-compound ( word count -- effect )
+: infer-compound ( word -- 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
-    #! continuation.
     [
         recursive-state get init-inference
-        over >r inline-block nip
+        [ inline-block nip [ current-effect ] bind ] keep
-        [ current-effect ] bind r>
     ] with-scope over consume/produce ;
 
 GENERIC: apply-word
@@ -111,7 +115,7 @@ M: object apply-word
 
 TUPLE: effect-error word effect ;
 
-: effect-error ( -- * ) <effect-error> throw ;
+: effect-error ( word effect -- * ) <effect-error> throw ;
 
 : check-effect ( word effect -- )
     over recorded get push
@@ -122,7 +126,7 @@ TUPLE: effect-error word effect ;
 M: compound apply-word
     #! Infer a compound word's stack effect.
     [
-        dup 0 infer-compound check-effect
+        dup infer-compound check-effect
     ] [
         swap t "no-effect" set-word-prop rethrow
     ] recover ;
@@ -158,7 +162,7 @@ M: symbol apply-object apply-literal ;
 
 M: compound apply-object
     #! Apply the word's stack effect to the inferencer state.
-    dup recursive-state get <reversed> assoc [
+    dup recursing? [
         dup recursive-effect consume/produce
     ] [
         dup "inline" word-prop

library/compiler/optimizer/call-optimizers.factor

@@ -30,7 +30,7 @@ math math-internals sequences words parser ;
     [ with-datastack ] catch
     [ 3drop t ] [ inline-literals ] if ;
 
-: call>no-op ( not -- )
+: call>no-op ( not -- node/f )
     #! Note: cloning the vectors, since subst-values will modify
     #! them.
     [ node-in-d clone ] keep

library/compiler/optimizer/print-dataflow.factor

@@ -5,7 +5,7 @@ math namespaces prettyprint sequences styles vectors words ;
 ! A simple tool for turning dataflow IR into quotations, for
 ! debugging purposes.
 
-GENERIC: node>quot ( node -- )
+GENERIC: node>quot ( ? node -- )
 
 TUPLE: comment node text ;
 

library/compiler/ppc/architecture.factor

@@ -25,7 +25,7 @@ M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
 : stack@ macosx? 24 8 ? + ;
 : lr@ macosx? 8 4 ? + ;
 
-GENERIC: loc>operand
+GENERIC: loc>operand ( loc -- reg n )
 
 M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
 M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;

library/compiler/ppc/assembler.factor

@@ -166,7 +166,7 @@ M: label (B) 0 -rot (B) rel-relative-3 rel-label ;
 
 : B 0 0 (B) ; : BL 0 1 (B) ;
 
-GENERIC: BC
+GENERIC: BC ( a b c -- )
 M: integer BC 0 0 b-form 16 insn ;
 M: word BC >r 0 BC r> rel-relative-2 rel-word ;
 M: label BC >r 0 BC r> rel-relative-2 rel-label ;

library/errors.factor

@@ -42,7 +42,7 @@ C: condition ( error restarts cc -- condition )
 : condition ( error restarts -- restart )
     [ <condition> throw ] callcc1 2nip ;
 
-GENERIC: compute-restarts
+GENERIC: compute-restarts ( error -- seq )
 
 M: object compute-restarts drop { } ;
 

library/generic/classes.factor

@@ -3,7 +3,7 @@
 IN: generic
 USING: arrays definitions errors hashtables kernel
 kernel-internals namespaces parser sequences strings words
-vectors math ;
+vectors math parser ;
 
 PREDICATE: word class "class" word-prop ;
 
@@ -17,8 +17,11 @@ SYMBOL: builtins
 : predicate-word ( word -- word )
     word-name "?" append create-in ;
 
+: predicate-effect 1 1 <effect> ;
+
 : define-predicate ( class predicate quot -- )
     over [
+        over predicate-effect "declared-effect" set-word-prop
         dupd define-compound
         2dup unit "predicate" set-word-prop
         swap "predicating" set-word-prop

library/help/porter-stemmer.factor

@@ -138,7 +138,7 @@ USING: kernel math parser sequences ;
         }
     } cond ;
 
-: step1b ( str -- str ? )
+: step1b ( str -- str )
     {
         { [ "eed" ?tail ] [ -eed ] }
         {

library/help/topics.factor

@@ -5,7 +5,7 @@ USING: arrays definitions errors generic graphs hashtables
 inspector io kernel namespaces prettyprint sequences words ;
 
 ! Markup
-GENERIC: print-element
+GENERIC: print-element ( element -- )
 
 ! Help articles
 SYMBOL: articles

library/io/unix/io.factor

@@ -91,7 +91,7 @@ M: port set-timeout
 ! Associates a port with a list of continuations waiting on the
 ! port to finish I/O
 TUPLE: io-task port callbacks ;
-C: io-task ( port -- )
+C: io-task ( port -- task )
     [ set-io-task-port ] keep
     V{ } clone over set-io-task-callbacks ;
 
@@ -132,7 +132,7 @@ GENERIC: task-container ( task -- vector )
         ] if
     ] hash-each-with ;
 
-: init-fdset ( fdset tasks -- )
+: init-fdset ( fdset tasks -- fdset )
     >r dup dup FD_SETSIZE clear-bits r>
     [ drop t swap rot set-bit-nth ] hash-each-with ;
 
@@ -204,7 +204,7 @@ M: input-port stream-read1
 
 ! Reading character counts
 : read-step ( count reader -- ? )
-    dup port-sbuf -rot >r over length - ( remaining) r>
+    dup port-sbuf -rot >r over length - r>
     2dup buffer-length <= [
         buffer> nappend t
     ] [

library/io/unix/sockets.factor

@@ -32,14 +32,14 @@ threads unix-internals ;
 : server-sockaddr ( port -- sockaddr )
     init-sockaddr  INADDR_ANY htonl over set-sockaddr-in-addr ;
 
-: sockopt ( fd level opt value -- )
+: sockopt ( fd level opt -- )
     1 <int> "int" c-size setsockopt io-error ;
 
 : server-socket ( port -- fd )
     server-sockaddr [
         dup SOL_SOCKET SO_REUSEADDR sockopt
         swap dupd "sockaddr-in" c-size bind
-        dup 0 >= [ drop 1 listen ] [ ( fd n - n) nip ] if
+        dup 0 >= [ drop 1 listen ] [ nip ] if
     ] with-socket-fd ;
 
 TUPLE: connect-task ;

library/math/math.factor

@@ -64,7 +64,7 @@ M: object zero? drop f ;
 
 : repeat 0 -rot (repeat) ; inline
 
-: times ( n quot -- | quot: -- )
+: times ( n quot -- ) | quot ( -- )
     swap [ >r dup slip r> ] repeat drop ; inline
 
 GENERIC: number>string ( n -- str ) foldable

library/syntax/parser.factor

@@ -92,7 +92,7 @@ TUPLE: bad-escape ;
 
 SYMBOL: effect-stack
 
-: (parse-effect)
+: (parse-effect) ( -- )
     scan [
         dup ")" = [ drop ] [ , (parse-effect) ] if
     ] [

library/test/inference.factor

@@ -205,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#

library/tools/debugger.factor

@@ -90,6 +90,6 @@ SYMBOL: restarts
 
 : init-error-handler ( -- )
     V{ } clone set-catchstack
-    ( kernel calls on error )
+    ! kernel calls on error
     [ error-handler ] 5 setenv
     \ kernel-error 12 setenv ;

library/ui/freetype/freetype-gl.factor

@@ -87,12 +87,12 @@ C: font ( handle -- font )
     [ set-font-handle ] keep dup init-font
     V{ } clone over set-font-widths ;
 
-: open-font ( { font style ptsize } -- font )
+: open-font ( fontspec -- font )
     #! Open a font and set the point size of the font.
     first3 >r open-face dup 0 r> 6 shift
     dpi dpi FT_Set_Char_Size freetype-error <font> ;
 
-: lookup-font ( { font style ptsize } -- font )
+: lookup-font ( fontspec -- font )
     #! Cache open fonts.
     open-fonts get [ open-font ] cache ;
 

library/ui/gadgets.factor

@@ -76,8 +76,7 @@ M: gadget children-on nip gadget-children ;
 : pick-up-list ( rect/point gadget -- gadget/f )
     dupd children-on <reversed> [ inside? ] find-with nip ;
 
-: translate ( rect/point -- new-origin )
+: translate ( rect/point -- ) rect-loc origin [ v+ ] change ;
-    rect-loc origin [ v+ ] change ;
 
 : pick-up ( rect/point gadget -- gadget )
     [

library/ui/gadgets/labels.factor

@@ -13,7 +13,7 @@ C: label ( text -- label )
     [ set-label-text ] keep
     dup label-theme ;
 
-: label-size ( gadget text -- dim )
+: label-size ( gadget -- dim )
     dup label-font lookup-font dup font-height >r
     swap label-text string-width r> 2array ;
 

library/ui/gadgets/scrolling.factor

@@ -9,7 +9,7 @@ gadgets-viewports generic kernel math namespaces sequences ;
 ! down on the next relayout.
 TUPLE: scroller viewport x y follows ;
 
-: scroller-origin ( scroller -- { x y } )
+: scroller-origin ( scroller -- point )
     dup scroller-x slider-value
     swap scroller-y slider-value
     2array ;

library/ui/hierarchy.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets
 USING: generic hashtables inference kernel math namespaces
-sequences vectors words ;
+sequences vectors words parser ;
 
 GENERIC: graft* ( gadget -- )
 
@@ -61,7 +61,7 @@ M: gadget ungraft* drop ;
     #! Add all gadgets in a sequence to a parent gadget.
     swap [ over (add-gadget) ] each relayout ;
 
-: add-spec ( quot { quot setter post loc } -- )
+: add-spec ( quot spec -- )
     dup first %
     dup second [ [ dup gadget get ] % , ] when*
     dup third %
@@ -75,7 +75,7 @@ M: gadget ungraft* drop ;
 : build-spec ( spec quot -- )
     swap (build-spec) call ;
 
-\ build-spec { 2 0 } "infer-effect" set-word-prop
+\ build-spec 2 0 <effect> "infer-effect" set-word-prop
 
 \ build-spec [
     pop-literal pop-literal nip (build-spec) infer-quot-value

library/ui/opengl/opengl-utils.factor

@@ -81,7 +81,7 @@ sequences ;
 ! A sprite is a texture and a display list.
 TUPLE: sprite dlist texture loc dim dim2 ;
 
-C: sprite ( loc dim dim2 -- )
+C: sprite ( loc dim dim2 -- sprite )
     [ set-sprite-dim2 ] keep
     [ set-sprite-dim ] keep
     [ set-sprite-loc ] keep ;
@@ -116,7 +116,7 @@ C: sprite ( loc dim dim2 -- )
     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf
     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf ;
 
-: gl-translate ( { x y } -- ) first2 0.0 glTranslated ;
+: gl-translate ( point -- ) first2 0.0 glTranslated ;
 
 : draw-sprite ( sprite -- )
     dup sprite-loc gl-translate

library/ui/text/document.factor

@@ -53,7 +53,7 @@ C: document ( -- document )
     tuck >r >r document get -rot start-on-line r> r>
     document get -rot end-on-line ;
 
-: (doc-range) ( startloc endloc line# -- str )
+: (doc-range) ( startloc endloc line# -- )
     [ start/end-on-line ] keep document get doc-line <slice> , ;
 
 : doc-range ( startloc endloc document -- str )
@@ -70,10 +70,10 @@ C: document ( -- document )
         first swap length 1- + 0
     ] if r> peek length + 2array ;
 
-: prepend-first ( str seq -- seq )
+: prepend-first ( str seq -- )
     0 swap [ append ] change-nth ;
 
-: append-last ( str seq -- seq )
+: append-last ( str seq -- )
     [ length 1- ] keep [ swap append ] change-nth ;
 
 : loc-col/str ( loc document -- str col )

library/ui/text/editor.factor

@@ -20,7 +20,7 @@ TUPLE: loc-monitor editor ;
     dup <loc> over set-editor-caret
     dup <loc> swap set-editor-mark ;
 
-C: editor ( document -- editor )
+C: editor ( -- editor )
     dup <document> delegate>control
     dup dup set-control-self
     dup init-editor-locs

library/ui/world.factor

@@ -65,7 +65,7 @@ M: world model-changed
 : focused-ancestors ( world -- seq )
     world-focus parents <reversed> ;
 
-: font-sprites ( font world -- { open-font sprites } )
+: font-sprites ( font world -- pair )
     world-fonts [ lookup-font V{ } clone 2array ] cache ;
 
 : draw-string ( font string -- )

library/words.factor

@@ -49,10 +49,10 @@ M: symbol definer drop \ SYMBOL: ;
     [ rot word-props set-hash ]
     [ nip remove-word-prop ] if ;
 
-GENERIC: word-xt
+GENERIC: word-xt ( word -- xt )
 M: word word-xt 7 integer-slot ;
 
-GENERIC: set-word-xt
+GENERIC: set-word-xt ( xt word -- )
 M: word set-word-xt 7 set-integer-slot ;
 
 SYMBOL: vocabularies

vm/compiler.c

@@ -53,7 +53,7 @@ CELL get_rel_word(F_REL *rel, CELL literal_start)
 	CELL arg = REL_ARGUMENT(rel);
 	F_WORD *word = untag_word(get_literal(literal_start,arg));
 	if(word->xt < compiling.base || word->xt >= compiling.limit)
-		critical_error("Bad XT",tag_word(word));
+		fprintf(stderr,"Bad XT %x",tag_word(word));
 	return word->xt;
 }