Merge branch 'master' of git://factorcode.org/git/factor

basis/alien/c-types/c-types-tests.factor

@@ -4,7 +4,7 @@ sequences system libc alien.strings io.encodings.utf8 ;
 
 \ expand-constants must-infer
 
-: xyz 123 ;
+CONSTANT: xyz 123
 
 [ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
 

basis/alien/structs/fields/fields.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel kernel.private math namespaces
 make sequences strings words effects combinators alien.c-types ;
@@ -6,28 +6,6 @@ IN: alien.structs.fields
 
 TUPLE: field-spec name offset type reader writer ;
 
-: reader-effect ( type spec -- effect )
-    [ 1array ] [ name>> 1array ] bi* <effect> ;
-
-PREDICATE: slot-reader < word "reading" word-prop >boolean ;
-
-: set-reader-props ( class spec -- )
-    2dup reader-effect
-    over reader>>
-    swap "declared-effect" set-word-prop
-    reader>> swap "reading" set-word-prop ;
-
-: writer-effect ( type spec -- effect )
-    name>> swap 2array 0 <effect> ;
-
-PREDICATE: slot-writer < word "writing" word-prop >boolean ;
-
-: set-writer-props ( class spec -- )
-    2dup writer-effect
-    over writer>>
-    swap "declared-effect" set-word-prop
-    writer>> swap "writing" set-word-prop ;
-
 : reader-word ( class name vocab -- word )
     [ "-" glue ] dip create ;
 
@@ -55,17 +33,13 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
 : define-struct-slot-word ( word quot spec effect -- )
     [ offset>> prefix ] dip define-inline ;
 
-: define-getter ( type spec -- )
+: define-getter ( spec -- )
-    [ set-reader-props ] keep
+    [ reader>> ] [ type>> c-type-getter-boxer ] [ ] tri
-    [ reader>> ]
-    [ type>> c-type-getter-boxer ]
-    [ ] tri
     (( c-ptr -- value )) define-struct-slot-word ;
 
-: define-setter ( type spec -- )
+: define-setter ( spec -- )
-    [ set-writer-props ] keep
     [ writer>> ] [ type>> c-setter ] [ ] tri
     (( value c-ptr -- )) define-struct-slot-word ;
 
-: define-field ( type spec -- )
+: define-field ( spec -- )
-    [ define-getter ] [ define-setter ] 2bi ;
+    [ define-getter ] [ define-setter ] bi ;

basis/alien/structs/structs-tests.factor

@@ -24,7 +24,7 @@ os winnt? cpu x86? and [
     ] when
 ] when
 
-: MAX_FOOS 30 ;
+CONSTANT: MAX_FOOS 30
 
 C-STRUCT: foox
     { { "int" MAX_FOOS } "x" } ;

basis/alien/structs/structs.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs generic hashtables kernel kernel.private
 math namespaces parser sequences strings words libc fry
@@ -56,10 +56,10 @@ M: struct-type stack-size
 : (define-struct) ( name size align fields -- )
     [ [ align ] keep ] dip
     struct-type new
-    swap >>fields
+        swap >>fields
-    swap >>align
+        swap >>align
-    swap >>size
+        swap >>size
-    swap typedef ;
+        swap typedef ;
 
 : make-fields ( name vocab fields -- fields )
     [ first2 <field-spec> ] with with map ;
@@ -68,12 +68,11 @@ M: struct-type stack-size
     [ c-type-align ] [ max ] map-reduce ;
 
 : define-struct ( name vocab fields -- )
