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/destructors/destructors.factor

@@ -26,4 +26,4 @@ M: F-destructor dispose* alien>> F ;
 
 ;FUNCTOR
 
-: DESTRUCTOR: scan-word define-destructor ; parsing
+SYNTAX: DESTRUCTOR: scan-word define-destructor ;

basis/alien/fortran/fortran.factor

@@ -416,7 +416,7 @@ PRIVATE>
 : define-fortran-record ( name vocab fields -- )
     [ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
 
-: RECORD: scan in get parse-definition define-fortran-record ; parsing
+SYNTAX: RECORD: scan in get parse-definition define-fortran-record ;
 
 : set-fortran-abi ( library -- )
     library-fortran-abis get-global at fortran-abi set ;
@@ -437,16 +437,16 @@ MACRO: fortran-invoke ( return library function parameters -- )
     return library function parameters return [ "void" ] unless* parse-arglist
     [ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
 
-: SUBROUTINE: 
+SYNTAX: SUBROUTINE: 
     f "c-library" get scan ";" parse-tokens
-    [ "()" subseq? not ] filter define-fortran-function ; parsing
+    [ "()" subseq? not ] filter define-fortran-function ;
 
-: FUNCTION:
+SYNTAX: FUNCTION:
     scan "c-library" get scan ";" parse-tokens
-    [ "()" subseq? not ] filter define-fortran-function ; parsing
+    [ "()" subseq? not ] filter define-fortran-function ;
 
-: LIBRARY:
+SYNTAX: LIBRARY:
     scan
     [ "c-library" set ]
-    [ set-fortran-abi ] bi  ; parsing
+    [ set-fortran-abi ] bi ;
 

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
@@ -68,12 +68,11 @@ M: struct-type stack-size
     [ c-type-align ] [ max ] map-reduce ;
 
 : define-struct ( name vocab fields -- )
-    [
     [ 2drop ] [ make-fields ] 3bi
     [ struct-offsets ] keep
     [ [ type>> ] map compute-struct-align ] keep
     [ (define-struct) ] keep
-    ] [ 2drop '[ _ swap define-field ] ] 3bi each ;
+    [ define-field ] 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/alien/syntax/syntax.factor

@@ -7,35 +7,34 @@ effects assocs combinators lexer strings.parser alien.parser
 fry vocabs.parser words.constant ;
 IN: alien.syntax
 
-: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
+SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ;
 
-: ALIEN: scan string>number <alien> parsed ; parsing
+SYNTAX: ALIEN: scan string>number <alien> parsed ;
 
-: BAD-ALIEN <bad-alien> parsed ; parsing
+SYNTAX: BAD-ALIEN <bad-alien> parsed ;
 
-: LIBRARY: scan "c-library" set ; parsing
+SYNTAX: LIBRARY: scan "c-library" set ;
 
-: FUNCTION:
+SYNTAX: FUNCTION:
     scan "c-library" get scan ";" parse-tokens
     [ "()" subseq? not ] filter
-    define-function ; parsing
+    define-function ;
 
-: TYPEDEF:
+SYNTAX: TYPEDEF:
-    scan scan typedef ; parsing
+    scan scan typedef ;
 
-: C-STRUCT:
+SYNTAX: C-STRUCT:
-    scan in get parse-definition define-struct ; parsing
+    scan in get parse-definition define-struct ;
 
-: C-UNION:
+SYNTAX: C-UNION:
-    scan parse-definition define-union ; parsing
+    scan parse-definition define-union ;
 
-: C-ENUM:
+SYNTAX: C-ENUM:
     ";" parse-tokens
     [ [ create-in ] dip define-constant ] each-index ;
-    parsing
 
 : address-of ( name library -- value )
     load-library dlsym [ "No such symbol" throw ] unless* ;
 
-: &:
+SYNTAX: &:
-    scan "c-library" get '[ _ _ address-of ] over push-all ; parsing
+    scan "c-library" get '[ _ _ address-of ] over push-all ;

basis/bit-arrays/bit-arrays.factor

@@ -68,7 +68,7 @@ M: bit-array resize
 
 M: bit-array byte-length length 7 + -3 shift ;
 
-: ?{ \ } [ >bit-array ] parse-literal ; parsing
+SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
 
 : integer>bit-array ( n -- bit-array )
     dup 0 = [

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/bit-vectors/bit-vectors.factor

@@ -31,7 +31,7 @@ M: bit-array new-resizable drop <bit-vector> ;
 
 INSTANCE: bit-vector growable
 
-: ?V{ \ } [ >bit-vector ] parse-literal ; parsing
+SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
 
 M: bit-vector >pprint-sequence ;
 M: bit-vector pprint-delims drop \ ?V{ \ } ;

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/byte-vectors/byte-vectors.factor

@@ -42,7 +42,7 @@ M: byte-array like
 
 M: byte-array new-resizable drop <byte-vector> ;
 
-: BV{ \ } [ >byte-vector ] parse-literal ; parsing
+SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ;
 
 M: byte-vector pprint* pprint-object ;
 M: byte-vector pprint-delims drop \ BV{ \ } ;

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/calendar/format/format.factor

@@ -46,6 +46,11 @@ IN: calendar.format
 
 : read-0000 ( -- n ) 4 read string>number ;
 
+: hhmm>timestamp ( hhmm -- timestamp )
+    [
+        0 0 0 read-00 read-00 0 instant <timestamp>
+    ] with-string-reader ;
+
 GENERIC: day. ( obj -- )
 
 M: integer day. ( n -- )

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/cocoa/cocoa.factor

@@ -14,18 +14,14 @@ SYMBOL: sent-messages
 : remember-send ( selector -- )
     sent-messages (remember-send) ;
 
-: ->
+SYNTAX: -> scan dup remember-send parsed \ send parsed ;
-    scan dup remember-send parsed \ send parsed ;
-    parsing
 
 SYMBOL: super-sent-messages
 
 : remember-super-send ( selector -- )
     super-sent-messages (remember-send) ;
 
-: SUPER->
+SYNTAX: SUPER-> scan dup remember-super-send parsed \ super-send parsed ;
-    scan dup remember-super-send parsed \ super-send parsed ;
-    parsing
 
 SYMBOL: frameworks
 
@@ -33,9 +29,9 @@ frameworks [ V{ } clone ] initialize
 
 [ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
 
-: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; parsing
+SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
 
-: IMPORT: scan [ ] import-objc-class ; parsing
+SYNTAX: IMPORT: scan [ ] import-objc-class ;
 
 "Compiling Objective C bridge..." print
 

basis/cocoa/messages/messages.factor

@@ -22,15 +22,13 @@ SYMBOL: super-message-senders
 message-senders [ H{ } clone ] initialize
 super-message-senders [ H{ } clone ] initialize
 
-: cache-stub ( method function hash -- )
+: cache-stub ( method assoc function -- )
-    [
+    '[ _ sender-stub ] cache drop ;
-        over get [ 2drop ] [ over [ sender-stub ] dip set ] if
-    ] bind ;
 
 : cache-stubs ( method -- )
-    dup
+    [ super-message-senders get "objc_msgSendSuper" cache-stub ]
-    "objc_msgSendSuper" super-message-senders get cache-stub
+    [ message-senders get "objc_msgSend" cache-stub ]
-    "objc_msgSend" message-senders get cache-stub ;
+    bi ;
 
 : <super> ( receiver -- super )
     "objc-super" <c-object> [

basis/cocoa/subclassing/subclassing.factor

@@ -76,6 +76,6 @@ SYMBOL: +superclass+
         import-objc-class
     ] bind ;
 
-: CLASS:
+SYNTAX: CLASS:
     parse-definition unclip
-    >hashtable define-objc-class ; parsing
+    >hashtable define-objc-class ;

basis/colors/constants/constants.factor

@@ -30,4 +30,4 @@ ERROR: no-such-color name ;
 : named-color ( name -- color )
     dup rgb.txt at [ ] [ no-such-color ] ?if ;
 
-: COLOR: scan named-color parsed ; parsing
+SYNTAX: COLOR: scan named-color parsed ;

basis/compiler/cfg/instructions/syntax/syntax.factor

@@ -13,10 +13,10 @@ IN: compiler.cfg.instructions.syntax
 : insn-effect ( word -- effect )
     boa-effect in>> but-last f <effect> ;
 
-: INSN:
+SYNTAX: INSN:
     parse-tuple-definition "regs" suffix
     [ dup tuple eq? [ drop insn-word ] when ] dip
     [ define-tuple-class ]
     [ 2drop save-location ]
     [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
-    3tri ; parsing
+    3tri ;

basis/compiler/cfg/registers/registers.factor

@@ -17,6 +17,6 @@ C: <ds-loc> ds-loc
 TUPLE: rs-loc < loc ;
 C: <rs-loc> rs-loc
 
-: V scan-word scan-word vreg boa parsed ; parsing
+SYNTAX: V scan-word scan-word vreg boa parsed ;
-: D scan-word <ds-loc> parsed ; parsing
+SYNTAX: D scan-word <ds-loc> parsed ;
-: R scan-word <rs-loc> parsed ; parsing
+SYNTAX: R scan-word <rs-loc> parsed ;

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

@@ -16,8 +16,8 @@ MACRO: set-slots ( slots -- quot )
     [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
     define-declared ;
 
-: CONSTRUCTOR:
+SYNTAX: CONSTRUCTOR:
     scan-word [ name>> "<" ">" surround create-in ] keep
-    "(" expect ")" parse-effect
+    complete-effect
     parse-definition
-    define-constructor ; parsing
+    define-constructor ;

basis/core-text/utilities/utilities.factor

@@ -3,7 +3,7 @@
 USING: words parser alien alien.c-types kernel fry accessors ;
 IN: core-text.utilities
 
-: C-GLOBAL:
+SYNTAX: C-GLOBAL:
     CREATE-WORD
     dup name>> '[ _ f dlsym *void* ]
-    (( -- value )) define-declared ; parsing
+    (( -- value )) define-declared ;

basis/cpu/ppc/assembler/backend/backend.factor

@@ -21,7 +21,7 @@ IN: cpu.ppc.assembler.backend
 : define-d-insn ( word opcode -- )
     [ d-insn ] curry (( d a simm -- )) define-declared ;
 
-: D: CREATE scan-word define-d-insn ; parsing
+SYNTAX: D: CREATE scan-word define-d-insn ;
 
 : sd-insn ( d a simm opcode -- )
     [ s>u16 { 0 21 16 } bitfield ] dip insn ;
@@ -29,7 +29,7 @@ IN: cpu.ppc.assembler.backend
 : define-sd-insn ( word opcode -- )
     [ sd-insn ] curry (( d a simm -- )) define-declared ;
 
-: SD: CREATE scan-word define-sd-insn ; parsing
+SYNTAX: SD: CREATE scan-word define-sd-insn ;
 
 : i-insn ( li aa lk opcode -- )
     [ { 0 1 0 } bitfield ] dip insn ;
@@ -40,26 +40,26 @@ IN: cpu.ppc.assembler.backend
 : (X) ( -- word quot )
     CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
 
-: X: (X) (( a s b -- )) define-declared ; parsing
+SYNTAX: X: (X) (( a s b -- )) define-declared ;
 
 : (1) ( quot -- quot' ) [ 0 ] prepose ;
 
-: X1: (X) (1) (( a s -- )) define-declared ; parsing
+SYNTAX: X1: (X) (1) (( a s -- )) define-declared ;
 
 : xfx-insn ( d spr xo opcode -- )
     [ { 1 11 21 } bitfield ] dip insn ;
 
 : CREATE-MF ( -- word ) scan "MF" prepend create-in ;
 
-: MFSPR:
+SYNTAX: MFSPR:
     CREATE-MF scan-word 5 shift [ 339 31 xfx-insn ] curry
-    (( d -- )) define-declared ; parsing
+    (( d -- )) define-declared ;
 
 : CREATE-MT ( -- word ) scan "MT" prepend create-in ;
 
-: MTSPR:
+SYNTAX: MTSPR:
     CREATE-MT scan-word 5 shift [ 467 31 xfx-insn ] curry
-    (( d -- )) define-declared ; parsing
+    (( d -- )) define-declared ;
 
 : xo-insn ( d a b oe rc xo opcode -- )
     [ { 1 0 10 11 16 21 } bitfield ] dip insn ;
@@ -68,9 +68,9 @@ IN: cpu.ppc.assembler.backend
     CREATE scan-word scan-word scan-word scan-word
     [ xo-insn ] 2curry 2curry ;
 
-: XO: (XO) (( a s b -- )) define-declared ; parsing
+SYNTAX: XO: (XO) (( a s b -- )) define-declared ;
 
-: XO1: (XO) (1) (( a s -- )) define-declared ; parsing
+SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
 
 GENERIC# (B) 2 ( dest aa lk -- )
 M: integer (B) 18 i-insn ;
@@ -84,11 +84,11 @@ M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
 
 : CREATE-B ( -- word ) scan "B" prepend create-in ;
 
-: BC:
+SYNTAX: BC:
     CREATE-B scan-word scan-word
-    [ rot BC ] 2curry (( c -- )) define-declared ; parsing
+    [ rot BC ] 2curry (( c -- )) define-declared ;
 
-: B:
+SYNTAX: B:
     CREATE-B scan-word scan-word scan-word scan-word scan-word
     [ b-insn ] curry curry curry curry curry
-    (( bo -- )) define-declared ; parsing
+    (( bo -- )) define-declared ;

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/cpu/x86/assembler/syntax/syntax.factor

@@ -11,5 +11,4 @@ IN: cpu.x86.assembler.syntax
 : define-registers ( names size -- )
     '[ _ define-register ] each-index ;
 
-: REGISTERS: ( -- )
+SYNTAX: REGISTERS: scan-word ";" parse-tokens swap define-registers ;
-    scan-word ";" parse-tokens swap define-registers ; parsing

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/definitions/icons/icons.factor

@@ -14,10 +14,10 @@ GENERIC: definition-icon ( definition -- path )
 
 <<
 
-: ICON:
+SYNTAX: ICON:
     scan-word \ definition-icon create-method
     scan '[ drop _ definition-icon-path ]
-    define ; parsing
+    define ;
 
 >>
 

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/delegate/delegate.factor

@@ -85,9 +85,9 @@ PRIVATE>
 : define-consult ( consultation -- )
     [ register-consult ] [ consult-methods ] bi ;
 
-: CONSULT:
+SYNTAX: CONSULT:
     scan-word scan-word parse-definition <consultation>
-    [ save-location ] [ define-consult ] bi ; parsing
+    [ save-location ] [ define-consult ] bi ;
 
 M: consultation where loc>> ;
 
@@ -144,8 +144,8 @@ PRIVATE>
         [ initialize-protocol-props ] 2tri
     ] 2bi ;
 
-: PROTOCOL:
+SYNTAX: PROTOCOL:
-    CREATE-WORD parse-definition define-protocol ; parsing
+    CREATE-WORD parse-definition define-protocol ;
 
 PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
 
@@ -159,7 +159,7 @@ M: protocol definer drop \ PROTOCOL: \ ; ;
 
 M: protocol group-words protocol-words ;
 
-: SLOT-PROTOCOL:
+SYNTAX: SLOT-PROTOCOL:
     CREATE-WORD ";" parse-tokens
     [ [ reader-word ] [ writer-word ] bi 2array ] map concat
-    define-protocol ; parsing
+    define-protocol ;

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/fry/fry.factor

@@ -53,4 +53,4 @@ M: callable deep-fry
 
 M: object deep-fry , ;
 
-: '[ parse-quotation fry over push-all ; parsing
+SYNTAX: '[ parse-quotation fry over push-all ;

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,7 +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-declared* ( word def effect -- ) pick set-word define-declared ;
 
 TUPLE: fake-quotation seq ;
 
@@ -39,9 +41,14 @@ 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 ;
 
-: `TUPLE:
+: DEFINE* ( accum -- accum ) \ define-declared* parsed ;
+
+SYNTAX: `TUPLE:
     scan-param parsed
     scan {
         { ";" [ tuple parsed f parsed ] }
@@ -52,40 +59,38 @@ M: object fake-quotations> ;
             make parsed
         ]
     } case
-    \ define-tuple-class parsed ; parsing
+    \ define-tuple-class parsed ;
 
-: `M:
+SYNTAX: `M:
-    effect off
     scan-param parsed
     scan-param parsed
     \ create-method-in parsed
     parse-definition*
-    DEFINE* ; parsing
+    \ define* parsed ;
 
-: `C:
+SYNTAX: `C:
-    effect off
     scan-param parsed
     scan-param parsed
-    [ [ boa ] curry ] over push-all
+    complete-effect
-    DEFINE* ; parsing
+    [ [ [ boa ] curry ] over push-all ] dip parsed
+    \ define-declared* parsed ;
 
-: `:
+SYNTAX: `:
-    effect off
+    scan-param parsed
+    parse-declared*
+    \ define-declared* parsed ;
+
+SYNTAX: `SYNTAX:
     scan-param parsed
     parse-definition*
-    DEFINE* ; parsing
+    \ define-syntax parsed ;
 
-: `INSTANCE:
+SYNTAX: `INSTANCE:
     scan-param parsed
     scan-param parsed
-    \ add-mixin-instance parsed ; parsing
+    \ add-mixin-instance parsed ;
 
-: `inline [ word make-inline ] over push-all ; parsing
+SYNTAX: `inline [ word make-inline ] over push-all ;
-
-: `parsing [ word make-parsing ] over push-all ; parsing
-
-: `(
-    ")" parse-effect effect set ; parsing
 
 : (INTERPOLATE) ( accum quot -- accum )
     [ scan interpolate-locals ] dip
@@ -93,11 +98,11 @@ M: object fake-quotations> ;
 
 PRIVATE>
 
-: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing
+SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ;
 
-: DEFINES [ create-in ] (INTERPOLATE) ; parsing
+SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
 
-: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing
+SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
 
 DEFER: ;FUNCTOR delimiter
 
@@ -110,9 +115,8 @@ DEFER: ;FUNCTOR delimiter
         { "C:" POSTPONE: `C: }
         { ":" POSTPONE: `: }
         { "INSTANCE:" POSTPONE: `INSTANCE: }
+        { "SYNTAX:" POSTPONE: `SYNTAX: }
         { "inline" POSTPONE: `inline }
-        { "parsing" POSTPONE: `parsing }
-        { "(" POSTPONE: `( }
     } ;
 
 : push-functor-words ( -- )
@@ -127,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>
 
-: FUNCTOR: (FUNCTOR:) define ; parsing
+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/grouping/grouping-docs.factor

@@ -97,8 +97,7 @@ HELP: <clumps>
     { $example
         "USING: grouping sequences math prettyprint kernel ;"
         "IN: scratchpad"
-        ": share-price"
+        "CONSTANT: share-price { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 }"
-        "    { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
         ""
         "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
         "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"

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/cookbook/cookbook.factor

@@ -121,16 +121,16 @@ $nl
     "sequences"
 } ;
 
-ARTICLE: "cookbook-variables" "Variables cookbook"
+ARTICLE: "cookbook-variables" "Dynamic variables cookbook"
-"Before using a variable, you must define a symbol for it:"
-{ $code "SYMBOL: name" }
 "A symbol is a word which pushes itself on the stack when executed. Try it:"
 { $example "SYMBOL: foo" "foo ." "foo" }
+"Before using a variable, you must define a symbol for it:"
+{ $code "SYMBOL: name" }
 "Symbols can be passed to the " { $link get } " and " { $link set } " words to read and write variable values:"
-{ $example "\"Slava\" name set" "name get print" "Slava" }
+{ $unchecked-example "\"Slava\" name set" "name get print" "Slava" }
 "If you set variables inside a " { $link with-scope } ", their values will be lost after leaving the scope:"
-{ $example
+{ $unchecked-example
-    ": print-name name get print ;"
+    ": print-name ( -- ) name get print ;"
     "\"Slava\" name set"
     "["
     "    \"Diana\" name set"
@@ -139,11 +139,8 @@ ARTICLE: "cookbook-variables" "Variables cookbook"
     "\"Here, the name is \" write  print-name"
     "There, the name is Diana\nHere, the name is Slava"
 }
-{ $curious
-    "Variables are dynamically-scoped in Factor."
-}
 { $references
-    "There is a lot more to be said about variables and namespaces."
+    "There is a lot more to be said about dynamically-scoped variables and namespaces."
     "namespaces"
 } ;
 

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,23 +1,19 @@
-! 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
 vocabs.parser ;
 IN: help.syntax
 
-: HELP:
+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 ; parsing
 
-: ARTICLE:
+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 ; parsing
+    ] dip remember-definition ;
 
-: ABOUT:
+SYNTAX: ABOUT:
-    in get vocab
+    in get vocab scan-object >>help changed-definition ;
-    dup changed-definition
-    scan-object >>help drop ; parsing

basis/hints/hints.factor

@@ -59,12 +59,11 @@ M: object specializer-declaration class ;
 : specialized-length ( specializer -- n )
     dup [ array? ] all? [ first ] when length ;
 
-: HINTS:
+SYNTAX: HINTS:
     scan-object
     dup method-spec? [ first2 method ] when
     [ redefined ]
     [ parse-definition "specializer" set-word-prop ] bi ;
-    parsing
 
 ! Default specializers
 { first first2 first3 first4 }

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/html/templates/chloe/components/components.factor

@@ -25,8 +25,7 @@ M: tuple-class component-tag ( tag class -- )
     [ compile-component-attrs ] 2bi
     [ render ] [code] ;
 
-: COMPONENT:
+SYNTAX: COMPONENT:
     scan-word
     [ name>> ] [ '[ _ component-tag ] ] bi
     define-chloe-tag ;
-    parsing

basis/html/templates/chloe/syntax/syntax.factor

@@ -15,8 +15,8 @@ tags [ H{ } clone ] initialize
 
 : define-chloe-tag ( name quot -- ) swap tags get set-at ;
 
-: CHLOE:
+SYNTAX: CHLOE:
-    scan parse-definition define-chloe-tag ; parsing
+    scan parse-definition define-chloe-tag ;
 
 CONSTANT: chloe-ns "http://factorcode.org/chloe/1.0"
 

basis/html/templates/fhtml/fhtml.factor

@@ -49,7 +49,7 @@ DEFER: <% delimiter
         drop
     ] if ;
 
-: %> lexer get parse-%> ; parsing
+SYNTAX: %> lexer get parse-%> ;
 
 : parse-template-lines ( lines -- quot )
     <template-lexer> [

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/interpolate/interpolate.factor

@@ -38,6 +38,6 @@ MACRO: interpolate ( string -- )
 : interpolate-locals ( string -- quot )
     [ search [ ] ] (interpolate) ;
 
-: I[
+SYNTAX: I[
     "]I" parse-multiline-string
-    interpolate-locals over push-all ; parsing
+    interpolate-locals over push-all ;

basis/interval-maps/interval-maps-docs.factor

@@ -1,22 +1,32 @@
-USING: help.markup help.syntax ;
+! Copyright (C) 2008, 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax assocs kernel sequences ;
 IN: interval-maps
 
 HELP: interval-at*
-{ $values { "key" "an object" } { "map" "an interval map" } { "value" "the value for the key, or f" } { "?" "whether the key is present" } }
+{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } { "?" "whether the key is present" } }
 { $description "Looks up a key in an interval map, returning the corresponding value if the item is in an interval in the map, and a boolean flag. The operation takes O(log n) time." } ;
 
 HELP: interval-at
-{ $values { "key" "an object" } { "map" "an interval map" } { "value" "the value for the key, or f" } }
+{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } }
 { $description "Looks up a key in an interval map, returning the value of the corresponding interval, or f if the interval is not present in the map." } ;
 
 HELP: interval-key?
-{ $values { "key" "an object" } { "map" "an interval map" } { "?" "a boolean" } }
+{ $values { "key" object } { "map" interval-map } { "?" "a boolean" } }
 { $description "Tests whether an object is in an interval in the interval map, returning t if the object is present." } ;
 
 HELP: <interval-map>
-{ $values { "specification" "an assoc" } { "map" "an interval map" } }
+{ $values { "specification" assoc } { "map" interval-map } }
 { $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ;
 
+HELP: interval-values
+{ $values { "map" interval-map } { "values" sequence } }
+{ $description "Constructs a list of all of the values that interval map keys are associated with. This list may contain duplicates." } ;
+
+HELP: coalesce
+{ $values { "alist" "an association list with integer keys" } { "specification" { "array of the format used by " { $link <interval-map> } } } }
+{ $description "Finds ranges used in the given alist, coalescing them into a single range." } ;
+
 ARTICLE: "interval-maps" "Interval maps"
 "The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between."
 $nl
@@ -24,7 +34,9 @@ $nl
 { $subsection interval-at* }
 { $subsection interval-at }
 { $subsection interval-key? }
+{ $subsection interval-values }
 "Use the following to construct interval maps"
-{ $subsection <interval-map> } ;
+{ $subsection <interval-map> }
+{ $subsection coalesce } ;
 
 ABOUT: "interval-maps"

basis/interval-maps/interval-maps.factor

@@ -8,17 +8,21 @@ TUPLE: interval-map array ;
 
 <PRIVATE
 
+ALIAS: start first
+ALIAS: end second
+ALIAS: value third
+
 : find-interval ( key interval-map -- interval-node )
-    [ first <=> ] with search nip ;
+    array>> [ start <=> ] with search nip ;
 
 : interval-contains? ( key interval-node -- ? )
-    first2 between? ;
+    [ start ] [ end ] bi between? ;
 
 : all-intervals ( sequence -- intervals )
     [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;
 
 : disjoint? ( node1 node2 -- ? )
-    [ second ] [ first ] bi* < ;
+    [ end ] [ start ] bi* < ;
 
 : ensure-disjoint ( intervals -- intervals )
     dup [ disjoint? ] monotonic?
@@ -30,14 +34,17 @@ TUPLE: interval-map array ;
 PRIVATE>
 
 : interval-at* ( key map -- value ? )
-    [ drop ] [ array>> find-interval ] 2bi
+    [ drop ] [ find-interval ] 2bi
     [ nip ] [ interval-contains? ] 2bi
-    [ third t ] [ drop f f ] if ;
+    [ value t ] [ drop f f ] if ;
 
 : interval-at ( key map -- value ) interval-at* drop ;
 
 : interval-key? ( key map -- ? ) interval-at* nip ;
 
+: interval-values ( map -- values )
+    array>> [ value ] map ;
+
 : <interval-map> ( specification -- map )
     all-intervals [ [ first second ] compare ] sort
     >intervals ensure-disjoint interval-map boa ;

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/euc/euc.factor

@@ -63,6 +63,6 @@ SYMBOL: euc-table
 
 PRIVATE>
 
-: EUC:
+SYNTAX: EUC:
     ! EUC: euc-kr "vocab:io/encodings/korean/cp949.txt"
-    CREATE-CLASS scan-object define-euc ; parsing
+    CREATE-CLASS scan-object define-euc ;

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

@@ -7,30 +7,30 @@ IN: io.encodings.iso2022
 [ "hello" ] [ "hello" >byte-array iso2022 decode ] unit-test
 [ "hello" ] [ "hello" iso2022 encode >string ] unit-test
 
-[ "hi" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: B CHAR: i } iso2022 decode ] unit-test
+[ "hi" ] [ B{ CHAR: h ESC CHAR: ( CHAR: B CHAR: i } iso2022 decode ] unit-test
-[ "hi" ] [ B{ CHAR: h CHAR: i $ ESC CHAR: ( CHAR: B } iso2022 decode ] unit-test
+[ "hi" ] [ B{ CHAR: h CHAR: i ESC CHAR: ( CHAR: B } iso2022 decode ] unit-test
-[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i $ ESC CHAR: ( } iso2022 decode ] unit-test
+[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i ESC CHAR: ( } iso2022 decode ] unit-test
-[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i $ ESC } iso2022 decode ] unit-test
+[ "hi\u00fffd" ] [ B{ CHAR: h CHAR: i ESC } iso2022 decode ] unit-test
 
-[ B{ CHAR: h $ ESC CHAR: ( CHAR: J HEX: D8 } ] [ "h\u00ff98" iso2022 encode ] unit-test
+[ B{ CHAR: h ESC CHAR: ( CHAR: J HEX: D8 } ] [ "h\u00ff98" iso2022 encode ] unit-test
-[ "h\u00ff98" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J HEX: D8 } iso2022 decode ] unit-test
+[ "h\u00ff98" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J HEX: D8 } iso2022 decode ] unit-test
-[ "hi" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J CHAR: i } iso2022 decode ] unit-test
+[ "hi" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J CHAR: i } iso2022 decode ] unit-test
-[ "h" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J } iso2022 decode ] unit-test
+[ "h" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J } iso2022 decode ] unit-test
-[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: ( CHAR: J HEX: 80 } iso2022 decode ] unit-test
+[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: ( CHAR: J HEX: 80 } iso2022 decode ] unit-test
 
-[ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } ] [ "h\u007126" iso2022 encode ] unit-test
+[ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } ] [ "h\u007126" iso2022 encode ] unit-test
-[ "h\u007126" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } iso2022 decode ] unit-test
+[ "h\u007126" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 3E HEX: 47 } iso2022 decode ] unit-test
-[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 3E } iso2022 decode ] unit-test
+[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 3E } iso2022 decode ] unit-test
-[ "h" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B } iso2022 decode ] unit-test
+[ "h" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B } iso2022 decode ] unit-test
-[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ } iso2022 decode ] unit-test
+[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ } iso2022 decode ] unit-test
-[ "h\u00fffd" ] [ B{ CHAR: h $ ESC } iso2022 decode ] unit-test
+[ "h\u00fffd" ] [ B{ CHAR: h ESC } iso2022 decode ] unit-test
-[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: B HEX: 80 HEX: 80 } iso2022 decode ] unit-test
+[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: B HEX: 80 HEX: 80 } iso2022 decode ] unit-test
 