-    [
+    [ 2drop ] [ make-fields ] 3bi
-        [ 2drop ] [ make-fields ] 3bi
+    [ struct-offsets ] keep
-        [ struct-offsets ] keep
+    [ [ type>> ] map compute-struct-align ] keep
-        [ [ type>> ] map compute-struct-align ] keep
+    [ (define-struct) ] keep
-        [ (define-struct) ] keep
+    [ define-field ] each ;
-    ] [ 2drop '[ _ swap define-field ] ] 3bi each ;
 
 : define-union ( name members -- )
     [ expand-constants ] map
@@ -83,4 +82,3 @@ M: struct-type stack-size
 : offset-of ( field struct -- offset )
     c-types get at fields>> 
     [ name>> = ] with find nip offset>> ;
-

basis/bit-vectors/bit-vectors-tests.factor

@@ -3,7 +3,7 @@ USING: tools.test bit-vectors vectors sequences kernel math ;
 
 [ 0 ] [ 123 <bit-vector> length ] unit-test
 
-: do-it
+: do-it ( seq -- )
     1234 swap [ [ even? ] dip push ] curry each ;
 
 [ t ] [

basis/bootstrap/image/image.factor

@@ -95,10 +95,10 @@ CONSTANT: -1-offset             9
 SYMBOL: sub-primitives
 
 : make-jit ( quot rc rt offset -- quad )
-    [ { } make ] 3dip 4array ; inline
+    [ [ call( -- ) ] { } make ] 3dip 4array ;
 
 : jit-define ( quot rc rt offset name -- )
-    [ make-jit ] dip set ; inline
+    [ make-jit ] dip set ;
 
 : define-sub-primitive ( quot rc rt offset word -- )
     [ make-jit ] dip sub-primitives get set-at ;
@@ -398,9 +398,14 @@ M: byte-array '
     ] emit-object ;
 
 ! Tuples
+ERROR: tuple-removed class ;
+
+: require-tuple-layout ( word -- layout )
+    dup tuple-layout [ ] [ tuple-removed ] ?if ;
+
 : (emit-tuple) ( tuple -- pointer )
     [ tuple-slots ]
-    [ class transfer-word tuple-layout ] bi prefix [ ' ] map
+    [ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
     tuple type-number dup [ emit-seq ] emit-object ;
 
 : emit-tuple ( tuple -- pointer )

basis/byte-vectors/byte-vectors-tests.factor

@@ -4,7 +4,7 @@ prettyprint ;
 
 [ 0 ] [ 123 <byte-vector> length ] unit-test
 
-: do-it
+: do-it ( seq -- seq )
     123 [ over push ] each ;
 
 [ t ] [

basis/calendar/calendar-tests.factor

@@ -148,7 +148,7 @@ IN: calendar.tests
 [ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
 [ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
 
-: checktime+ now dup clone [ rot time+ drop ] keep = ;
+: checktime+ ( duration -- ? ) now dup clone [ rot time+ drop ] keep = ;
 
 [ t ] [ 5 seconds checktime+ ] unit-test
 

basis/cocoa/cocoa-tests.factor

@@ -13,7 +13,7 @@ CLASS: {
     [ gc "x" set 2drop ]
 } ;
 
-: test-foo
+: test-foo ( -- )
     Foo -> alloc -> init
     dup 1.0 2.0 101.0 102.0 <CGRect> -> foo:
     -> release ;

basis/compiler/compiler.factor

@@ -35,11 +35,14 @@ SYMBOLS: +optimized+ +unoptimized+ ;
     [ usage [ word? ] filter ] [ compiled-usage keys ] if
     [ queue-compile ] each ;
 
-: ripple-up? ( word status -- ? )
+: ripple-up? ( status word -- ? )
-    swap "compiled-status" word-prop [ = not ] keep and ;
+    [
+        [ nip changed-effects get key? ]
+        [ "compiled-status" word-prop eq? not ] 2bi or
+    ] keep "compiled-status" word-prop and ;
 
 : save-compiled-status ( word status -- )
-    [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
+    [ over ripple-up? [ ripple-up ] [ drop ] if ]
     [ "compiled-status" set-word-prop ]
     2bi ;
 

basis/compiler/tests/intrinsics.factor

@@ -270,7 +270,7 @@ cell 8 = [
 ] when
 
 ! Some randomized tests
-: compiled-fixnum* fixnum* ;
+: compiled-fixnum* ( a b -- c ) fixnum* ;
 
 [ ] [
     10000 [ 
@@ -281,7 +281,7 @@ cell 8 = [
     ] times
 ] unit-test
 
-: compiled-fixnum>bignum fixnum>bignum ;
+: compiled-fixnum>bignum ( a -- b ) fixnum>bignum ;
 
 [ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
 
@@ -293,7 +293,7 @@ cell 8 = [
     ] times
 ] unit-test
 
-: compiled-bignum>fixnum bignum>fixnum ;
+: compiled-bignum>fixnum ( a -- b ) bignum>fixnum ;
 
 [ ] [
     10000 [

basis/compiler/tests/optimizer.factor

@@ -13,7 +13,7 @@ M: array xyz xyz ;
 [ t ] [ \ xyz optimized>> ] unit-test
 
 ! Test predicate inlining
-: pred-test-1
+: pred-test-1 ( a -- b c )
     dup fixnum? [
         dup integer? [ "integer" ] [ "nope" ] if
     ] [
@@ -24,7 +24,7 @@ M: array xyz xyz ;
 
 TUPLE: pred-test ;
 
-: pred-test-2
+: pred-test-2 ( a -- b c )
     dup tuple? [
         dup pred-test? [ "pred-test" ] [ "nope" ] if
     ] [
@@ -33,7 +33,7 @@ TUPLE: pred-test ;
 
 [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
 
-: pred-test-3
+: pred-test-3 ( a -- b c )
     dup pred-test? [
         dup tuple? [ "pred-test" ] [ "nope" ] if
     ] [
@@ -42,14 +42,14 @@ TUPLE: pred-test ;
 
 [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
 
-: inline-test
+: inline-test ( a -- b )
     "nom" = ;
 
 [ t ] [ "nom" inline-test ] unit-test
 [ f ] [ "shayin" inline-test ] unit-test
 [ f ] [ 3 inline-test ] unit-test
 
-: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
+: fixnum-declarations ( a -- b ) >fixnum 24 shift 1234 bitxor ;
 
 [ ] [ 1000000 fixnum-declarations . ] unit-test
 
@@ -61,13 +61,13 @@ TUPLE: pred-test ;
 
 ! regression
 
-: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
+: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline recursive
-: bad-kill-2 bad-kill-1 drop ;
+: bad-kill-2 ( a b -- c d ) bad-kill-1 drop ;
 
 [ 3 ] [ t bad-kill-2 ] unit-test
 
 ! regression
-: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
+: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline recursive
 : the-test ( -- x y ) 2 dup (the-test) ;
 
 [ 2 0 ] [ the-test ] unit-test
@@ -77,7 +77,7 @@ TUPLE: pred-test ;
     < [
         6 1 (double-recursion)
         3 2 (double-recursion)
-    ] when ; inline
+    ] when ; inline recursive
 
 : double-recursion ( -- ) 0 2 (double-recursion) ;
 
@@ -85,7 +85,7 @@ TUPLE: pred-test ;
 
 ! regression
 : double-label-1 ( a b c -- d )
-    [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
+    [ f double-label-1 ] [ swap nth-unsafe ] if ; inline recursive
 
 : double-label-2 ( a -- b )
     dup array? [ ] [ ] if 0 t double-label-1 ;
@@ -100,7 +100,7 @@ GENERIC: void-generic ( obj -- * )
 
 ! regression
 : branch-fold-regression-0 ( m -- n )
-    t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
+    t [ ] [ 1+ branch-fold-regression-0 ] if ; inline recursive
 
 : branch-fold-regression-1 ( -- m )
     10 branch-fold-regression-0 ;
@@ -224,7 +224,7 @@ USE: binary-search.private
 ] unit-test
 
 ! Regression
-: empty-compound ;
+: empty-compound ( -- ) ;
 
 : node-successor-f-bug ( x -- * )
     [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
@@ -293,7 +293,7 @@ HINTS: recursive-inline-hang-3 array ;
 
 ! Wow
 : counter-example ( a b c d -- a' b' c' d' )
-    dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline
+    dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline recursive
 
 : counter-example' ( -- a' b' c' d' )
     1 2 3.0 3 counter-example ;

basis/compiler/tests/redefine15.factor

@@ -0,0 +1,20 @@
+USING: compiler.units words tools.test math kernel ;
+IN: compiler.tests.redefine15
+
+DEFER: word-1
+
+: word-2 ( a -- b ) word-1 ;
+
+[ \ word-1 [ ] (( a -- b )) define-declared ] with-compilation-unit 
+
+[ "a" ] [ "a" word-2 ] unit-test
+
+: word-3 ( a -- b ) 1 + ;
+
+: word-4 ( a -- b c ) 0 swap word-3 swap 1+ ;
+
+[ 1 1 ] [ 0 word-4 ] unit-test
+
+[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit
+
+[ 2 3 ] [ 0 word-4 ] unit-test

basis/compiler/tests/redefine2.factor

@@ -1,12 +1,14 @@
 IN: compiler.tests
 USING: compiler compiler.units tools.test math parser kernel
 sequences sequences.private classes.mixin generic definitions
-arrays words assocs eval ;
+arrays words assocs eval words.symbol ;
 
 DEFER: redefine2-test
 
 [ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
 
+[ t ] [ \ redefine2-test symbol? ] unit-test
+
 [ t ] [ redefine2-test new sequence? ] unit-test
 
 [ 3 ] [ 0 redefine2-test new nth-unsafe ] unit-test

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -90,7 +90,7 @@ M: object xyz ;
         [ swap [ call 1+ ] dip ] keep (i-repeat)
     ] if ; inline recursive
 
-: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
+: i-repeat ( n quot -- ) [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
 
 [ t ] [
     [ [ dup xyz drop ] i-repeat ] \ xyz inlined?
@@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ;
         [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
     ] if ; inline recursive
 
-: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
+: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline
 
 [ f ] [
     [ { bignum } declare annotate-entry-test-2 ]

basis/constructors/constructors.factor

@@ -18,6 +18,6 @@ MACRO: set-slots ( slots -- quot )
 
 SYNTAX: CONSTRUCTOR:
     scan-word [ name>> "<" ">" surround create-in ] keep
-    "(" expect ")" parse-effect
+    complete-effect
     parse-definition
     define-constructor ;

basis/cpu/ppc/bootstrap.factor

@@ -11,8 +11,8 @@ big-endian on
 
 4 jit-code-format set
 
-: ds-reg 29 ;
+CONSTANT: ds-reg 29
-: rs-reg 30 ;
+CONSTANT: rs-reg 30
 
 : factor-area-size ( -- n ) 4 bootstrap-cells ;
 

basis/db/tuples/tuples-tests.factor

@@ -285,7 +285,7 @@ paste "PASTE"
 [ test-cascade ] test-postgresql
 [ test-restrict ] test-postgresql
 
-: test-repeated-insert
+: test-repeated-insert ( -- )
     [ ] [ person ensure-table ] unit-test
     [ ] [ person1 get insert-tuple ] unit-test
     [ person1 get insert-tuple ] must-fail ;
@@ -458,7 +458,7 @@ TUPLE: bignum-test id m n o ;
         swap >>n
         swap >>m ;
 
-: test-bignum
+: test-bignum ( -- )
     bignum-test "BIGNUM_TEST"
     {
         { "id" "ID" +db-assigned-id+ }
@@ -478,7 +478,7 @@ TUPLE: bignum-test id m n o ;
 TUPLE: secret n message ;
 C: <secret> secret
 
-: test-random-id
+: test-random-id ( -- )
     secret "SECRET"
     {
         { "n" "ID" +random-id+ system-random-generator }

basis/delegate/delegate-tests.factor

@@ -41,13 +41,13 @@ M: hello bing hello-test ;
 
 [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
 
-GENERIC: one
+GENERIC: one ( a -- b )
 M: integer one ;
-GENERIC: two
+GENERIC: two ( a -- b )
 M: integer two ;
-GENERIC: three
+GENERIC: three ( a -- b )
 M: integer three ;
-GENERIC: four
+GENERIC: four ( a -- b )
 M: integer four ;
 
 PROTOCOL: alpha one two ;

basis/environment/environment-docs.factor

@@ -17,7 +17,7 @@ HELP: (set-os-envs)
 { $notes "In most cases, use " { $link set-os-envs } " instead." } ;
 
 
-HELP: os-env ( key -- value )
+HELP: os-env
 { $values { "key" string } { "value" string } }
 { $description "Looks up the value of a shell environment variable." }
 { $examples
@@ -39,14 +39,14 @@ HELP: set-os-envs
     "Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
 } ;
 
-HELP: set-os-env ( value key -- )
+HELP: set-os-env
 { $values { "value" string } { "key" string } }
 { $description "Set an environment variable." }
 { $notes
     "Names and values of environment variables are operating system-specific."
 } ;
 
-HELP: unset-os-env ( key -- )
+HELP: unset-os-env
 { $values { "key" string } }
 { $description "Unset an environment variable." }
 { $notes

basis/farkup/farkup-docs.factor

@@ -9,7 +9,7 @@ HELP: write-farkup
 { $values { "string" string } }
 { $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ;
 
-HELP: parse-farkup ( string -- farkup )
+HELP: parse-farkup
 { $values { "string" string } { "farkup" "a Farkup syntax tree node" } }
 { $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
 

basis/fry/fry-tests.factor

@@ -34,7 +34,7 @@ sequences eval accessors ;
     { "a" "b" "c" } swap map
 ] unit-test
 
-: funny-dip '[ [ @ ] dip ] call ; inline
+: funny-dip ( obj quot -- ) '[ [ @ ] dip ] call ; inline
 
 [ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
 

basis/functors/functors-tests.factor

@@ -13,7 +13,7 @@ WHERE
 
 TUPLE: B { value T } ;
 
-C: <B> B
+C: <B> B ( T -- B )
 
 ;FUNCTOR
 

basis/functors/functors.factor

@@ -14,9 +14,9 @@ IN: functors
 
 : scan-param ( -- obj ) scan-object literalize ;
 
-: define* ( word def effect -- ) pick set-word define-declared ;
+: define* ( word def -- ) over set-word define ;
 
-: define-syntax* ( word def -- ) over set-word define-syntax ;
+: define-declared* ( word def effect -- ) pick set-word define-declared ;
 
 TUPLE: fake-quotation seq ;
 
@@ -41,7 +41,12 @@ M: object fake-quotations> ;
 : parse-definition* ( accum -- accum )
     parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
 
-: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
+: parse-declared* ( accum -- accum )
+    complete-effect
+    [ parse-definition* ] dip
+    parsed ;
+
+: DEFINE* ( accum -- accum ) \ define-declared* parsed ;
 
 SYNTAX: `TUPLE:
     scan-param parsed
@@ -57,31 +62,28 @@ SYNTAX: `TUPLE:
     \ define-tuple-class parsed ;
 
 SYNTAX: `M:
-    effect off
     scan-param parsed
     scan-param parsed
     \ create-method-in parsed
     parse-definition*
-    DEFINE* ;
+    \ define* parsed ;
 
 SYNTAX: `C:
-    effect off
     scan-param parsed
     scan-param parsed
-    [ [ boa ] curry ] over push-all
+    complete-effect
-    DEFINE* ;
+    [ [ [ boa ] curry ] over push-all ] dip parsed
+    \ define-declared* parsed ;
 
 SYNTAX: `:
-    effect off
     scan-param parsed
-    parse-definition*
+    parse-declared*
-    DEFINE* ;
+    \ define-declared* parsed ;
 
 SYNTAX: `SYNTAX:
-    effect off
     scan-param parsed
     parse-definition*
-    \ define-syntax* parsed ;
+    \ define-syntax parsed ;
 
 SYNTAX: `INSTANCE:
     scan-param parsed
@@ -90,9 +92,6 @@ SYNTAX: `INSTANCE:
 
 SYNTAX: `inline [ word make-inline ] over push-all ;
 
-SYNTAX: `(
-    ")" parse-effect effect set ;
-
 : (INTERPOLATE) ( accum quot -- accum )
     [ scan interpolate-locals ] dip
     '[ _ with-string-writer @ ] parsed ;
@@ -118,7 +117,6 @@ DEFER: ;FUNCTOR delimiter
         { "INSTANCE:" POSTPONE: `INSTANCE: }
         { "SYNTAX:" POSTPONE: `SYNTAX: }
         { "inline" POSTPONE: `inline }
-        { "(" POSTPONE: `( }
     } ;
 
 : push-functor-words ( -- )
@@ -133,9 +131,9 @@ DEFER: ;FUNCTOR delimiter
     [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
     pop-functor-words ;
 
-: (FUNCTOR:) ( -- word def )
+: (FUNCTOR:) ( -- word def effect )
     CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
 
 PRIVATE>
 
-SYNTAX: FUNCTOR: (FUNCTOR:) define ;
+SYNTAX: FUNCTOR: (FUNCTOR:) define-declared ;

basis/furnace/actions/actions-tests.factor

@@ -7,7 +7,7 @@ IN: furnace.actions.tests
     [ "a" param "b" param [ string>number ] bi@ + ] >>display
 "action-1" set
 
-: lf>crlf "\n" split "\r\n" join ;
+: lf>crlf ( string -- string' ) "\n" split "\r\n" join ;
 
 STRING: action-request-test-1
 GET http://foo/bar?a=12&b=13 HTTP/1.1

basis/furnace/furnace-tests.factor

@@ -4,7 +4,7 @@ http.server furnace furnace.utilities tools.test kernel
 namespaces accessors io.streams.string urls xml.writer ;
 TUPLE: funny-dispatcher < dispatcher ;
 
-: <funny-dispatcher> funny-dispatcher new-dispatcher ;
+: <funny-dispatcher> ( -- dispatcher ) funny-dispatcher new-dispatcher ;
 
 TUPLE: base-path-check-responder ;
 

basis/furnace/sessions/sessions-tests.factor

@@ -6,7 +6,7 @@ io.streams.string io.files io.files.temp io.directories
 splitting destructors sequences db db.tuples db.sqlite
 continuations urls math.parser furnace furnace.utilities ;
 
-: with-session
+: with-session ( session quot -- )
     [
         [ [ save-session-after ] [ session set ] bi ] dip call
     ] with-destructors ; inline
@@ -22,7 +22,7 @@ M: foo call-responder*
     "x" [ 1+ ] schange
     "x" sget number>string "text/html" <content> ;
 
-: url-responder-mock-test
+: url-responder-mock-test ( -- )
     [
         <request>
             "GET" >>method
@@ -34,7 +34,7 @@ M: foo call-responder*
         [ write-response-body drop ] with-string-writer
     ] with-destructors ;
 
-: sessions-mock-test
+: sessions-mock-test ( -- )
     [
         <request>
             "GET" >>method
@@ -45,7 +45,7 @@ M: foo call-responder*
         [ write-response-body drop ] with-string-writer
     ] with-destructors ;
 
-: <exiting-action>
+: <exiting-action> ( -- action )
     <action>
         [ [ ] "text/plain" <content> exit-with ] >>display ;
 

basis/hash2/hash2-tests.factor

@@ -4,7 +4,7 @@ IN: hash2.tests
 [ t ] [ 1 2 { 1 2 } 2= ] unit-test
 [ f ] [ 1 3 { 1 2 } 2= ] unit-test
 
-: sample-hash
+: sample-hash ( -- )
     5 <hash2>
     dup 2 3 "foo" roll set-hash2
     dup 4 2 "bar" roll set-hash2

basis/help/crossref/crossref-tests.factor

@@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays
 io.streams.string continuations debugger compiler.units eval ;
 
 [ ] [
-    "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval
+    "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval
 ] unit-test
 
 [ $subsection ] [
@@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
 ] unit-test
 
 [ ] [
-    "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval
+    "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval
 ] unit-test
 
 [ ] [

basis/help/definitions/definitions-tests.factor

@@ -7,7 +7,7 @@ IN: help.definitions.tests
 
 [
     [ 4 ] [
-        "IN: help.definitions.tests USING: help.syntax ; : hello ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" <string-reader> "foo"
+        "IN: help.definitions.tests USING: help.syntax ; : hello ( -- ) ; HELP: hello \"test\" ; ARTICLE: \"hello\" \"world\" ; ARTICLE: \"hello2\" \"world\" ;" <string-reader> "foo"
         parse-stream drop
 
         "foo" source-file definitions>> first assoc-size
@@ -20,7 +20,7 @@ IN: help.definitions.tests
     ] unit-test
 
     [ 2 ] [
-        "IN: help.definitions.tests USING: help.syntax ; : hello ; ARTICLE: \"hello\" \"world\" ;" <string-reader> "foo"
+        "IN: help.definitions.tests USING: help.syntax ; : hello ( -- ) ; ARTICLE: \"hello\" \"world\" ;" <string-reader> "foo"
         parse-stream drop
 
         "foo" source-file definitions>> first assoc-size
@@ -32,7 +32,7 @@ IN: help.definitions.tests
         "hello" "help.definitions.tests" lookup "help" word-prop
     ] unit-test
 
-    [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test
+    [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval ] unit-test
 
     [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
 

basis/help/markup/markup-tests.factor

@@ -11,7 +11,7 @@ TUPLE: blahblah quux ;
 [ ] [ \ >>quux print-topic ] unit-test
 [ ] [ \ blahblah? print-topic ] unit-test
 
-: fooey "fooey" throw ;
+: fooey ( -- * ) "fooey" throw ;
 
 [ ] [ \ fooey print-topic ] unit-test
 

basis/help/markup/markup.factor

@@ -4,7 +4,7 @@ USING: accessors arrays definitions generic io kernel assocs
 hashtables namespaces make parser prettyprint sequences strings
 io.styles vectors words math sorting splitting classes slots fry
 sets vocabs help.stylesheet help.topics vocabs.loader quotations
-combinators see ;
+combinators see present ;
 IN: help.markup
 
 PREDICATE: simple-element < array
@@ -276,7 +276,7 @@ M: f ($instance)
     $snippet ;
 
 : values-row ( seq -- seq )
-    unclip \ $snippet swap ?word-name 2array
+    unclip \ $snippet swap present 2array
     swap dup first word? [ \ $instance prefix ] when 2array ;
 
 : $values ( element -- )

basis/help/syntax/syntax.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel parser sequences words help
 help.topics namespaces vocabs definitions compiler.units
@@ -7,17 +7,13 @@ IN: help.syntax
 
 SYNTAX: HELP:
     scan-word bootstrap-word
-    dup set-word
+    [ >link save-location ] [ [ \ ; parse-until >array ] dip set-word-help ] bi ;
-    dup >link save-location
-    \ ; parse-until >array swap set-word-help ;
 
 SYNTAX: ARTICLE:
     location [
-        \ ; parse-until >array [ first2 ] keep 2 tail <article>
+        \ ; parse-until >array [ first2 ] [ 2 tail ] bi <article>
         over add-article >link
     ] dip remember-definition ;
 
 SYNTAX: ABOUT:
-    in get vocab
+    in get vocab scan-object >>help changed-definition ;
-    dup changed-definition
-    scan-object >>help drop ;

basis/html/templates/chloe/chloe-tests.factor

@@ -5,7 +5,7 @@ splitting unicode.categories furnace accessors
 html.templates.chloe.compiler ;
 IN: html.templates.chloe.tests
 
-: run-template
+: run-template ( quot -- string )
     with-string-writer [ "\r\n\t" member? not ] filter
     "?>" split1 nip ; inline
 
@@ -37,7 +37,7 @@ IN: html.templates.chloe.tests
     ] run-template
 ] unit-test
 
-: test4-aux? t ;
+: test4-aux? ( -- ? ) t ;
 
 [ "True" ] [
     [
@@ -45,7 +45,7 @@ IN: html.templates.chloe.tests
     ] run-template
 ] unit-test
 
-: test5-aux? f ;
+: test5-aux? ( -- ? ) f ;
 
 [ "" ] [
     [

basis/http/http-tests.factor

@@ -13,7 +13,7 @@ IN: http.tests
 
 [ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
 
-: lf>crlf "\n" split "\r\n" join ;
+: lf>crlf ( string -- string' ) "\n" split "\r\n" join ;
 
 STRING: read-request-test-1
 POST /bar HTTP/1.1
@@ -180,14 +180,14 @@ accessors namespaces threads
 http.server.responses http.server.redirection furnace.redirection
 http.server.dispatchers db.tuples ;
 
-: add-quit-action
+: add-quit-action ( responder -- responder )
     <action>
         [ stop-this-server "Goodbye" "text/html" <content> ] >>display
     "quit" add-responder ;
 
-: test-db-file "test.db" temp-file ;
+: test-db-file ( -- path ) "test.db" temp-file ;
 
-: test-db test-db-file <sqlite-db> ;
+: test-db ( -- db ) test-db-file <sqlite-db> ;
 
 [ test-db-file delete-file ] ignore-errors
 
@@ -268,7 +268,7 @@ test-db [
     test-httpd
 ] unit-test
 
-: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
+: 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ;
 
 ! This should give a 404 not an infinite redirect loop
 [ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with

basis/io/backend/unix/unix-tests.factor

@@ -5,7 +5,7 @@ io.streams.duplex destructors make io.launcher ;
 IN: io.backend.unix.tests
 
 ! Unix domain stream sockets
-: socket-server "unix-domain-socket-test" temp-file ;
+: socket-server ( -- path ) "unix-domain-socket-test" temp-file ;
 
 [
     [ socket-server delete-file ] ignore-errors
@@ -33,8 +33,8 @@ yield
     ] { } make
 ] unit-test
 
-: datagram-server "unix-domain-datagram-test" temp-file ;
+: datagram-server ( -- path ) "unix-domain-datagram-test" temp-file ;
-: datagram-client "unix-domain-datagram-test-2" temp-file ;
+: datagram-client ( -- path ) "unix-domain-datagram-test-2" temp-file ;
 
 ! Unix domain datagram sockets
 [ datagram-server delete-file ] ignore-errors
@@ -104,7 +104,7 @@ datagram-client <local> <datagram>
 [ ] [ "d" get dispose ] unit-test
 
 ! Test error behavior
-: another-datagram "unix-domain-datagram-test-3" temp-file ;
+: another-datagram ( -- path ) "unix-domain-datagram-test-3" temp-file ;
 
 [ another-datagram delete-file ] ignore-errors
 

basis/io/encodings/strict/strict-docs.factor

@@ -3,6 +3,6 @@
 USING: help.syntax help.markup ;
 IN: io.encodings.strict
 
-HELP: strict ( encoding -- strict-encoding )
+HELP: strict ( code -- strict )
-{ $values { "encoding" "an encoding descriptor" } { "strict-encoding" "a strict encoding descriptor" } }
+{ $values { "code" "an encoding descriptor" } { "strict" "a strict encoding descriptor" } }
 { $description "Makes an encoding strict, that is, in the presence of a malformed code point, an error is thrown. Note that the existence of a replacement character in a file (U+FFFD) also throws an error." } ;

basis/io/encodings/utf16n/utf16n-tests.factor

@@ -2,7 +2,7 @@ USING: accessors alien.c-types kernel
 io.encodings.utf16 io.streams.byte-array tools.test ;
 IN: io.encodings.utf16n
 
-: correct-endian
+: correct-endian ( obj -- ? )
     code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
 
 [ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test

basis/io/files/unique/unique-docs.factor

@@ -23,7 +23,7 @@ HELP: unique-retries
 
 { unique-length unique-retries } related-words
 
-HELP: make-unique-file ( prefix suffix -- path )
+HELP: make-unique-file
 { $values { "prefix" "a string" } { "suffix" "a string" }
 { "path" "a pathname string" } }
 { $description "Creates a file that is guaranteed not to exist in the directory stored in " { $link current-temporary-directory } ". The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
@@ -31,18 +31,18 @@ HELP: make-unique-file ( prefix suffix -- path )
 
 { unique-file make-unique-file cleanup-unique-file } related-words
 
-HELP: cleanup-unique-file ( prefix suffix quot: ( path -- ) -- )
+HELP: cleanup-unique-file
 { $values { "prefix" "a string" } { "suffix" "a string" }
 { "quot" "a quotation" } }
 { $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
 { $notes "The unique file will be deleted after calling this word." } ;
 
-HELP: unique-directory ( -- path )
+HELP: unique-directory
 { $values { "path" "a pathname string" } }
 { $description "Creates a directory in the value in " { $link current-temporary-directory } " that is guaranteed not to exist in and returns the full pathname." }
 { $errors "Throws an error if the directory cannot be created after a number of tries. The most likely error is incorrect directory permissions on the temporary directory." } ;
 
-HELP: cleanup-unique-directory ( quot -- )
+HELP: cleanup-unique-directory
 { $values { "quot" "a quotation" } }
 { $description "Creates a directory with " { $link unique-directory } " and calls the quotation with the pathname on the stack using the " { $link with-temporary-directory } " combinator. The quotation can access the " { $link current-temporary-directory } " symbol for the name of the temporary directory. Subsequent unique files will be created in this unique directory until the combinator returns." }
 { $notes "The directory will be deleted after calling this word, even if an error is thrown in the quotation. This combinator is like " { $link with-unique-directory } " but does not delete the directory." } ;

basis/io/streams/duplex/duplex-tests.factor

@@ -5,13 +5,13 @@ IN: io.streams.duplex.tests
 ! Test duplex stream close behavior
 TUPLE: closing-stream < disposable ;
 
-: <closing-stream> closing-stream new ;
+: <closing-stream> ( -- stream ) closing-stream new ;
 
 M: closing-stream dispose* drop ;
 
 TUPLE: unclosable-stream ;
 
-: <unclosable-stream> unclosable-stream new ;
+: <unclosable-stream> ( -- stream ) unclosable-stream new ;
 
 M: unclosable-stream dispose
     "Can't close me!" throw ;

basis/listener/listener-tests.factor

@@ -50,7 +50,7 @@ SYNTAX: hello "Hi" print ;
 
 [
     [ ] [
-        "IN: listener.tests : hello\n\"world\" ;" parse-interactive
+        "IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive
         drop
     ] unit-test
 ] with-file-vocabs

basis/lists/lists-docs.factor

@@ -83,10 +83,6 @@ HELP: nil?
 
 { nil nil? } related-words
 
-HELP: list? ( object -- ? )
-{ $values { "object" "an object" } { "?" "a boolean" } }
-{ $description "Returns true if the object conforms to the list protocol." } ;
-
 { 1list 2list 3list } related-words
 
 HELP: 1list

basis/locals/locals-tests.factor

@@ -192,14 +192,14 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
 DEFER: xyzzy
 
 [ ] [
-    "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
+    "IN: locals.tests USE: math GENERIC: xyzzy ( a -- b ) M: integer xyzzy ;"
     <string-reader> "lambda-generic-test" parse-stream drop
 ] unit-test
 
 [ 10 ] [ 10 xyzzy ] unit-test
 
 [ ] [
-    "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
+    "IN: locals.tests USE: math USE: locals GENERIC: xyzzy ( a -- b ) M:: integer xyzzy ( n -- x ) 5 ;"
     <string-reader> "lambda-generic-test" parse-stream drop
 ] unit-test
 
@@ -245,7 +245,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
 
 [ 5 ] [ 1 next-method-test ] unit-test
 
-: no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
+: no-with-locals-test ( -- seq ) { 1 2 3 } [| x | x 3 + ] map ;
 
 [ { 4 5 6 } ] [ no-with-locals-test ] unit-test
 
@@ -259,7 +259,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
 
 :: a-word-with-locals ( a b -- ) ;
 
-: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ;
+CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
 
 [ ] [ new-definition eval ] unit-test
 
@@ -268,7 +268,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
     new-definition =
 ] unit-test
 
-: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n" ;
+CONSTANT: method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n"
 
 GENERIC: method-with-locals ( x -- y )
 

basis/locals/locals.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: lexer macros memoize parser sequences vocabs
 vocabs.loader words kernel namespaces locals.parser locals.types
@@ -17,7 +17,7 @@ SYNTAX: [let* parse-let* over push-all ;
 
 SYNTAX: [wlet parse-wlet over push-all ;
 
-SYNTAX: :: (::) define ;
+SYNTAX: :: (::) define-declared ;
 
 SYNTAX: M:: (M::) define ;
 

basis/locals/parser/parser.factor

@@ -103,18 +103,19 @@ M: lambda-parser parse-quotation ( -- quotation )
     "|" expect "|" parse-wbindings
     (parse-lambda) <wlet> ?rewrite-closures ;
 
-: parse-locals ( -- vars assoc )
+: parse-locals ( -- effect vars assoc )
-    "(" expect ")" parse-effect
+    complete-effect
-    word [ over "declared-effect" set-word-prop ] when*
+    dup
     in>> [ dup pair? [ first ] when ] map make-locals ;
 
-: parse-locals-definition ( word reader -- word quot )
+: parse-locals-definition ( word reader -- word quot effect )
     [ parse-locals ] dip
     ((parse-lambda)) <lambda>
-    [ "lambda" set-word-prop ]
+    [ nip "lambda" set-word-prop ]
-    [ rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ] 2bi ; inline
+    [ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
+    [ drop nip ] 3tri ; inline
 
-: (::) ( -- word def )
+: (::) ( -- word def effect )
     CREATE-WORD
     [ parse-definition ]
     parse-locals-definition ;
@@ -123,5 +124,5 @@ M: lambda-parser parse-quotation ( -- quotation )
     CREATE-METHOD
     [
         [ parse-definition ] 
-        parse-locals-definition
+        parse-locals-definition drop
     ] with-method-definition ;

basis/macros/macros-tests.factor

@@ -2,16 +2,22 @@ IN: macros.tests
 USING: tools.test macros math kernel arrays
 vectors io.streams.string prettyprint parser eval see ;
 
-MACRO: see-test ( a b -- c ) + ;
+MACRO: see-test ( a b -- quot ) + ;
 
-[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- c ) + ;\n" ]
+[ t ] [ \ see-test macro? ] unit-test
+
+[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- quot ) + ;\n" ]
 [ [ \ see-test see ] with-string-writer ]
 unit-test
 
+[ t ] [ \ see-test macro? ] unit-test
+
 [ t ] [
     "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
     [ \ see-test see ] with-string-writer =
 ] unit-test
 
+[ f ] [ \ see-test macro? ] unit-test
+
 [ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test
 

basis/macros/macros.factor

@@ -6,15 +6,16 @@ IN: macros
 
 <PRIVATE
 
-: real-macro-effect ( word -- effect' )
+: real-macro-effect ( effect -- effect' )
-    stack-effect in>> 1 <effect> ;
+    in>> { "quot" } <effect> ;
 
 PRIVATE>
 
-: define-macro ( word definition -- )
+: define-macro ( word definition effect -- )
-    [ "macro" set-word-prop ]
+    real-macro-effect
-    [ over real-macro-effect memoize-quot [ call ] append define ]
+    [ [ memoize-quot [ call ] append ] keep define-declared ]
-    2bi ;
+    [ drop "macro" set-word-prop ]
+    3bi ;
 
 SYNTAX: MACRO: (:) define-macro ;
 

basis/memoize/memoize.factor

@@ -34,11 +34,10 @@ M: too-many-arguments summary
 
 PRIVATE>
 
-: define-memoized ( word quot -- )
+: define-memoized ( word quot effect -- )
-    [ H{ } clone ] dip
+    [ drop "memo-quot" set-word-prop ]
-    [ pick stack-effect make-memoizer define ]
+    [ 2drop H{ } clone "memoize" set-word-prop ]
-    [ nip "memo-quot" set-word-prop ]
+    [ [ [ dup "memoize" word-prop ] 2dip make-memoizer ] keep define-declared ]
-    [ drop "memoize" set-word-prop ]
     3tri ;
 
 SYNTAX: MEMO: (:) define-memoized ;

basis/models/models-tests.factor

@@ -4,7 +4,7 @@ IN: models.tests
 
 TUPLE: model-tester hit? ;
 
-: <model-tester> model-tester new ;
+: <model-tester> ( -- model-tester ) model-tester new ;
 
 M: model-tester model-changed nip t >>hit? drop ;
 

basis/models/range/range-tests.factor

@@ -3,7 +3,7 @@ USING: arrays generic kernel math models namespaces sequences assocs
 tools.test models.range ;
 
 ! Test <range> 
-: setup-range 0 0 0 255 <range> ;
+: setup-range ( -- range ) 0 0 0 255 <range> ;
 
 ! clamp-value should not go past range ends
 [ 0   ] [ -10 setup-range clamp-value ] unit-test

basis/peg/peg.factor

@@ -618,7 +618,7 @@ ERROR: parse-failed input word ;
 
 SYNTAX: PEG:
   (:)
-  [let | def [ ] word [ ] |
+  [let | effect [ ] def [ ] word [ ] |
     [
       [
         [let | compiled-def [ def call compile ] |
@@ -626,7 +626,7 @@ SYNTAX: PEG:
             dup compiled-def compiled-parse
             [ ast>> ] [ word parse-failed ] ?if
           ]
-          word swap define
+          word swap effect define-declared
         ]
       ] with-compilation-unit
     ] over push-all

basis/persistent/heaps/heaps-tests.factor

@@ -1,9 +1,9 @@
 USING: persistent.heaps tools.test ;
 IN: persistent.heaps.tests
 
-: test-input
+CONSTANT: test-input
     { { "hello" 3 } { "goodbye" 2 } { "whatever" 5 }
-      { "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } } ;
+      { "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } }
 
 [
     { { "baz" -7 } { "bar" -1 } { "bing" 0 } { "foo" 1 }

basis/prettyprint/prettyprint-tests.factor

@@ -63,7 +63,7 @@ unit-test
 [ "USING: math ;\nIN: prettyprint.tests\n: bar ( x -- y ) 2 + ;\n" ]
 [ [ \ bar see ] with-string-writer ] unit-test
 
-: blah 
+: blah ( a a a a a a a a a a a a a a a a a a a a -- )
     drop
     drop
     drop
@@ -102,7 +102,7 @@ unit-test
         ] keep =
     ] with-scope ;
 
-GENERIC: method-layout
+GENERIC: method-layout ( a -- b )
 
 M: complex method-layout
     "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
@@ -135,7 +135,7 @@ M: object method-layout ;
     [ \ method-layout see-methods ] with-string-writer "\n" split
 ] unit-test
 
-: soft-break-test
+: soft-break-test ( -- str )
     {
         "USING: kernel math sequences strings ;"
         "IN: prettyprint.tests"
@@ -152,7 +152,7 @@ M: object method-layout ;
 
 DEFER: parse-error-file
 
-: another-soft-break-test
+: another-soft-break-test ( -- str )
     {
         "USING: make sequences ;"
         "IN: prettyprint.tests"
@@ -166,7 +166,7 @@ DEFER: parse-error-file
     check-see
 ] unit-test
 
-: string-layout
+: string-layout ( -- str )
     {
         "USING: accessors debugger io kernel ;"
         "IN: prettyprint.tests"
@@ -187,7 +187,7 @@ DEFER: parse-error-file
 
 \ send soft "break-after" set-word-prop
 
-: final-soft-break-test
+: final-soft-break-test ( -- str )
     {
         "USING: kernel sequences ;"
         "IN: prettyprint.tests"
@@ -202,7 +202,7 @@ DEFER: parse-error-file
     "final-soft-break-layout" final-soft-break-test check-see
 ] unit-test
 
-: narrow-test
+: narrow-test ( -- str )
     {
         "USING: arrays combinators continuations kernel sequences ;"
         "IN: prettyprint.tests"
@@ -218,7 +218,7 @@ DEFER: parse-error-file
     "narrow-layout" narrow-test check-see
 ] unit-test
 
-: another-narrow-test
+: another-narrow-test ( -- str )
     {
         "IN: prettyprint.tests"
         ": another-narrow-layout ( -- obj )"
@@ -326,7 +326,7 @@ INTERSECTION: intersection-see-test sequence number ;
     
 TUPLE: started-out-hustlin' ;
 
-GENERIC: ended-up-ballin'
+GENERIC: ended-up-ballin' ( a -- b )
 
 M: started-out-hustlin' ended-up-ballin' ; inline
 

basis/serialize/serialize-tests.factor

@@ -7,7 +7,7 @@ sequences math prettyprint parser classes math.constants
 io.encodings.binary random assocs serialize.private ;
 IN: serialize.tests
 
-: test-serialize-cell
+: test-serialize-cell ( a -- ? )
     2^ random dup
     binary [ serialize-cell ] with-byte-writer
     binary [ deserialize-cell ] with-byte-reader = ;
@@ -27,7 +27,7 @@ TUPLE: serialize-test a b ;
 
 C: <serialize-test> serialize-test
 
-: objects
+CONSTANT: objects
     {
         f
         t
@@ -52,7 +52,7 @@ C: <serialize-test> serialize-test
         << 1 [ 2 ] curry parsed >>
         { { "a" "bc" } { "de" "fg" } }
         H{ { "a" "bc" } { "de" "fg" } }
-    } ;
+    }
 
 : check-serialize-1 ( obj -- ? )
     "=====" print

basis/tools/annotations/annotations-tests.factor

@@ -2,7 +2,7 @@ USING: tools.test tools.annotations tools.time math parser eval
 io.streams.string kernel strings ;
 IN: tools.annotations.tests
 
-: foo ;
+: foo ( -- ) ;
 \ foo watch
 
 [ ] [ foo ] unit-test

basis/tools/crossref/crossref-tests.factor

@@ -3,7 +3,7 @@ tools.crossref tools.test parser namespaces source-files generic
 definitions ;
 IN: tools.crossref.tests
 
-GENERIC: foo
+GENERIC: foo ( a b -- c )
 
 M: integer foo + ;
 

basis/tools/disassembler/disassembler.factor

@@ -18,7 +18,7 @@ M: word disassemble word-xt 2array disassemble ;
 
 M: method-spec disassemble first2 method disassemble ;
 
-cpu x86? os unix? and
+cpu x86?
 "tools.disassembler.udis"
 "tools.disassembler.gdb" ?
 require

basis/tools/disassembler/udis/udis.factor

@@ -30,9 +30,9 @@ CONSTANT: UD_VENDOR_AMD   0
 CONSTANT: UD_VENDOR_INTEL 1
 
 FUNCTION: void ud_init ( ud* u ) ;
-FUNCTION: void ud_set_mode ( ud* u, uint8_t mode ) ;
+FUNCTION: void ud_set_mode ( ud* u, uchar mode ) ;
 FUNCTION: void ud_set_pc ( ud* u, ulonglong pc ) ;
-FUNCTION: void ud_set_input_buffer ( ud* u, uint8_t* offset, size_t size ) ;
+FUNCTION: void ud_set_input_buffer ( ud* u, uchar* offset, size_t size ) ;
 FUNCTION: void ud_set_vendor ( ud* u, uint vendor ) ;
 FUNCTION: void ud_set_syntax ( ud* u, void* syntax ) ;
 FUNCTION: void ud_input_skip ( ud* u, size_t size ) ;

basis/tools/walker/walker-tests.factor

@@ -36,7 +36,7 @@ IN: tools.walker.tests
     [ 2 2 fixnum+ ] test-walker
 ] unit-test
 
-: foo 2 2 fixnum+ ;
+: foo ( -- x ) 2 2 fixnum+ ;
 
 [ { 8 } ] [
     [ foo 4 fixnum+ ] test-walker

basis/ui/gadgets/buttons/buttons-tests.factor

@@ -5,9 +5,9 @@ IN: ui.gadgets.buttons.tests
 
 TUPLE: foo-gadget ;
 
-: com-foo-a ;
+: com-foo-a ( -- ) ;
 
-: com-foo-b ;
+: com-foo-b ( -- ) ;
 
 \ foo-gadget "toolbar" f {
     { f com-foo-a }

basis/ui/gadgets/gadgets-tests.factor

@@ -119,14 +119,14 @@ M: mock-gadget ungraft*
         [ { f f } ] [ "g" get graft-state>> ] unit-test
     ] with-variable
 
-    : add-some-children
+    : add-some-children ( gadget -- gadget )
         3 [
             <mock-gadget> over <model> >>model
             "g" get over add-gadget drop
             swap 1+ number>string set
         ] each ;
 
-    : status-flags
+    : status-flags ( -- seq )
         { "g" "1" "2" "3" } [ get graft-state>> ] map prune ;
 
     : notify-combo ( ? ? -- )

basis/ui/gadgets/panes/panes-tests.factor

@@ -5,7 +5,7 @@ help.stylesheet splitting tools.test.ui models math summary
 inspector accessors help.topics see ;
 IN: ui.gadgets.panes.tests
 
-: #children "pane" get children>> length ;
+: #children ( -- n ) "pane" get children>> length ;
 
 [ ] [ <pane> "pane" set ] unit-test
 

basis/ui/operations/operations-tests.factor

@@ -3,7 +3,7 @@ USING: ui.operations ui.commands prettyprint kernel namespaces
 tools.test ui.gadgets ui.gadgets.editors parser io
 io.streams.string math help help.markup accessors ;
 
-: my-pprint pprint ;
+: my-pprint ( obj -- ) pprint ;
 
 [ drop t ] \ my-pprint [ ] f operation boa "op" set
 

basis/ui/tools/listener/listener-tests.factor

@@ -68,7 +68,7 @@ IN: ui.tools.listener.tests
 
 [ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
 
-: text "Hello world.\nThis is a test." ;
+CONSTANT: text "Hello world.\nThis is a test."
 
 [ ] [ text "interactor" get set-editor-string ] unit-test
 

basis/urls/urls-tests.factor

@@ -2,7 +2,7 @@ IN: urls.tests
 USING: urls urls.private tools.test
 arrays kernel assocs present accessors ;
 
-: urls
+CONSTANT: urls
     {
         {
             T{ url
@@ -80,7 +80,7 @@ arrays kernel assocs present accessors ;
             }
             "ftp://slava:secret@ftp.kernel.org/"
         }
-    } ;
+    }
 
 urls [
     [ 1array ] [ [ >url ] curry ] bi* unit-test

basis/xml/syntax/syntax.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: words assocs kernel accessors parser sequences summary
+USING: words assocs kernel accessors parser effects.parser
-lexer splitting combinators locals xml.data memoize sequences.deep
+sequences summary lexer splitting combinators locals xml.data
-xml.data xml.state xml namespaces present arrays generalizations strings
+memoize sequences.deep xml.data xml.state xml namespaces present
-make math macros multiline inverse combinators.short-circuit 
+arrays generalizations strings make math macros multiline
-sorting fry unicode.categories ;
+inverse combinators.short-circuit sorting fry unicode.categories
+effects ;
 IN: xml.syntax
 
 <PRIVATE
@@ -17,26 +18,26 @@ M: no-tag summary
     >alist swap '[ _ no-tag boa throw ] suffix
     '[ dup main>> _ case ] ;
 
-: define-tags ( word -- )
+: define-tags ( word effect -- )
-    dup dup "xtable" word-prop compile-tags define ;
+    [ dup dup "xtable" word-prop compile-tags ] dip define-declared ;
 
 :: define-tag ( string word quot -- )
     quot string word "xtable" word-prop set-at
-    word define-tags ;
+    word word stack-effect define-tags ;
 
 PRIVATE>
 
 SYNTAX: TAGS:
-    CREATE
+    CREATE-WORD complete-effect
-    [ H{ } clone "xtable" set-word-prop ]
+    [ drop H{ } clone "xtable" set-word-prop ]
-    [ define-tags ] bi ;
+    [ define-tags ]
+    2bi ;
 
 SYNTAX: TAG:
     scan scan-word parse-definition define-tag ;
 
 SYNTAX: XML-NS:
-    CREATE-WORD (( string -- name )) over set-stack-effect
+    CREATE-WORD scan '[ f swap _ <name> ] (( string -- name )) define-memoized ;
-    scan '[ f swap _ <name> ] define-memoized ;
 
 <PRIVATE
 

basis/xml/tests/templating.factor

@@ -2,8 +2,8 @@ USING: kernel xml sequences assocs tools.test io arrays namespaces fry
 accessors xml.data xml.traversal xml.writer generic sequences.deep multiline ;
 IN: xml.tests
 
-: sub-tag
+CONSTANT: sub-tag
-    T{ name f f "sub" "http://littledan.onigirihouse.com/namespaces/replace" } ;
+    T{ name f f "sub" "http://littledan.onigirihouse.com/namespaces/replace" }
 
 SYMBOL: ref-table
 

basis/xml/tests/xmltest.factor

@@ -17,7 +17,7 @@ TUPLE: xml-test id uri sections description type ;
 : parse-tests ( xml -- tests )
     "TEST" tags-named [ >xml-test ] map ;
 
-: base "vocab:xml/tests/xmltest/" ;
+CONSTANT: base "vocab:xml/tests/xmltest/"
 
 MACRO: drop-output ( quot -- newquot )
     dup infer out>> '[ @ _ ndrop ] ;

basis/xml/writer/writer-tests.factor

@@ -61,7 +61,7 @@ IN: xml.writer.tests
 [ "<foo>         bar            </foo>" string>xml pprint-xml>string ] unit-test
 [ "<foo'>" ] [ "<foo'>" <unescaped> xml>string ] unit-test
 
-: test-file "resource:basis/xml/writer/test.xml" ;
+CONSTANT: test-file "resource:basis/xml/writer/test.xml"
 
 [ ] [ "<?xml version='1.0' encoding='UTF-16BE'?><x/>" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test
 [ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test

core/bootstrap/primitives.factor

@@ -36,7 +36,7 @@ H{ } clone sub-primitives set
 "syntax" vocab vocab-words bootstrap-syntax set {
     dictionary
     new-classes
-    changed-definitions changed-generics
+    changed-definitions changed-generics changed-effects
     outdated-generics forgotten-definitions
     root-cache source-files update-map implementors-map
 } [ H{ } clone swap set ] each
@@ -48,9 +48,9 @@ init-caches
 
 dummy-compiler compiler-impl set
 
-call
+call( -- )
-call
+call( -- )
-call
+call( -- )
 
 ! After we execute bootstrap/layouts
 num-types get f <array> builtins set
@@ -335,205 +335,204 @@ tuple
 (( quot1 quot2 -- compose )) define-declared
 
 ! Sub-primitive words
-: make-sub-primitive ( word vocab -- )
+: make-sub-primitive ( word vocab effect -- )
-    create
+    [ create dup 1quotation ] dip define-declared ;
-    dup reset-word
-    dup 1quotation define ;
 
 {
-    { "(execute)" "words.private" }
+    { "(execute)" "words.private" (( word -- )) }
-    { "(call)" "kernel.private" }
+    { "(call)" "kernel.private" (( quot -- )) }
-    { "both-fixnums?" "math.private" }
+    { "both-fixnums?" "math.private" (( x y -- ? )) }
-    { "fixnum+fast" "math.private" }
+    { "fixnum+fast" "math.private" (( x y -- z )) }
-    { "fixnum-fast" "math.private" }
+    { "fixnum-fast" "math.private" (( x y -- z )) }
-    { "fixnum*fast" "math.private" }
+    { "fixnum*fast" "math.private" (( x y -- z )) }
-    { "fixnum-bitand" "math.private" }
+    { "fixnum-bitand" "math.private" (( x y -- z )) }
-    { "fixnum-bitor" "math.private" }
+    { "fixnum-bitor" "math.private" (( x y -- z )) }
-    { "fixnum-bitxor" "math.private" }
+    { "fixnum-bitxor" "math.private" (( x y -- z )) }
-    { "fixnum-bitnot" "math.private" }
+    { "fixnum-bitnot" "math.private" (( x -- y )) }
-    { "fixnum-mod" "math.private" }
+    { "fixnum-mod" "math.private" (( x y -- z )) }
-    { "fixnum-shift-fast" "math.private" }
+    { "fixnum-shift-fast" "math.private" (( x y -- z )) }
-    { "fixnum/i-fast" "math.private" }
+    { "fixnum/i-fast" "math.private" (( x y -- z )) }
-    { "fixnum/mod-fast" "math.private" }
+    { "fixnum/mod-fast" "math.private" (( x y -- z w )) }
-    { "fixnum<" "math.private" }
+    { "fixnum<" "math.private" (( x y -- ? )) }
-    { "fixnum<=" "math.private" }
+    { "fixnum<=" "math.private" (( x y -- z )) }
-    { "fixnum>" "math.private" }
+    { "fixnum>" "math.private" (( x y -- ? )) }
-    { "fixnum>=" "math.private" }
+    { "fixnum>=" "math.private" (( x y -- ? )) }
-    { "drop" "kernel" }
+    { "drop" "kernel" (( x -- )) }
-    { "2drop" "kernel" }
+    { "2drop" "kernel" (( x y -- )) }
-    { "3drop" "kernel" }
+    { "3drop" "kernel" (( x y z -- )) }
-    { "dup" "kernel" }
+    { "dup" "kernel" (( x -- x x )) }
-    { "2dup" "kernel" }
+    { "2dup" "kernel" (( x y -- x y x y )) }
-    { "3dup" "kernel" }
+    { "3dup" "kernel" (( x y z -- x y z x y z )) }
-    { "rot" "kernel" }
+    { "rot" "kernel" (( x y z -- y z x )) }
-    { "-rot" "kernel" }
+    { "-rot" "kernel" (( x y z -- z x y )) }
-    { "dupd" "kernel" }
+    { "dupd" "kernel" (( x y -- x x y )) }
-    { "swapd" "kernel" }
+    { "swapd" "kernel" (( x y z -- y x z )) }
-    { "nip" "kernel" }
+    { "nip" "kernel" (( x y -- y )) }
-    { "2nip" "kernel" }
+    { "2nip" "kernel" (( x y z -- z )) }
-    { "tuck" "kernel" }
+    { "tuck" "kernel" (( x y -- y x y )) }
-    { "over" "kernel" }
+    { "over" "kernel" (( x y -- x y x )) }
-    { "pick" "kernel" }
+    { "pick" "kernel" (( x y z -- x y z x )) }
-    { "swap" "kernel" }
+    { "swap" "kernel" (( x y -- y x )) }
-    { "eq?" "kernel" }
+    { "eq?" "kernel" (( obj1 obj2 -- ? )) }
-    { "tag" "kernel.private" }
+    { "tag" "kernel.private" (( object -- n )) }
-    { "slot" "slots.private" }
+    { "slot" "slots.private" (( obj m -- value )) }
-    { "get-local" "locals.backend" }
+    { "get-local" "locals.backend" (( n -- obj )) }
-    { "load-local" "locals.backend" }
+    { "load-local" "locals.backend" (( obj -- )) }
-    { "drop-locals" "locals.backend" }
+    { "drop-locals" "locals.backend" (( n -- )) }
-} [ make-sub-primitive ] assoc-each
+} [ first3 make-sub-primitive ] each
 
 ! Primitive words
-: make-primitive ( word vocab n -- )
+: make-primitive ( word vocab n effect -- )
-    [ create dup reset-word ] dip
+    [
-    [ do-primitive ] curry [ ] like define ;
+        [ create dup reset-word ] dip
+        [ do-primitive ] curry
+    ] dip define-declared ;
 
 {
-    { "bignum>fixnum" "math.private" }
+    { "bignum>fixnum" "math.private" (( x -- y )) }
-    { "float>fixnum" "math.private" }
+    { "float>fixnum" "math.private" (( x -- y )) }
-    { "fixnum>bignum" "math.private" }
+    { "fixnum>bignum" "math.private" (( x -- y )) }
-    { "float>bignum" "math.private" }
+    { "float>bignum" "math.private" (( x -- y )) }
-    { "fixnum>float" "math.private" }
+    { "fixnum>float" "math.private" (( x -- y )) }
-    { "bignum>float" "math.private" }
+    { "bignum>float" "math.private" (( x -- y )) }
-    { "<ratio>" "math.private" }
+    { "<ratio>" "math.private" (( a b -- a/b )) }
-    { "string>float" "math.private" }
+    { "string>float" "math.private" (( str -- n/f )) }
-    { "float>string" "math.private" }
+    { "float>string" "math.private" (( n -- str )) }
-    { "float>bits" "math" }
+    { "float>bits" "math" (( x -- n )) }
-    { "double>bits" "math" }
+    { "double>bits" "math" (( x -- n )) }
-    { "bits>float" "math" }
+    { "bits>float" "math" (( n -- x )) }
-    { "bits>double" "math" }
+    { "bits>double" "math" (( n -- x )) }
-    { "<complex>" "math.private" }
+    { "<complex>" "math.private" (( x y -- z )) }
-    { "fixnum+" "math.private" }
+    { "fixnum+" "math.private" (( x y -- z )) }
-    { "fixnum-" "math.private" }
+    { "fixnum-" "math.private" (( x y -- z )) }
-    { "fixnum*" "math.private" }
+    { "fixnum*" "math.private" (( x y -- z )) }
-    { "fixnum/i" "math.private" }
+    { "fixnum/i" "math.private" (( x y -- z )) }
-    { "fixnum/mod" "math.private" }
+    { "fixnum/mod" "math.private" (( x y -- z w )) }
-    { "fixnum-shift" "math.private" }
+    { "fixnum-shift" "math.private" (( x y -- z )) }
-    { "bignum=" "math.private" }
+    { "bignum=" "math.private" (( x y -- ? )) }
-    { "bignum+" "math.private" }
+    { "bignum+" "math.private" (( x y -- z )) }
-    { "bignum-" "math.private" }
+    { "bignum-" "math.private" (( x y -- z )) }
-    { "bignum*" "math.private" }
+    { "bignum*" "math.private" (( x y -- z )) }
-    { "bignum/i" "math.private" }
+    { "bignum/i" "math.private" (( x y -- z )) }
-    { "bignum-mod" "math.private" }
+    { "bignum-mod" "math.private" (( x y -- z )) }
-    { "bignum/mod" "math.private" }
+    { "bignum/mod" "math.private" (( x y -- z w )) }
-    { "bignum-bitand" "math.private" }
+    { "bignum-bitand" "math.private" (( x y -- z )) }
-    { "bignum-bitor" "math.private" }
+    { "bignum-bitor" "math.private" (( x y -- z )) }
-    { "bignum-bitxor" "math.private" }
+    { "bignum-bitxor" "math.private" (( x y -- z )) }
-    { "bignum-bitnot" "math.private" }
+    { "bignum-bitnot" "math.private" (( x -- y )) }
-    { "bignum-shift" "math.private" }
+    { "bignum-shift" "math.private" (( x y -- z )) }
-    { "bignum<" "math.private" }
+    { "bignum<" "math.private" (( x y -- ? )) }
-    { "bignum<=" "math.private" }
+    { "bignum<=" "math.private" (( x y -- ? )) }
-    { "bignum>" "math.private" }
+    { "bignum>" "math.private" (( x y -- ? )) }
-    { "bignum>=" "math.private" }
+    { "bignum>=" "math.private" (( x y -- ? )) }
-    { "bignum-bit?" "math.private" }
+    { "bignum-bit?" "math.private" (( n x -- ? )) }
-    { "bignum-log2" "math.private" }
+    { "bignum-log2" "math.private" (( x -- n )) }
-    { "byte-array>bignum" "math" }
+    { "byte-array>bignum" "math" (( x -- y ))  }
-    { "float=" "math.private" }
+    { "float=" "math.private" (( x y -- ? )) }
-    { "float+" "math.private" }
+    { "float+" "math.private" (( x y -- z )) }
-    { "float-" "math.private" }
+    { "float-" "math.private" (( x y -- z )) }
-    { "float*" "math.private" }
+    { "float*" "math.private" (( x y -- z )) }
-    { "float/f" "math.private" }
+    { "float/f" "math.private" (( x y -- z )) }
-    { "float-mod" "math.private" }
+    { "float-mod" "math.private" (( x y -- z )) }
-    { "float<" "math.private" }
+    { "float<" "math.private" (( x y -- ? )) }
-    { "float<=" "math.private" }
+    { "float<=" "math.private" (( x y -- ? )) }
-    { "float>" "math.private" }
+    { "float>" "math.private" (( x y -- ? )) }
-    { "float>=" "math.private" }
+    { "float>=" "math.private" (( x y -- ? )) }
-    { "<word>" "words" }
+    { "<word>" "words" (( name vocab -- word )) }
-    { "word-xt" "words" }
+    { "word-xt" "words" (( word -- start end )) }
-    { "getenv" "kernel.private" }
+    { "getenv" "kernel.private" (( n -- obj )) }
-    { "setenv" "kernel.private" }
+    { "setenv" "kernel.private" (( obj n -- )) }
-    { "(exists?)" "io.files.private" }
+    { "(exists?)" "io.files.private" (( path -- ? )) }
-    { "gc" "memory" }
+    { "gc" "memory" (( -- )) }
-    { "gc-stats" "memory" }
+    { "gc-stats" "memory" f }
-    { "save-image" "memory" }
+    { "save-image" "memory" (( path -- )) }
-    { "save-image-and-exit" "memory" }
+    { "save-image-and-exit" "memory" (( path -- )) }
-    { "datastack" "kernel" }
+    { "datastack" "kernel" (( -- ds )) }
-    { "retainstack" "kernel" }
+    { "retainstack" "kernel" (( -- rs )) }
-    { "callstack" "kernel" }
+    { "callstack" "kernel" (( -- cs )) }
-    { "set-datastack" "kernel" }
+    { "set-datastack" "kernel" (( ds -- )) }
-    { "set-retainstack" "kernel" }
+    { "set-retainstack" "kernel" (( rs -- )) }
-    { "set-callstack" "kernel" }
+    { "set-callstack" "kernel" (( cs -- )) }
-    { "exit" "system" }
+    { "exit" "system" (( n -- )) }
-    { "data-room" "memory" }
+    { "data-room" "memory" (( -- cards generations )) }
-    { "code-room" "memory" }
+    { "code-room" "memory" (( -- code-free code-total )) }
-    { "micros" "system" }
+    { "micros" "system" (( -- us )) }
-    { "modify-code-heap" "compiler.units" }
+    { "modify-code-heap" "compiler.units" (( alist -- )) }
-    { "dlopen" "alien" }
+    { "dlopen" "alien" (( path -- dll )) }
-    { "dlsym" "alien" }
+    { "dlsym" "alien" (( name dll -- alien )) }
-    { "dlclose" "alien" }
+    { "dlclose" "alien" (( dll -- )) }
-    { "<byte-array>" "byte-arrays" }
+    { "<byte-array>" "byte-arrays" (( n -- byte-array )) }
-    { "(byte-array)" "byte-arrays" }
+    { "(byte-array)" "byte-arrays" (( n -- byte-array )) }
-    { "<displaced-alien>" "alien" }
+    { "<displaced-alien>" "alien" (( displacement c-ptr -- alien )) }
-    { "alien-signed-cell" "alien.accessors" }
+    { "alien-signed-cell" "alien.accessors" f }
-    { "set-alien-signed-cell" "alien.accessors" }
+    { "set-alien-signed-cell" "alien.accessors" f }
-    { "alien-unsigned-cell" "alien.accessors" }
+    { "alien-unsigned-cell" "alien.accessors" f }
-    { "set-alien-unsigned-cell" "alien.accessors" }
+    { "set-alien-unsigned-cell" "alien.accessors" f }
-    { "alien-signed-8" "alien.accessors" }
+    { "alien-signed-8" "alien.accessors" f }
-    { "set-alien-signed-8" "alien.accessors" }
+    { "set-alien-signed-8" "alien.accessors" f }
-    { "alien-unsigned-8" "alien.accessors" }
+    { "alien-unsigned-8" "alien.accessors" f }
-    { "set-alien-unsigned-8" "alien.accessors" }
+    { "set-alien-unsigned-8" "alien.accessors" f }
-    { "alien-signed-4" "alien.accessors" }
+    { "alien-signed-4" "alien.accessors" f }
-    { "set-alien-signed-4" "alien.accessors" }
+    { "set-alien-signed-4" "alien.accessors" f }
-    { "alien-unsigned-4" "alien.accessors" }
+    { "alien-unsigned-4" "alien.accessors" f }
-    { "set-alien-unsigned-4" "alien.accessors" }
+    { "set-alien-unsigned-4" "alien.accessors" f }
-    { "alien-signed-2" "alien.accessors" }
+    { "alien-signed-2" "alien.accessors" f }
-    { "set-alien-signed-2" "alien.accessors" }
+    { "set-alien-signed-2" "alien.accessors" f }
-    { "alien-unsigned-2" "alien.accessors" }
+    { "alien-unsigned-2" "alien.accessors" f }
-    { "set-alien-unsigned-2" "alien.accessors" }
+    { "set-alien-unsigned-2" "alien.accessors" f }
-    { "alien-signed-1" "alien.accessors" }
+    { "alien-signed-1" "alien.accessors" f }
-    { "set-alien-signed-1" "alien.accessors" }
+    { "set-alien-signed-1" "alien.accessors" f }
-    { "alien-unsigned-1" "alien.accessors" }
+    { "alien-unsigned-1" "alien.accessors" f }
-    { "set-alien-unsigned-1" "alien.accessors" }
+    { "set-alien-unsigned-1" "alien.accessors" f }
-    { "alien-float" "alien.accessors" }
+    { "alien-float" "alien.accessors" f }
-    { "set-alien-float" "alien.accessors" }
+    { "set-alien-float" "alien.accessors" f }
-    { "alien-double" "alien.accessors" }
+    { "alien-double" "alien.accessors" f }
-    { "set-alien-double" "alien.accessors" }
+    { "set-alien-double" "alien.accessors" f }
-    { "alien-cell" "alien.accessors" }
+    { "alien-cell" "alien.accessors" f }
-    { "set-alien-cell" "alien.accessors" }
+    { "set-alien-cell" "alien.accessors" f }
-    { "alien-address" "alien" }
+    { "alien-address" "alien" (( c-ptr -- addr )) }
-    { "set-slot" "slots.private" }
+    { "set-slot" "slots.private" (( value obj n -- )) }
-    { "string-nth" "strings.private" }
+    { "string-nth" "strings.private" (( n string -- ch )) }
-    { "set-string-nth-fast" "strings.private" }
+    { "set-string-nth-fast" "strings.private" (( ch n string -- )) }
-    { "set-string-nth-slow" "strings.private" }
+    { "set-string-nth-slow" "strings.private" (( ch n string -- )) }
-    { "resize-array" "arrays" }
+    { "resize-array" "arrays" (( n array -- newarray )) }
-    { "resize-string" "strings" }
+    { "resize-string" "strings" (( n str -- newstr )) }
-    { "<array>" "arrays" }
+    { "<array>" "arrays" (( n elt -- array )) }
-    { "begin-scan" "memory" }
+    { "begin-scan" "memory" (( -- )) }
-    { "next-object" "memory" }
+    { "next-object" "memory" (( -- obj )) }
-    { "end-scan" "memory" }
+    { "end-scan" "memory" (( -- )) }
-    { "size" "memory" }
+    { "size" "memory" (( obj -- n )) }
-    { "die" "kernel" }
+    { "die" "kernel" (( -- )) }
-    { "fopen" "io.streams.c" }
+    { "fopen" "io.streams.c" (( path mode -- alien )) }
-    { "fgetc" "io.streams.c" }
+    { "fgetc" "io.streams.c" (( alien -- ch/f )) }
-    { "fread" "io.streams.c" }
+    { "fread" "io.streams.c" (( n alien -- str/f )) }
-    { "fputc" "io.streams.c" }
+    { "fputc" "io.streams.c" (( ch alien -- )) }
-    { "fwrite" "io.streams.c" }
+    { "fwrite" "io.streams.c" (( string alien -- )) }
-    { "fflush" "io.streams.c" }
+    { "fflush" "io.streams.c" (( alien -- )) }
-    { "fclose" "io.streams.c" }
+    { "fclose" "io.streams.c" (( alien -- )) }
-    { "<wrapper>" "kernel" }
+    { "<wrapper>" "kernel" (( obj -- wrapper )) }
-    { "(clone)" "kernel" }
+    { "(clone)" "kernel" (( obj -- newobj )) }
-    { "<string>" "strings" }
+    { "<string>" "strings" (( n ch -- string )) }
-    { "array>quotation" "quotations.private" }
+    { "array>quotation" "quotations.private" (( array -- quot )) }
-    { "quotation-xt" "quotations" }
+    { "quotation-xt" "quotations" (( quot -- xt )) }
-    { "<tuple>" "classes.tuple.private" }
+    { "<tuple>" "classes.tuple.private" (( layout -- tuple )) }
-    { "profiling" "tools.profiler.private" }
+    { "profiling" "tools.profiler.private" (( ? -- )) }
-    { "become" "kernel.private" }
+    { "become" "kernel.private" (( old new -- )) }
-    { "(sleep)" "threads.private" }
+    { "(sleep)" "threads.private" (( us -- )) }
-    { "<tuple-boa>" "classes.tuple.private" }
+    { "<tuple-boa>" "classes.tuple.private" (( ... layout -- tuple )) }
-    { "callstack>array" "kernel" }
+    { "callstack>array" "kernel" (( callstack -- array )) }
-    { "innermost-frame-quot" "kernel.private" }
+    { "innermost-frame-quot" "kernel.private" (( callstack -- quot )) }
-    { "innermost-frame-scan" "kernel.private" }
+    { "innermost-frame-scan" "kernel.private" (( callstack -- n )) }
-    { "set-innermost-frame-quot" "kernel.private" }
+    { "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) }
-    { "call-clear" "kernel" }
+    { "call-clear" "kernel" (( quot -- )) }
-    { "resize-byte-array" "byte-arrays" }
+    { "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) }
-    { "dll-valid?" "alien" }
+    { "dll-valid?" "alien" (( dll -- ? )) }
-    { "unimplemented" "kernel.private" }
+    { "unimplemented" "kernel.private" (( -- * )) }
-    { "gc-reset" "memory" }
+    { "gc-reset" "memory" (( -- )) }
-    { "jit-compile" "quotations" }
+    { "jit-compile" "quotations" (( quot -- )) }
-    { "load-locals" "locals.backend" }
+    { "load-locals" "locals.backend" (( ... n -- )) }
-    { "check-datastack" "kernel.private" }
+    { "check-datastack" "kernel.private" (( array in# out# -- ? )) }
-}
+} [ [ first3 ] dip swap make-primitive ] each-index
-[ [ first2 ] dip make-primitive ] each-index
 
 ! Bump build number
 "build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared

core/classes/classes.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays definitions assocs kernel kernel.private
 slots.private namespaces make sequences strings words words.symbol
@@ -126,14 +126,19 @@ M: sequence implementors [ implementors ] gather ;
         } spread
     ] H{ } make-assoc ;
 
+: ?define-symbol ( word -- )
+    dup deferred? [ define-symbol ] [ drop ] if ;
+
 : (define-class) ( word props -- )
     [
-        dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
+        {
-        dup reset-class
+            [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
-        dup deferred? [ dup define-symbol ] when
+            [ reset-class ]
-        dup redefined
+            [ ?define-symbol ]
-        dup props>>
+            [ redefined ]
-    ] dip assoc-union >>props
+            [ ]
+        } cleave
+    ] dip [ assoc-union ] curry change-props
     dup predicate-word
     [ 1quotation "predicate" set-word-prop ]
     [ swap "predicating" set-word-prop ]

core/classes/singleton/singleton-tests.factor

@@ -13,7 +13,7 @@ GENERIC: zammo ( obj -- str )
 
 SINGLETON: word-and-singleton
 
-: word-and-singleton 3 ;
+: word-and-singleton ( -- x ) 3 ;
 
 [ t ] [ \ word-and-singleton word-and-singleton? ] unit-test
 [ 3 ] [ word-and-singleton ] unit-test

core/classes/tuple/tuple-tests.factor

@@ -4,7 +4,8 @@ namespaces quotations sequences.private classes continuations
 generic.standard effects classes.tuple classes.tuple.private
 arrays vectors strings compiler.units accessors classes.algebra
 calendar prettyprint io.streams.string splitting summary
-columns math.order classes.private slots slots.private eval see ;
+columns math.order classes.private slots slots.private eval see
+words.symbol ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -62,7 +63,7 @@ TUPLE: predicate-test ;
 
 C: <predicate-test> predicate-test
 
-: predicate-test drop f ;
+: predicate-test ( a -- ? ) drop f ;
 
 [ t ] [ <predicate-test> predicate-test? ] unit-test
 
@@ -97,7 +98,7 @@ TUPLE: size-test a b c d ;
     size-test tuple-layout second =
 ] unit-test
 
-GENERIC: <yo-momma>
+GENERIC: <yo-momma> ( a -- b )
 
 TUPLE: yo-momma ;
 
@@ -123,7 +124,7 @@ TUPLE: loc-recording ;
 
 TUPLE: forget-robustness ;
 
-GENERIC: forget-robustness-generic
+GENERIC: forget-robustness-generic ( a -- b )
 
 M: forget-robustness forget-robustness-generic ;
 
@@ -493,7 +494,7 @@ must-fail-with
 [ t ] [ "z" accessor-exists? ] unit-test
 
 [ [ ] ] [
-    "IN: classes.tuple.tests GENERIC: forget-accessors-test"
+    "IN: classes.tuple.tests GENERIC: forget-accessors-test ( a -- b )"
     <string-reader>
     "forget-accessors-test" parse-stream
 ] unit-test
@@ -508,7 +509,7 @@ TUPLE: another-forget-accessors-test ;
 
 
 [ [ ] ] [
-    "IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
+    "IN: classes.tuple.tests GENERIC: another-forget-accessors-test ( a -- b )"
     <string-reader>
     "another-forget-accessors-test" parse-stream
 ] unit-test
@@ -567,7 +568,7 @@ GENERIC: break-me ( obj -- )
 
 [ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test
 
-[ ] [ "IN: classes.tuple.tests : subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
+[ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
 
 [ f ] [ subclass-reset-test-1 tuple-class? ] unit-test
 [ f ] [ subclass-reset-test-2 tuple-class? ] unit-test
@@ -666,7 +667,7 @@ DEFER: error-y
 
 [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
 
-[ ] [ "IN: classes.tuple.tests GENERIC: error-y" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval ] unit-test
 
 [ f ] [ \ error-y tuple-class? ] unit-test
 
@@ -731,3 +732,17 @@ SLOT: kex
 
 [ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
 [ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test
+
+DEFER: redefine-tuple-twice
+
+[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test
+
+[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
+
+[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval ] unit-test
+
+[ t ] [ \ redefine-tuple-twice deferred? ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test
+
+[ t ] [ \ redefine-tuple-twice symbol? ] unit-test

core/classes/tuple/tuple.factor

@@ -247,8 +247,7 @@ M: tuple-class update-class
             bi
         ] each-subclass
     ]
-    [ define-new-tuple-class ]
+    [ define-new-tuple-class ] 3bi ;
-    3bi ;
 
 : tuple-class-unchanged? ( class superclass slots -- ? )
     [ [ superclass ] [ bootstrap-word ] bi* = ]
@@ -275,7 +274,7 @@ M: word (define-tuple-class)
 
 M: tuple-class (define-tuple-class)
     3dup tuple-class-unchanged?
-    [ 3drop ] [ redefine-tuple-class ] if ;
+    [ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
 
 : thrower-effect ( slots -- effect )
     [ dup array? [ first ] when ] map { "*" } <effect> ;

core/combinators/combinators-tests.factor

@@ -288,7 +288,7 @@ CONSTANT: case-const-2 2
     } case
 ] unit-test
 
-: do-not-call "do not call" throw ;
+: do-not-call ( -- * ) "do not call" throw ;
 
 : test-case-6 ( obj -- value )
     {

core/compiler/units/units.factor

@@ -148,6 +148,7 @@ GENERIC: definitions-changed ( assoc obj -- )
     [
         H{ } clone changed-definitions set
         H{ } clone changed-generics set
+        H{ } clone changed-effects set
         H{ } clone outdated-generics set
         H{ } clone outdated-tuples set
         H{ } clone new-classes set
@@ -158,6 +159,7 @@ GENERIC: definitions-changed ( assoc obj -- )
     [
         H{ } clone changed-definitions set
         H{ } clone changed-generics set
+        H{ } clone changed-effects set
         H{ } clone outdated-generics set
         H{ } clone forgotten-definitions set
         H{ } clone outdated-tuples set

core/continuations/continuations-tests.factor

@@ -3,7 +3,7 @@ continuations debugger parser memory arrays words
 kernel.private accessors eval ;
 IN: continuations.tests
 
-: (callcc1-test)
+: (callcc1-test) ( -- )
     [ 1- dup ] dip ?push
     over 0 = [ "test-cc" get continue-with ] when
     (callcc1-test) ;
@@ -59,10 +59,10 @@ IN: continuations.tests
 ! : callstack-overflow callstack-overflow f ;
 ! [ callstack-overflow ] must-fail
 
-: don't-compile-me { } [ ] each ;
+: don't-compile-me ( -- ) { } [ ] each ;
 
-: foo callstack "c" set 3 don't-compile-me ;
+: foo ( -- ) callstack "c" set 3 don't-compile-me ;
-: bar 1 foo 2 ;
+: bar ( -- a b ) 1 foo 2 ;
 
 [ 1 3 2 ] [ bar ] unit-test
 

core/definitions/definitions.factor

@@ -1,13 +1,11 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: definitions
 USING: kernel sequences namespaces assocs graphs math math.order ;
+IN: definitions
 
 ERROR: no-compilation-unit definition ;
 
-SYMBOL: inlined-dependency
+SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
-SYMBOL: flushed-dependency
-SYMBOL: called-dependency
 
 : set-in-unit ( value key assoc -- )
     [ set-at ] [ no-compilation-unit ] if* ;
@@ -17,6 +15,11 @@ SYMBOL: changed-definitions
 : changed-definition ( defspec -- )
     inlined-dependency swap changed-definitions get set-in-unit ;
 
+SYMBOL: changed-effects
+
+: changed-effect ( word -- )
+    dup changed-effects get set-in-unit ;
+
 SYMBOL: changed-generics
 
 SYMBOL: outdated-generics

core/destructors/destructors-tests.factor

@@ -21,7 +21,7 @@ T{ dispose-dummy } "b" set
 
 TUPLE: dummy-obj destroyed? ;
 
-: <dummy-obj> dummy-obj new ;
+: <dummy-obj> ( -- obj ) dummy-obj new ;
 
 TUPLE: dummy-destructor obj ;
 
@@ -30,10 +30,10 @@ C: <dummy-destructor> dummy-destructor
 M: dummy-destructor dispose ( obj -- )
     obj>> t >>destroyed? drop ;
 
-: destroy-always
+: destroy-always ( obj -- )
     <dummy-destructor> &dispose drop ;
 
-: destroy-later
+: destroy-later ( obj -- )
     <dummy-destructor> |dispose drop ;
 
 [ t ] [

core/effects/parser/parser.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: lexer sets sequences kernel splitting effects
-combinators arrays parser ;
+combinators arrays ;
 IN: effects.parser
 
 DEFER: parse-effect
@@ -12,9 +12,9 @@ ERROR: bad-effect ;
     scan [ nip ] [ = ] 2bi [ drop f ] [
         dup { f "(" "((" } member? [ bad-effect ] [
             ":" ?tail [
-                scan-word {
+                scan {
-                    { \ ( [ ")" parse-effect ] }
+                    { "(" [ ")" parse-effect ] }
-                    [ ]
+                    { f [ ")" unexpected-eof ] }
                 } case 2array
             ] when
         ] if
@@ -27,5 +27,8 @@ ERROR: bad-effect ;
     parse-effect-tokens { "--" } split1 dup
     [ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;
 
+: complete-effect ( -- effect )
+    "(" expect ")" parse-effect ;
+
 : parse-call( ( accum word -- accum )
-    [ ")" parse-effect parsed ] dip parsed ;
+    [ ")" parse-effect ] dip 2array over push-all ;

core/generic/generic-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax words classes classes.algebra
 definitions kernel alien sequences math quotations
-generic.standard generic.math combinators prettyprint ;
+generic.standard generic.math combinators prettyprint effects ;
 IN: generic
 
 ARTICLE: "method-order" "Method precedence"
@@ -115,7 +115,7 @@ HELP: make-generic
 $low-level-note ;
 
 HELP: define-generic
-{ $values { "word" word } { "combination" "a method combination" } }
+{ $values { "word" word } { "effect" effect } { "combination" "a method combination" } }
 { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
 { $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ;
 

core/generic/generic-tests.factor

@@ -186,7 +186,7 @@ M: f generic-forget-test-3 ;
 
 [ f ] [ f generic-forget-test-3 ] unit-test
 
-: a-word ;
+: a-word ( -- ) ;
 
 GENERIC: a-generic ( a -- b )
 
@@ -196,7 +196,7 @@ M: integer a-generic a-word ;
 
 [ t ] [ "m" get \ a-word usage memq? ] unit-test
 
-[ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test
+[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test
 
 [ f ] [ "m" get \ a-word usage memq? ] unit-test
 

core/generic/generic.factor

@@ -185,13 +185,21 @@ M: sequence update-methods ( class seq -- )
         [ changed-generic ] [ remake-generic drop ] 2bi
     ] with each ;
 
-: define-generic ( word combination -- )
+: define-generic ( word combination effect -- )
-    over "combination" word-prop over = [ drop ] [
+    [ nip swap set-stack-effect ]
-        2dup "combination" set-word-prop
+    [
-        over "methods" word-prop values forget-all
+        drop
-        over H{ } clone "methods" set-word-prop
+        2dup [ "combination" word-prop ] dip = [ 2drop ] [
-        dupd define-default-method
+            {
-    ] if remake-generic ;
+                [ "combination" set-word-prop ]
+                [ drop "methods" word-prop values forget-all ]
+                [ drop H{ } clone "methods" set-word-prop ]
+                [ define-default-method ]
+            }
+            2cleave
+        ] if
+    ]
+    [ 2drop remake-generic ] 3tri ;
 
 M: generic subwords
     [

core/generic/math/math.factor

@@ -72,7 +72,7 @@ SYMBOL: picker
         \ dispatch ,
     ] [ ] make ; inline
 
-TUPLE: math-combination ;
+SINGLETON: math-combination
 
 M: math-combination make-default-method
     drop default-math-method ;

core/generic/parser/parser.factor

@@ -1,12 +1,15 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel words generic namespaces ;
+USING: parser kernel words generic namespaces effects.parser ;
 IN: generic.parser
 
 ERROR: not-in-a-method-error ;
 
 : CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
 
+: (GENERIC:) ( quot -- )
+    [ CREATE-GENERIC ] dip call complete-effect define-generic ; inline
+
 : create-method-in ( class generic -- method )
     create-method dup set-word dup save-location ;
 

core/generic/standard/standard-docs.factor

@@ -1,5 +1,5 @@
 USING: generic help.markup help.syntax sequences math
-math.parser ;
+math.parser effects ;
 IN: generic.standard
 
 HELP: no-method
@@ -28,7 +28,7 @@ HELP: hook-combination
 } ;
 
 HELP: define-simple-generic
-{ $values { "word" "a word" } }
+{ $values { "word" "a word" } { "effect" effect } }
 { $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
 
 { standard-combination hook-combination } related-words

core/generic/standard/standard-tests.factor

@@ -280,16 +280,6 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
     V{ } my-var [ call-next-hooker ] with-variable
 ] unit-test
 
-GENERIC: no-stack-effect-decl
-
-M: hashtable no-stack-effect-decl ;
-M: vector no-stack-effect-decl ;
-M: sbuf no-stack-effect-decl ;
-
-[ ] [ \ no-stack-effect-decl see ] unit-test
-
-[ ] [ \ no-stack-effect-decl def>> . ] unit-test
-
 ! Cross-referencing with generic words
 TUPLE: xref-tuple-1 ;
 TUPLE: xref-tuple-2 < xref-tuple-1 ;

core/generic/standard/standard.factor

@@ -24,7 +24,7 @@ M: quotation engine>quot
 ERROR: no-method object generic ;
 
 : error-method ( word -- quot )
-    picker swap [ no-method ] curry append ;
+    [ picker ] dip [ no-method ] curry append ;
 
 : push-method ( method specializer atomic assoc -- )
     [
@@ -56,7 +56,7 @@ ERROR: no-method object generic ;
 
 : find-default ( methods -- quot )
     #! Side-effects methods.
-    object bootstrap-word swap delete-at* [
+    [ object bootstrap-word ] dip delete-at* [
         drop generic get "default-method" word-prop mangle-method
     ] unless ;
 
@@ -104,8 +104,10 @@ PREDICATE: standard-generic < generic
 PREDICATE: simple-generic < standard-generic
     "combination" word-prop #>> zero? ;
 
-: define-simple-generic ( word -- )
+CONSTANT: simple-combination T{ standard-combination f 0 }
-    T{ standard-combination f 0 } define-generic ;
+
+: define-simple-generic ( word effect -- )
+    [ simple-combination ] dip define-generic ;
 
 : with-standard ( combination quot -- quot' )
     [ #>> (dispatch#) ] dip with-variable ; inline

core/io/test/no-trailing-eol.factor

@@ -1,4 +1,4 @@
 IN: io.tests
 USE: math
-: foo 2 2 + ;
+: foo ( -- x ) 2 2 + ;
 FORGET: foo

core/kernel/kernel-tests.factor

@@ -21,21 +21,21 @@ IN: kernel.tests
 
 [ ] [ :c ] unit-test
 
-: overflow-d 3 overflow-d ;
+: overflow-d ( -- ) 3 overflow-d ;
 
 [ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
 
 [ ] [ :c ] unit-test
 
-: (overflow-d-alt) 3 ;
+: (overflow-d-alt) ( -- ) 3 ;
 
-: overflow-d-alt (overflow-d-alt) overflow-d-alt ;
+: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
 
 [ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
 
 [ ] [ [ :c ] with-string-writer drop ] unit-test
 
-: overflow-r 3 load-local overflow-r ;
+: overflow-r ( -- ) 3 load-local overflow-r ;
 
 [ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
 
@@ -99,7 +99,7 @@ IN: kernel.tests
 [ ] [ :c ] unit-test
 
 ! Doesn't compile; important
-: foo 5 + 0 [ ] each ;
+: foo ( a -- b ) 5 + 0 [ ] each ;
 
 [ drop foo ] must-fail
 [ ] [ :c ] unit-test
@@ -115,7 +115,7 @@ IN: kernel.tests
 [ loop ] must-fail
 
 ! Discovered on Windows
-: total-failure-1 "" [ ] map unimplemented ;
+: total-failure-1 ( -- ) "" [ ] map unimplemented ;
 
 [ total-failure-1 ] must-fail
 

core/kernel/kernel.factor

@@ -1,7 +1,6 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel.private slots.private math.private
+USING: kernel.private slots.private math.private ;
-classes.tuple.private ;
 IN: kernel
 
 DEFER: dip

core/parser/parser-tests.factor

@@ -27,7 +27,7 @@ IN: parser.tests
 
     [ "hello world" ]
     [
-        "IN: parser.tests : hello \"hello world\" ;"
+        "IN: parser.tests : hello ( -- str ) \"hello world\" ;"
         eval "USE: parser.tests hello" eval
     ] unit-test
 
@@ -78,12 +78,8 @@ IN: parser.tests
     [ T{ effect f { "a" "b" } { "d" } f } ]
     [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
 
-    [ ] [ "IN: parser.tests : effect-parsing-test ;" eval ] unit-test
-
-    [ f ] [ \ effect-parsing-test "declared-effect" word-prop ] unit-test
-
     ! Funny bug
-    [ 2 ] [ "IN: parser.tests : \0. 2 ; \0." eval ] unit-test
+    [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval ] unit-test
 
     [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail
 
@@ -110,7 +106,7 @@ IN: parser.tests
 
     [ ] [ "USE: parser.tests foo" eval ] unit-test
 
-    "IN: parser.tests USING: math prettyprint ; : foo 2 2 + . ;" eval
+    "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval
 
     [ t ] [
         "USE: parser.tests \\ foo" eval
@@ -120,7 +116,7 @@ IN: parser.tests
     ! Test smudging
 
     [ 1 ] [
-        "IN: parser.tests : smudge-me ;" <string-reader> "foo"
+        "IN: parser.tests : smudge-me ( -- ) ;" <string-reader> "foo"
         parse-stream drop
 
         "foo" source-file definitions>> first assoc-size
@@ -129,7 +125,7 @@ IN: parser.tests
     [ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
 
     [ ] [
-        "IN: parser.tests : smudge-me-more ;" <string-reader> "foo"
+        "IN: parser.tests : smudge-me-more ( -- ) ;" <string-reader> "foo"
         parse-stream drop
     ] unit-test
 
@@ -137,7 +133,7 @@ IN: parser.tests
     [ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
 
     [ 3 ] [
-        "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
+        "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
         parse-stream drop
 
         "foo" source-file definitions>> first assoc-size
@@ -151,7 +147,7 @@ IN: parser.tests
     ] unit-test
 
     [ 2 ] [
-        "IN: parser.tests USING: math strings ; GENERIC: smudge-me M: integer smudge-me ;" <string-reader> "foo"
+        "IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ;" <string-reader> "foo"
         parse-stream drop
 
         "foo" source-file definitions>> first assoc-size
@@ -190,7 +186,7 @@ IN: parser.tests
     [ ] [
         "a" source-files get delete-at
         2 [
-            "IN: parser.tests DEFER: x : y x ; : x y ;"
+            "IN: parser.tests DEFER: x : y ( -- ) x ; : x ( -- ) y ;"
             <string-reader> "a" parse-stream drop
         ] times
     ] unit-test
@@ -198,7 +194,7 @@ IN: parser.tests
     "a" source-files get delete-at
 
     [
-        "IN: parser.tests : x ; : y 3 throw ; this is an error"
+        "IN: parser.tests : x ( -- ) ; : y ( -- * ) 3 throw ; this is an error"
         <string-reader> "a" parse-stream
     ] [ source-file-error? ] must-fail-with
 
@@ -207,7 +203,7 @@ IN: parser.tests
     ] unit-test
 
     [ f ] [
-        "IN: parser.tests : x ;"
+        "IN: parser.tests : x ( -- ) ;"
         <string-reader> "a" parse-stream drop
         
         "y" "parser.tests" lookup
@@ -215,18 +211,18 @@ IN: parser.tests
 
     ! Test new forward definition logic
     [ ] [
-        "IN: axx : axx ;"
+        "IN: axx : axx ( -- ) ;"
         <string-reader> "axx" parse-stream drop
     ] unit-test
 
     [ ] [
-        "USE: axx IN: bxx : bxx ; : cxx axx bxx ;"
+        "USE: axx IN: bxx : bxx ( -- ) ; : cxx ( -- ) axx bxx ;"
         <string-reader> "bxx" parse-stream drop
     ] unit-test
 
     ! So we move the bxx word to axx...
     [ ] [
-        "IN: axx : axx ; : bxx ;"
+        "IN: axx : axx ( -- ) ; : bxx ( -- ) ;"
         <string-reader> "axx" parse-stream drop
     ] unit-test
 
@@ -234,7 +230,7 @@ IN: parser.tests
 
     ! And reload the file that uses it...
     [ ] [
-        "USE: axx IN: bxx : cxx axx bxx ;"
+        "USE: axx IN: bxx ( -- ) : cxx ( -- ) axx bxx ;"
         <string-reader> "bxx" parse-stream drop
     ] unit-test
     
@@ -243,17 +239,17 @@ IN: parser.tests
     ! Turning a generic into a non-generic could cause all
     ! kinds of funnyness
     [ ] [
-        "IN: ayy USE: kernel GENERIC: ayy M: object ayy ;"
+        "IN: ayy USE: kernel GENERIC: ayy ( a -- b ) M: object ayy ;"
         <string-reader> "ayy" parse-stream drop
     ] unit-test
 
     [ ] [
-        "IN: ayy USE: kernel : ayy ;"
+        "IN: ayy USE: kernel : ayy ( -- ) ;"
         <string-reader> "ayy" parse-stream drop
     ] unit-test
 
     [ ] [
-        "IN: azz TUPLE: my-class ; GENERIC: a-generic"
+        "IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b )"
         <string-reader> "azz" parse-stream drop
     ] unit-test
 
@@ -263,7 +259,7 @@ IN: parser.tests
     ] unit-test
 
     [ ] [
-        "IN: azz GENERIC: a-generic"
+        "IN: azz GENERIC: a-generic ( a -- b )"
         <string-reader> "azz" parse-stream drop
     ] unit-test
 
@@ -273,12 +269,12 @@ IN: parser.tests
     ] unit-test
 
     [ ] [
-        "IN: parser.tests : <bogus-error> ; : bogus <bogus-error> ;"
+        "IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- ) <bogus-error> ;"
         <string-reader> "bogus-error" parse-stream drop
     ] unit-test
 
     [ ] [
-        "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus <bogus-error> ;"
+        "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- ) <bogus-error> ;"
         <string-reader> "bogus-error" parse-stream drop
     ] unit-test
 
@@ -298,7 +294,7 @@ IN: parser.tests
     ] unit-test
 
     [
-        "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
+        "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b )"
         <string-reader> "removing-the-predicate" parse-stream
     ] [ error>> error>> error>> redefine-error? ] must-fail-with
 
@@ -313,7 +309,7 @@ IN: parser.tests
     ] unit-test
 
     [
-        "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
+        "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ( -- ) ;"
         <string-reader> "redefining-a-class-3" parse-stream drop
     ] [ error>> error>> error>> redefine-error? ] must-fail-with
 
@@ -338,7 +334,7 @@ IN: parser.tests
     ] [ error>> error>> error>> no-word-error? ] must-fail-with
 
     [
-        "IN: parser.tests : foo ; TUPLE: foo ;"
+        "IN: parser.tests : foo ( -- ) ; TUPLE: foo ;"
         <string-reader> "redefining-a-class-4" parse-stream drop
     ] [ error>> error>> error>> redefine-error? ] must-fail-with
 
@@ -369,7 +365,7 @@ IN: parser.tests
 
 2 [
     [ ] [
-        "IN: parser.tests TUPLE: foo ; GENERIC: foo"
+        "IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
         <string-reader> "redefining-a-class-5" parse-stream drop
     ] unit-test
 
@@ -381,14 +377,14 @@ IN: parser.tests
     [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
 
     [ ] [
-        "IN: parser.tests TUPLE: foo ; GENERIC: foo"
+        "IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
         <string-reader> "redefining-a-class-5" parse-stream drop
     ] unit-test
 
     [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
 
     [ ] [
-        "IN: parser.tests TUPLE: foo ; GENERIC: foo"
+        "IN: parser.tests TUPLE: foo ; GENERIC: foo ( a -- b )"
     <string-reader> "redefining-a-class-7" parse-stream drop
     ] unit-test
 
@@ -438,7 +434,7 @@ IN: parser.tests
     {
         "IN: parser.tests"
         "USING: math arrays ;"
-        "GENERIC: change-combination"
+        "GENERIC: change-combination ( a -- b )"
         "M: integer change-combination 1 ;"
         "M: array change-combination 2 ;"
     } "\n" join <string-reader> "change-combination-test" parse-stream drop
@@ -448,7 +444,7 @@ IN: parser.tests
     {
         "IN: parser.tests"
         "USING: math arrays ;"
-        "GENERIC# change-combination 1"
+        "GENERIC# change-combination 1 ( a -- b )"
         "M: integer change-combination 1 ;"
         "M: array change-combination 2 ;"
     } "\n" join <string-reader> "change-combination-test" parse-stream drop
@@ -467,7 +463,7 @@ IN: parser.tests
 ] unit-test
 
 [ [ ] ] [
-    "IN: parser.tests : staging-problem-test-1 1 ; : staging-problem-test-2 staging-problem-test-1 ;"
+    "IN: parser.tests : staging-problem-test-1 ( -- ) 1 ; : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
     <string-reader> "staging-problem-test" parse-stream
 ] unit-test
 
@@ -476,7 +472,7 @@ IN: parser.tests
 [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
 
 [ [ ] ] [
-    "IN: parser.tests << : staging-problem-test-1 1 ; >> : staging-problem-test-2 staging-problem-test-1 ;"
+    "IN: parser.tests << : staging-problem-test-1 ( -- ) 1 ; >> : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
     <string-reader> "staging-problem-test" parse-stream
 ] unit-test
 
@@ -495,7 +491,7 @@ IN: parser.tests
 ! Bogus error message
 DEFER: blahy
 
-[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ; TUPLE: blahy < tuple ; : blahy ;" eval ]
+[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval ]
 [ error>> error>> def>> \ blahy eq? ] must-fail-with
 
 [ ] [ f lexer set f file set "Hello world" note. ] unit-test
@@ -510,7 +506,7 @@ SYMBOLS: a b c ;
 
 DEFER: blah
 
-[ ] [ "IN: parser.tests GENERIC: blah" eval ] unit-test
+[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval ] unit-test
 [ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test
 
 [ f ] [ \ blah generic? ] unit-test
@@ -523,13 +519,13 @@ DEFER: blah1
 must-fail-with
 
 IN: qualified.tests.foo
-: x 1 ;
+: x ( -- a ) 1 ;
-: y 5 ;
+: y ( -- a ) 5 ;
 IN: qualified.tests.bar
-: x 2 ;
+: x ( -- a ) 2 ;
-: y 4 ;
+: y ( -- a ) 4 ;
 IN: qualified.tests.baz
-: x 3 ;
+: x ( -- a ) 3 ;
 
 QUALIFIED: qualified.tests.foo
 QUALIFIED: qualified.tests.bar

core/parser/parser.factor

@@ -4,7 +4,7 @@ USING: arrays definitions generic assocs kernel math namespaces
 sequences strings vectors words words.symbol quotations io combinators
 sorting splitting math.parser effects continuations io.files vocabs
 io.encodings.utf8 source-files classes hashtables compiler.errors
-compiler.units accessors sets lexer vocabs.parser slots ;
+compiler.units accessors sets lexer vocabs.parser effects.parser slots ;
 IN: parser
 
 : location ( -- loc )
@@ -132,7 +132,10 @@ M: f parse-quotation \ ] parse-until >quotation ;
 : parse-definition ( -- quot )
     \ ; parse-until >quotation ;
 
-: (:) ( -- word def ) CREATE-WORD parse-definition ;
+: (:) ( -- word def effect )
+    CREATE-WORD
+    complete-effect
+    parse-definition swap ;
 
 ERROR: bad-number ;
 

core/sequences/sequences.factor

@@ -176,7 +176,7 @@ PRIVATE>
     3 swap bounds-check nip first4-unsafe ; flushable
 
 : ?nth ( n seq -- elt/f )
-    2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; flushable
+    2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; inline
 
 MIXIN: virtual-sequence
 GENERIC: virtual-seq ( seq -- seq' )

core/slots/slots.factor

@@ -21,7 +21,7 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
         object bootstrap-word >>class ;
 
 : define-typecheck ( class generic quot props -- )
-    [ dup define-simple-generic create-method ] 2dip
+    [ create-method ] 2dip
     [ [ props>> ] [ drop ] [ ] tri* update ]
     [ drop define ]
     3bi ;
@@ -36,7 +36,6 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
 
 : reader-word ( name -- word )
     ">>" append "accessors" create
-    dup (( object -- value )) "declared-effect" set-word-prop
     dup t "reader" set-word-prop ;
 
 : reader-props ( slot-spec -- assoc )
@@ -46,13 +45,18 @@ PREDICATE: writer-method < method-body "writing" word-prop ;
         t "flushable" set
     ] H{ } make-assoc ;
 
+: define-reader-generic ( name -- )
+    reader-word (( object -- value )) define-simple-generic ;
+
 : define-reader ( class slot-spec -- )
-    [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
+    [ nip name>> define-reader-generic ]
-    define-typecheck ;
+    [
+        [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri
+        define-typecheck
+    ] 2bi ;
 
 : writer-word ( name -- word )
     "(>>" ")" surround "accessors" create
-    dup (( value object -- )) "declared-effect" set-word-prop
     dup t "writer" set-word-prop ;
 
 ERROR: bad-slot-value value class ;
@@ -92,9 +96,14 @@ ERROR: bad-slot-value value class ;
 : writer-props ( slot-spec -- assoc )
     "writing" associate ;
 
+: define-writer-generic ( name -- )
+    writer-word (( object value -- )) define-simple-generic ;
+
 : define-writer ( class slot-spec -- )
-    [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
+    [ nip name>> define-writer-generic ] [
-    define-typecheck ;
+        [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri
+        define-typecheck
+    ] 2bi ;
 
 : setter-word ( name -- word )
     ">>" prepend "accessors" create ;
@@ -134,8 +143,8 @@ ERROR: bad-slot-value value class ;
 
 : define-protocol-slot ( name -- )
     {
-        [ reader-word define-simple-generic ]
+        [ define-reader-generic ]
-        [ writer-word define-simple-generic ]
+        [ define-writer-generic ]
         [ define-setter ]
         [ define-changer ]
     } cleave ;

core/syntax/syntax-docs.factor

@@ -508,8 +508,8 @@ HELP: P"
 HELP: (
 { $syntax "( inputs -- outputs )" }
 { $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
-{ $description "Declares the stack effect of the most recently defined word, storing a new " { $link effect } " instance in the " { $snippet "\"declared-effect\"" } " word property." }
+{ $description "A stack effect declaration. This is treated as a comment unless it appears inside a word definition." }
-{ $notes "All words except those only pushing literals on the stack must have a stack effect declaration. See " { $link "effect-declaration" } " for details." } ;
+{ $see-also "effect-declaration" } ;
 
 HELP: ((
 { $syntax "(( inputs -- outputs ))" }

core/syntax/syntax.factor

@@ -111,7 +111,7 @@ IN: bootstrap.syntax
     "delimiter" [ word t "delimiter" set-word-prop ] define-core-syntax
 
     "SYNTAX:" [
-        (:) define-syntax
+        CREATE-WORD parse-definition define-syntax
     ] define-core-syntax
 
     "SYMBOL:" [
@@ -128,6 +128,11 @@ IN: bootstrap.syntax
         [ create-class-in define-singleton-class ] each
     ] define-core-syntax
 
+    "DEFER:" [
+        scan current-vocab create
+        [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri
+    ] define-core-syntax
+    
     "ALIAS:" [
         CREATE-WORD scan-word define-alias
     ] define-core-syntax
@@ -136,32 +141,24 @@ IN: bootstrap.syntax
         CREATE scan-object define-constant
     ] define-core-syntax
 
-    "DEFER:" [
-        scan current-vocab create
-        [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri
-    ] define-core-syntax
-
     ":" [
-        (:) define
+        (:) define-declared
     ] define-core-syntax
 
     "GENERIC:" [
-        CREATE-GENERIC define-simple-generic
+        [ simple-combination ] (GENERIC:)
     ] define-core-syntax
 
     "GENERIC#" [
-        CREATE-GENERIC
+        [ scan-word <standard-combination> ] (GENERIC:)
-        scan-word <standard-combination> define-generic
     ] define-core-syntax
 
     "MATH:" [
-        CREATE-GENERIC
+        [ math-combination ] (GENERIC:)
-        T{ math-combination } define-generic
     ] define-core-syntax
 
     "HOOK:" [
-        CREATE-GENERIC scan-word
+        [ scan-word <hook-combination> ] (GENERIC:)
-        <hook-combination> define-generic
     ] define-core-syntax
 
     "M:" [
@@ -221,8 +218,7 @@ IN: bootstrap.syntax
     ] define-core-syntax
 
     "(" [
-        ")" parse-effect
+        ")" parse-effect drop
-        word dup [ set-stack-effect ] [ 2drop ] if
     ] define-core-syntax
 
     "((" [

core/vocabs/loader/loader-tests.factor

@@ -132,7 +132,7 @@ IN: vocabs.loader.tests
     "vocabs.loader.test.d" vocab source-loaded?>>
 ] unit-test
 
-: forget-junk
+: forget-junk ( -- )
     [
         { "2" "a" "b" "d" "e" "f" }
         [

core/vocabs/loader/test/d/d.factor

@@ -1,3 +1,3 @@
 IN: vocabs.loader.test.d
 
-: foo iterate-next ;
+: foo ( -- ) iterate-next ;

core/vocabs/parser/parser.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Daniel Ehrenberg, Bruno Deferrari,
+! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari,
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs hashtables kernel namespaces sequences