-[ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } ] [ "h\u0058ce" iso2022 encode ] unit-test
+[ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } ] [ "h\u0058ce" iso2022 encode ] unit-test
-[ "h\u0058ce" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } iso2022 decode ] unit-test
+[ "h\u0058ce" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 HEX: 54 } iso2022 decode ] unit-test
-[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 } iso2022 decode ] unit-test
+[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 38 } iso2022 decode ] unit-test
-[ "h" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D } iso2022 decode ] unit-test
+[ "h" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D } iso2022 decode ] unit-test
-[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( } iso2022 decode ] unit-test
+[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( } iso2022 decode ] unit-test
-[ "h\u00fffd" ] [ B{ CHAR: h $ ESC CHAR: $ CHAR: ( CHAR: D HEX: 70 HEX: 70 } iso2022 decode ] unit-test
+[ "h\u00fffd" ] [ B{ CHAR: h ESC CHAR: $ CHAR: ( CHAR: D HEX: 70 HEX: 70 } iso2022 decode ] unit-test
 
 [ "\u{syriac-music}" iso2022 encode ] must-fail

basis/io/encodings/iso2022/iso2022.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.encodings kernel sequences io simple-flat-file sets math
 combinators.short-circuit io.binary values arrays assocs
-locals accessors combinators literals biassocs byte-arrays ;
+locals accessors combinators biassocs byte-arrays parser ;
 IN: io.encodings.iso2022
 
 SINGLETON: iso2022
@@ -31,12 +31,12 @@ M: iso2022 <encoder>
 M: iso2022 <decoder>
     make-iso-coder <decoder> ;
 
-CONSTANT: ESC HEX: 16
+<< SYNTAX: ESC HEX: 16 parsed ; >>
 
-CONSTANT: switch-ascii B{ $ ESC CHAR: ( CHAR: B }
+CONSTANT: switch-ascii B{ ESC CHAR: ( CHAR: B }
-CONSTANT: switch-jis201 B{ $ ESC CHAR: ( CHAR: J }
+CONSTANT: switch-jis201 B{ ESC CHAR: ( CHAR: J }
-CONSTANT: switch-jis208 B{ $ ESC CHAR: $ CHAR: B }
+CONSTANT: switch-jis208 B{ ESC CHAR: $ CHAR: B }
-CONSTANT: switch-jis212 B{ $ ESC CHAR: $ CHAR: ( CHAR: D }
+CONSTANT: switch-jis212 B{ ESC CHAR: $ CHAR: ( CHAR: D }
 
 : find-type ( char -- code type )
     {

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

@@ -3,7 +3,7 @@ tools.test parser math namespaces continuations vocabs kernel
 compiler.units eval vocabs.parser ;
 IN: listener.tests
 
-: hello "Hi" print ; parsing
+SYNTAX: hello "Hi" print ;
 
 : parse-interactive ( string -- quot )
     <string-reader> stream-read-quot ;
@@ -50,7 +50,7 @@ IN: listener.tests
 
 [
     [ ] [
-        "IN: listener.tests : hello\n\"world\" ;" parse-interactive
+        "IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive
         drop
     ] unit-test
 ] with-file-vocabs

basis/lists/lazy/lazy-docs.factor

@@ -108,7 +108,7 @@ HELP: lappend
 { $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
 
 HELP: lfrom-by
-{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "list" "a lazy list of integers" } }
+{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "lazy-from-by" "a lazy list of integers" } }
 { $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
 
 HELP: lfrom

basis/lists/lazy/lazy.factor

@@ -203,7 +203,7 @@ M: lazy-append nil? ( lazy-append -- bool )
 
 TUPLE: lazy-from-by n quot ;
 
-C: lfrom-by lazy-from-by ( n quot -- list )
+C: lfrom-by lazy-from-by
 
 : lfrom ( n -- list )
     [ 1+ ] lfrom-by ;

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

@@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
 namespaces arrays strings prettyprint io.streams.string parser
 accessors generic eval combinators combinators.short-circuit
 combinators.short-circuit.smart math.order math.functions
-definitions compiler.units fry lexer words.symbol see ;
+definitions compiler.units fry lexer words.symbol see multiline ;
 IN: locals.tests
 
 :: foo ( a b -- a a ) a a ;
@@ -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 )
 
@@ -392,6 +392,65 @@ ERROR: punned-class x ;
 
 [ 9 ] [ 3 big-case-test ] unit-test
 
+! Dan found this problem
+: littledan-case-problem-1 ( a -- b )
+    {
+        { t [ 3 ] }
+        { f [ 4 ] }
+        [| x | x 12 + { "howdy" } nth ]
+    } case ;
+
+\ littledan-case-problem-1 must-infer
+
+[ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test
+[ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test
+
+:: littledan-case-problem-2 ( a -- b )
+    a {
+        { t [ a not ] }
+        { f [ 4 ] }
+        [| x | x a - { "howdy" } nth ]
+    } case ;
+
+\ littledan-case-problem-2 must-infer
+
+[ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test
+[ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test
+
+:: littledan-cond-problem-1 ( a -- b )
+    a {
+        { [ dup 0 < ] [ drop a not ] }
+        { [| y | y y 0 > ] [ drop 4 ] }
+        [| x | x a - { "howdy" } nth ]
+    } cond ;
+
+\ littledan-cond-problem-1 must-infer
+
+[ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test
+[ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test
+[ "howdy" ] [ 0 \ littledan-cond-problem-1 def>> call ] unit-test
+[ f ] [ -12 littledan-cond-problem-1 ] unit-test
+[ 4 ] [ 12 littledan-cond-problem-1 ] unit-test
+[ "howdy" ] [ 0 littledan-cond-problem-1 ] unit-test
+
+/*
+:: littledan-case-problem-3 ( a quot -- b )
+    a {
+        { t [ a not ] }
+        { f [ 4 ] }
+        quot
+    } case ; inline
+
+[ f ] [ t [ ] littledan-case-problem-3 ] unit-test
+[ 144 ] [ 12 [ sq ] littledan-case-problem-3 ] unit-test
+[| | [| a | a ] littledan-case-problem-3 ] must-infer
+
+: littledan-case-problem-4 ( a -- b )
+    [ 1 + ] littledan-case-problem-3 ;
+
+\ littledan-case-problem-4 must-infer
+*/
+
 GENERIC: lambda-method-forget-test ( a -- b )
 
 M:: integer lambda-method-forget-test ( a -- b ) ;

basis/locals/locals.factor

@@ -1,31 +1,29 @@
-! 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
 locals.errors ;
 IN: locals
 
-: :>
+SYNTAX: :>
     scan locals get [ :>-outside-lambda-error ] unless*
-    [ make-local ] bind <def> parsed ; parsing
+    [ make-local ] bind <def> parsed ;
 
-: [| parse-lambda over push-all ; parsing
+SYNTAX: [| parse-lambda over push-all ;
 
-: [let parse-let over push-all ; parsing
+SYNTAX: [let parse-let over push-all ;
 
-: [let* parse-let* over push-all ; parsing
+SYNTAX: [let* parse-let* over push-all ;
 
-: [wlet parse-wlet over push-all ; parsing
+SYNTAX: [wlet parse-wlet over push-all ;
 
-: :: (::) define ; parsing
+SYNTAX: :: (::) define-declared ;
 
-: M:: (M::) define ; parsing
+SYNTAX: M:: (M::) define ;
 
-: MACRO:: (::) define-macro ; parsing
+SYNTAX: MACRO:: (::) define-macro ;
 
-: MEMO:: (::) define-memoized ; parsing
+SYNTAX: MEMO:: (::) define-memoized ;
-
-USE: syntax
 
 {
     "locals.macros"

basis/locals/macros/macros.factor

@@ -1,6 +1,6 @@
-! 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: accessors assocs kernel locals.types macros.expander ;
+USING: accessors assocs kernel locals.types macros.expander fry ;
 IN: locals.macros
 
 M: lambda expand-macros clone [ expand-macros ] change-body ;
@@ -14,3 +14,6 @@ M: binding-form expand-macros
 
 M: binding-form expand-macros* expand-macros literal ;
 
+M: lambda condomize? drop t ;
+
+M: lambda condomize '[ @ ] ;

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/logging/logging.factor

@@ -135,11 +135,11 @@ PRIVATE>
     [ [ input-logging-quot ] 2keep drop error-logging-quot ]
     (define-logging) ;
 
-: LOG:
+SYNTAX: LOG:
     #! Syntax: name level
     CREATE-WORD dup scan-word
     '[ 1array stack>message _ _ log-message ]
-    (( message -- )) define-declared ; parsing
+    (( message -- )) define-declared ;
 
 USE: vocabs.loader
 

basis/macros/expander/expander.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private namespaces make
 quotations accessors words continuations vectors effects math
-generalizations fry ;
+generalizations fry arrays ;
 IN: macros.expander
 
 GENERIC: expand-macros ( quot -- quot' )
@@ -17,7 +17,23 @@ SYMBOL: stack
     [ delete-all ]
     bi ;
 
-: literal ( obj -- ) stack get push ;
+GENERIC: condomize? ( obj -- ? )
+
+M: array condomize? [ condomize? ] any? ;
+
+M: callable condomize? [ condomize? ] any? ;
+
+M: object condomize? drop f ;
+
+GENERIC: condomize ( obj -- obj' )
+
+M: array condomize [ condomize ] map ;
+
+M: callable condomize [ condomize ] map ;
+
+M: object condomize ;
+
+: literal ( obj -- ) dup condomize? [ condomize ] when stack get push ;
 
 GENERIC: expand-macros* ( obj -- )
 

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,17 +6,18 @@ 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 ;
 
-: MACRO: (:) define-macro ; parsing
+SYNTAX: MACRO: (:) define-macro ;
 
 PREDICATE: macro < word "macro" word-prop >boolean ;
 

basis/match/match.factor

@@ -16,8 +16,8 @@ SYMBOL: _
 : define-match-vars ( seq -- )
     [ define-match-var ] each ;
 
-: MATCH-VARS: ! vars ...
+SYNTAX: MATCH-VARS: ! vars ...
-    ";" parse-tokens define-match-vars ; parsing
+    ";" parse-tokens define-match-vars ;
 
 : match-var? ( symbol -- bool )
     dup word? [ "match-var" word-prop ] [ drop f ] if ;

basis/math/bitwise/bitwise-docs.factor

@@ -139,8 +139,8 @@ HELP: flags
 { $examples
     { $example "USING: math.bitwise kernel prettyprint ;"
         "IN: scratchpad"
-        ": MY-CONSTANT HEX: 1 ; inline"
+        "CONSTANT: x HEX: 1"
-        "{ HEX: 20 MY-CONSTANT BIN: 100 } flags .h"
+        "{ HEX: 20 x BIN: 100 } flags .h"
         "25"
     }
 } ;

basis/math/blas/matrices/matrices.factor

@@ -289,7 +289,7 @@ M: MATRIX n*V(*)V+M!
 M: MATRIX n*V(*)Vconj+M!
     (prepare-ger) [ XGERC ] dip ;
 
-: XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing
+SYNTAX: XMATRIX{ \ } [ >MATRIX ] parse-literal ;
 
 M: MATRIX pprint-delims
     drop \ XMATRIX{ \ } ;

basis/math/blas/vectors/vectors.factor

@@ -179,7 +179,7 @@ M: VECTOR n*V+V!
 M: VECTOR n*V!
     (prepare-scal) [ XSCAL ] dip ;
 
-: XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing
+SYNTAX: XVECTOR{ \ } [ >VECTOR ] parse-literal ;
 
 M: VECTOR pprint-delims
     drop \ XVECTOR{ \ } ;

basis/math/complex/complex.factor

@@ -31,7 +31,7 @@ M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ;
 
 IN: syntax
 
-: C{ \ } [ first2 rect> ] parse-literal ; parsing
+SYNTAX: C{ \ } [ first2 rect> ] parse-literal ;
 
 USE: prettyprint.custom
 

basis/memoize/memoize-docs.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup words quotations effects ;
 IN: memoize
 
 HELP: define-memoized
-{ $values { "word" "the word to be defined" } { "quot" "a quotation" } }
+{ $values { "word" word } { "quot" quotation } { "effect" effect } }
 { $description "defines the given word at runtime as one which memoizes its output given a particular input" }
 { $notes "A maximum of four input and four output arguments can be used" }
 { $see-also POSTPONE: MEMO: } ;

basis/memoize/memoize.factor

@@ -34,14 +34,13 @@ 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 ;
 
-: MEMO: (:) define-memoized ; parsing
+SYNTAX: MEMO: (:) define-memoized ;
 
 PREDICATE: memoized < word "memoize" word-prop ;
 

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/multiline/multiline.factor

@@ -20,10 +20,10 @@ PRIVATE>
     [ (parse-here) ] "" make but-last
     lexer get next-line ;
 
-: STRING:
+SYNTAX: STRING:
     CREATE-WORD
     parse-here 1quotation
-    (( -- string )) define-inline ; parsing
+    (( -- string )) define-inline ;
 
 <PRIVATE
 
@@ -48,16 +48,16 @@ PRIVATE>
         change-column drop
     ] "" make ;
 
-: <"
+SYNTAX: <"
-    "\">" parse-multiline-string parsed ; parsing
+    "\">" parse-multiline-string parsed ;
 
-: <'
+SYNTAX: <'
-    "'>" parse-multiline-string parsed ; parsing
+    "'>" parse-multiline-string parsed ;
 
-: {'
+SYNTAX: {'
-    "'}" parse-multiline-string parsed ; parsing
+    "'}" parse-multiline-string parsed ;
 
-: {"
+SYNTAX: {"
-    "\"}" parse-multiline-string parsed ; parsing
+    "\"}" parse-multiline-string parsed ;
 
-: /* "*/" parse-multiline-string drop ; parsing
+SYNTAX: /* "*/" parse-multiline-string drop ;

basis/nibble-arrays/nibble-arrays.factor

@@ -62,7 +62,7 @@ M: nibble-array resize
 
 M: nibble-array byte-length length nibbles>bytes ;
 
-: N{ \ } [ >nibble-array ] parse-literal ; parsing
+SYNTAX: N{ \ } [ >nibble-array ] parse-literal ;
 
 INSTANCE: nibble-array sequence
 

basis/opengl/gl/extensions/extensions.factor

@@ -47,7 +47,7 @@ reset-gl-function-number-counter
     parameters return parse-arglist [ abi indirect-quot ] dip
     define-declared ;
 
-: GL-FUNCTION:
+SYNTAX: GL-FUNCTION:
     gl-function-calling-convention
     scan
     scan dup
@@ -55,5 +55,4 @@ reset-gl-function-number-counter
     gl-function-number
     [ gl-function-pointer ] 2curry swap
     ";" parse-tokens [ "()" subseq? not ] filter
-    define-indirect
+    define-indirect ;
-    ; parsing

basis/openssl/libssl/libssl.factor

@@ -279,12 +279,12 @@ H{ } clone verify-messages set-global
 
 : verify-message ( n -- word ) verify-messages get-global at ;
 
-: X509_V_:
+SYNTAX: X509_V_:
     scan "X509_V_" prepend create-in
     scan-word
     [ 1quotation (( -- value )) define-inline ]
     [ verify-messages get set-at ]
-    2bi ; parsing
+    2bi ;
 
 >>
 

basis/peg/ebnf/ebnf.factor

@@ -34,9 +34,9 @@ TUPLE: tokenizer any one many ;
 : reset-tokenizer ( -- )
   default-tokenizer \ tokenizer set-global ;
 
-: TOKENIZER: 
+SYNTAX: TOKENIZER: 
   scan search [ "Tokenizer not found" throw ] unless*
-  execute( -- tokenizer ) \ tokenizer set-global ; parsing
+  execute( -- tokenizer ) \ tokenizer set-global ;
 
 TUPLE: ebnf-non-terminal symbol ;
 TUPLE: ebnf-terminal symbol ;
@@ -522,16 +522,14 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
   parse-ebnf dup dup parser [ main swap at compile ] with-variable
   [ compiled-parse ] curry [ with-scope ast>> ] curry ;
 
-: <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at  
+SYNTAX: <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at  
-  parsed reset-tokenizer ; parsing
+  parsed reset-tokenizer ;
 
-: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip 
+SYNTAX: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip 
-  parsed \ call parsed reset-tokenizer ; parsing
+  parsed \ call parsed reset-tokenizer ;
 
-: EBNF: 
+SYNTAX: EBNF: 
   reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string  
   ebnf>quot swapd (( input -- ast )) define-declared "ebnf-parser" set-word-prop 
-  reset-tokenizer ; parsing
+  reset-tokenizer ;
-
-
 

basis/peg/parsers/parsers.factor

@@ -9,14 +9,14 @@ TUPLE: just-parser p1 ;
 
 CONSTANT: just-pattern
   [
-    execute dup [
+    dup [
       dup remaining>> empty? [ drop f ] unless
     ] when
   ]
 
 
 M: just-parser (compile) ( parser -- quot )
-  p1>> compile-parser just-pattern curry ;
+  p1>> compile-parser-quot just-pattern compose ;
 
 : just ( parser -- parser )
   just-parser boa wrap-peg ;

basis/peg/peg.factor

@@ -116,7 +116,7 @@ TUPLE: peg-head rule-id involved-set eval-set ;
   #! Evaluate a rule, return an ast resulting from it.
   #! Return fail if the rule failed. The rule has
   #! stack effect ( -- parse-result )
-  pos get swap execute process-rule-result ; inline
+  pos get swap execute( -- parse-result ) process-rule-result ; inline
 
 : memo ( pos id -- memo-entry )
   #! Return the result from the memo cache. 
@@ -244,14 +244,15 @@ TUPLE: peg-head rule-id involved-set eval-set ;
 
 : with-packrat ( input quot -- result )
   #! Run the quotation with a packrat cache active.
-  swap [ 
+  [ 
-    input set
+    swap input set
     0 pos set
     f lrstack set
     V{ } clone error-stack set
     H{ } clone \ heads set
     H{ } clone \ packrat set
-  ] H{ } make-assoc swap bind ; inline
+    call
+  ] with-scope ; inline
 
 
 GENERIC: (compile) ( peg -- quot )
@@ -264,20 +265,16 @@ GENERIC: (compile) ( peg -- quot )
   ] if ;
     
 : execute-parser ( word -- result )
-  pos get apply-rule process-parser-result ; inline
+  pos get apply-rule process-parser-result ;
-
-: parser-body ( parser -- quot )
-  #! Return the body of the word that is the compiled version
-  #! of the parser.
-  gensym 2dup swap peg>> (compile) (( -- result )) define-declared
-  swap dupd id>> "peg-id" set-word-prop
-  [ execute-parser ] curry ;
 
 : preset-parser-word ( parser -- parser word )
   gensym [ >>compiled ] keep ;
 
 : define-parser-word ( parser word -- )
-  swap parser-body (( -- result )) define-declared ;
+  #! Return the body of the word that is the compiled version
+  #! of the parser.
+  2dup swap peg>> (compile) (( -- result )) define-declared
+  swap id>> "peg-id" set-word-prop ;
 
 : compile-parser ( parser -- word )
   #! Look to see if the given parser has been compiled.
@@ -292,19 +289,22 @@ GENERIC: (compile) ( peg -- quot )
     preset-parser-word [ define-parser-word ] keep
   ] if* ;
 
+: compile-parser-quot ( parser -- quot )
+  compile-parser [ execute-parser ] curry ;
+
 SYMBOL: delayed
 
 : fixup-delayed ( -- )
   #! Work through all delayed parsers and recompile their
   #! words to have the correct bodies.
   delayed get [
-    call( -- parser ) compile-parser 1quotation (( -- result )) define-declared
+    call( -- parser ) compile-parser-quot (( -- result )) define-declared
   ] assoc-each ;
 
 : compile ( parser -- word )
   [
     H{ } clone delayed [ 
-      compile-parser fixup-delayed 
+      compile-parser-quot (( -- result )) define-temp fixup-delayed 
     ] with-variable
   ] with-compilation-unit ;
 
@@ -411,8 +411,8 @@ M: seq-parser (compile) ( peg -- quot )
   [
     [ input-slice V{ } clone <parse-result> ] %
     [
-      parsers>> unclip compile-parser 1quotation [ parse-seq-element ] curry ,
+      parsers>> unclip compile-parser-quot [ parse-seq-element ] curry ,
-      [ compile-parser 1quotation [ merge-errors ] compose [ parse-seq-element ] curry , ] each 
+      [ compile-parser-quot [ merge-errors ] compose [ parse-seq-element ] curry , ] each 
     ] { } make , \ 1&& , 
   ] [ ] make ;
 
@@ -421,8 +421,8 @@ TUPLE: choice-parser parsers ;
 M: choice-parser (compile) ( peg -- quot )
   [ 
     [
-      parsers>> [ compile-parser ] map 
+      parsers>> [ compile-parser-quot ] map 
-      unclip 1quotation , [ 1quotation [ merge-errors ] compose , ] each
+      unclip , [ [ merge-errors ] compose , ] each
     ] { } make , \ 0|| ,
   ] [ ] make ;
 
@@ -438,7 +438,7 @@ TUPLE: repeat0-parser p1 ;
   ] if* ; inline recursive
 
 M: repeat0-parser (compile) ( peg -- quot )
-  p1>> compile-parser 1quotation '[ 
+  p1>> compile-parser-quot '[ 
     input-slice V{ } clone <parse-result> _ swap (repeat) 
   ] ; 
 
@@ -452,7 +452,7 @@ TUPLE: repeat1-parser p1 ;
   ] if* ;
 
 M: repeat1-parser (compile) ( peg -- quot )
-  p1>> compile-parser 1quotation '[ 
+  p1>> compile-parser-quot '[ 
     input-slice V{ } clone <parse-result> _ swap (repeat) repeat1-empty-check  
   ] ; 
 
@@ -462,7 +462,7 @@ TUPLE: optional-parser p1 ;
   [ input-slice f <parse-result> ] unless* ;
 
 M: optional-parser (compile) ( peg -- quot )
-  p1>> compile-parser 1quotation '[ @ check-optional ] ;
+  p1>> compile-parser-quot '[ @ check-optional ] ;
 
 TUPLE: semantic-parser p1 quot ;
 
@@ -474,7 +474,7 @@ TUPLE: semantic-parser p1 quot ;
   ] if ; inline
 
 M: semantic-parser (compile) ( peg -- quot )
-  [ p1>> compile-parser 1quotation ] [ quot>> ] bi  
+  [ p1>> compile-parser-quot ] [ quot>> ] bi  
   '[ @ _ check-semantic ] ;
 
 TUPLE: ensure-parser p1 ;
@@ -483,7 +483,7 @@ TUPLE: ensure-parser p1 ;
   [ ignore <parse-result> ] [ drop f ] if ;
 
 M: ensure-parser (compile) ( peg -- quot )
-  p1>> compile-parser 1quotation '[ input-slice @ check-ensure ] ;
+  p1>> compile-parser-quot '[ input-slice @ check-ensure ] ;
 
 TUPLE: ensure-not-parser p1 ;
 
@@ -491,7 +491,7 @@ TUPLE: ensure-not-parser p1 ;
   [ drop f ] [ ignore <parse-result> ] if ;
 
 M: ensure-not-parser (compile) ( peg -- quot )
-  p1>> compile-parser 1quotation '[ input-slice @ check-ensure-not ] ;
+  p1>> compile-parser-quot '[ input-slice @ check-ensure-not ] ;
 
 TUPLE: action-parser p1 quot ;
 
@@ -503,12 +503,12 @@ TUPLE: action-parser p1 quot ;
   ] if ; inline
 
 M: action-parser (compile) ( peg -- quot )
-  [ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ _ check-action ] ;
+  [ p1>> compile-parser-quot ] [ quot>> ] bi '[ @ _ check-action ] ;
 
 TUPLE: sp-parser p1 ;
 
 M: sp-parser (compile) ( peg -- quot )
-  p1>> compile-parser 1quotation '[ 
+  p1>> compile-parser-quot '[ 
     input-slice [ blank? ] trim-head-slice input-from pos set @ 
   ] ;
 
@@ -527,7 +527,7 @@ M: box-parser (compile) ( peg -- quot )
   #! to produce the parser to be compiled.
   #! This differs from 'delay' which calls
   #! it at run time.
-  quot>> call( -- parser ) compile-parser 1quotation ;
+  quot>> call( -- parser ) compile-parser-quot ;
 
 PRIVATE>
 
@@ -616,9 +616,9 @@ PRIVATE>
 
 ERROR: parse-failed input word ;
 
-: PEG:
+SYNTAX: PEG:
   (:)
-  [let | def [ ] word [ ] |
+  [let | effect [ ] def [ ] word [ ] |
     [
       [
         [let | compiled-def [ def call compile ] |
@@ -626,11 +626,11 @@ ERROR: parse-failed input word ;
             dup compiled-def compiled-parse
             [ ast>> ] [ word parse-failed ] ?if
           ]
-          word swap define
+          word swap effect define-declared
         ]
       ] with-compilation-unit
     ] over push-all
-  ] ; parsing
+  ] ;
 
 USING: vocabs vocabs.loader ;
 

basis/persistent/hashtables/hashtables.factor

@@ -48,7 +48,7 @@ M: persistent-hash hashcode* nip assoc-size ;
 
 M: persistent-hash clone ;
 
-: PH{ \ } [ >persistent-hash ] parse-literal ; parsing
+SYNTAX: PH{ \ } [ >persistent-hash ] parse-literal ;
 
 M: persistent-hash pprint-delims drop \ PH{ \ } ;
 M: persistent-hash >pprint-sequence >alist ;