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

basis/compiler/generator/iterator/iterator.factor

@@ -37,9 +37,9 @@ DEFER: (tail-call?)
 : tail-call? ( -- ? )
     node-stack get [
         rest-slice
-        dup [
+        dup empty? [ drop t ] [
             [ (tail-call?) ]
             [ first #terminate? not ]
             bi and
-        ] [ drop t ] if
+        ] if
     ] all? ;

basis/compiler/tests/intrinsics.factor

@@ -450,3 +450,14 @@ cell 8 = [
 [ 8 ] [
     1 [ 3 fixnum-shift-fast ] compile-call
 ] unit-test
+
+TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
+
+[ B{ 0 1 } ] [
+    B{ 0 0 } 1 alien-accessor-regression boa
+    dup [
+        { alien-accessor-regression } declare
+        [ i>> ] [ b>> ] bi over set-alien-unsigned-1
+    ] compile-call
+    b>>
+] unit-test

basis/compiler/tests/optimizer.factor

@@ -3,7 +3,7 @@ stack-checker kernel kernel.private math prettyprint sequences
 sbufs strings tools.test vectors words sequences.private
 quotations classes classes.algebra classes.tuple.private
 continuations growable namespaces hints alien.accessors
-compiler.tree.builder compiler.tree.optimizer ;
+compiler.tree.builder compiler.tree.optimizer sequences.deep ;
 IN: optimizer.tests
 
 GENERIC: xyz ( obj -- obj )
@@ -353,3 +353,12 @@ TUPLE: some-tuple x ;
 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
 [ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
+
+: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
+
+[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
+[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
+
+[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
+
+[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test

basis/compiler/tests/redefine4.factor

@@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
 
 [ "" ] [ [ declaration-test ] with-string-writer ] unit-test
 
-[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" print f ;" eval ] unit-test
+[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test
 
 [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

basis/compiler/tree/cleanup/cleanup.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sequences.deep combinators fry
-classes.algebra namespaces assocs math math.private
+classes.algebra namespaces assocs words math math.private
-math.partial-dispatch classes.tuple classes.tuple.private
+math.partial-dispatch math.intervals classes classes.tuple
-definitions stack-checker.state stack-checker.branches
+classes.tuple.private layouts definitions stack-checker.state
-compiler.tree
+stack-checker.branches compiler.tree
 compiler.tree.intrinsics
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -64,9 +64,19 @@ GENERIC: cleanup* ( node -- node/nodes )
         { fixnum-shift fixnum-shift-fast }
     } at ;
 
+: (remove-overflow-check?) ( #call -- ? )
+    node-output-infos first class>> fixnum class<= ;
+
+: small-shift? ( #call -- ? )
+    node-input-infos second interval>>
+    cell-bits tag-bits get - [ neg ] keep [a,b] interval-subset? ;
+
 : remove-overflow-check? ( #call -- ? )
-    dup word>> no-overflow-variant
+    {
-    [ node-output-infos first class>> fixnum class<= ] [ drop f ] if ;
+        { [ dup word>> \ fixnum-shift eq? ] [ [ (remove-overflow-check?) ] [ small-shift? ] bi and ] }
+        { [ dup word>> no-overflow-variant ] [ (remove-overflow-check?) ] }
+        [ drop f ]
+    } cond ;
 
 : remove-overflow-check ( #call -- #call )
     [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
@@ -92,8 +102,11 @@ M: #declare cleanup* drop f ;
 : fold-only-branch ( #branch -- node/nodes )
     #! If only one branch is live we don't need to branch at
     #! all; just drop the condition value.
-    dup live-children sift dup length 1 =
+    dup live-children sift dup length {
-    [ first swap in-d>> #drop prefix ] [ drop ] if ;
+        { 0 [ 2drop f ] }
+        { 1 [ first swap in-d>> #drop prefix ] }
+        [ 2drop ]
+    } case ;
 
 SYMBOL: live-branches
 
@@ -108,15 +121,18 @@ M: #branch cleanup*
         [ live-branches>> live-branches set ]
     } cleave ;
 
+: output-fs ( values -- nodes )
+    [ f swap #push ] map ;
+
 : eliminate-single-phi ( #phi -- node )
     [ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
-    [ [ drop ] [ [ f swap #push ] map ] bi* ]
+    [ [ drop ] [ output-fs ] bi* ]
     [ #copy ]
     if ;
 
 : eliminate-phi ( #phi -- node )
     live-branches get sift length {
-        { 0 [ drop f ] }
+        { 0 [ out-d>> output-fs ] }
         { 1 [ eliminate-single-phi ] }
         [ drop ]
     } case ;

basis/compiler/tree/dead-code/dead-code-tests.factor

@@ -120,7 +120,7 @@ IN: compiler.tree.dead-code.tests
 : call-recursive-dce-1 ( a -- b )
     [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
 
-[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [
+[ [ drop "WRAP" [ "REC" drop "REC" ] label ] ] [
     [ call-recursive-dce-1 ] optimize-quot squish
 ] unit-test
 
@@ -134,7 +134,7 @@ IN: compiler.tree.dead-code.tests
     [ f call-recursive-dce-2 drop ] optimize-quot squish
 ] unit-test
 
-[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [
+[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
     [ f call-recursive-dce-2 ] optimize-quot squish
 ] unit-test
 
@@ -152,7 +152,7 @@ IN: compiler.tree.dead-code.tests
 : call-recursive-dce-4 ( a -- b )
     call-recursive-dce-4 ; inline recursive
 
-[ [ "WRAP" [ "REC" ] label ] ] [
+[ [ drop "WRAP" [ "REC" ] label ] ] [
     [ call-recursive-dce-4 ] optimize-quot squish
 ] unit-test
 
@@ -182,3 +182,8 @@ IN: compiler.tree.dead-code.tests
 [ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
 
 [ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test
+
+: call-recursive-dce-7 ( obj -- elt ? )
+    dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive
+
+[ ] [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test

basis/compiler/tree/dead-code/recursive/recursive.factor

@@ -13,11 +13,8 @@ M: #enter-recursive compute-live-values*
     #! corresponding inputs to the #call-recursive are live also.
     [ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
 
-: return-recursive-phi-in ( #return-recursive -- phi-in )
-    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
-
 M: #return-recursive compute-live-values*
-    [ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ;
+    [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
 
 M: #call-recursive compute-live-values*
     #! If the output of a #call-recursive is live, then the
@@ -34,15 +31,6 @@ M: #call-recursive compute-live-values*
         drop-values
     ] ;
 
-M: #recursive remove-dead-code* ( node -- nodes )
-    dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
-    {
-        [ [ dup label>> enter-recursive>> ] [ out-d>> ] bi* '[ , >>in-d drop ] bi@ ]
-        [ drop [ (remove-dead-code) ] change-child drop ]
-        [ drop label>> [ filter-live ] change-enter-out drop ]
-        [ swap 2array ]
-    } 2cleave ;
-
 M: #enter-recursive remove-dead-code*
     [ filter-live ] change-out-d ;
 
@@ -73,9 +61,30 @@ M: #call-recursive remove-dead-code*
     [ drop-call-recursive-outputs ]
     tri 3array ;
 
-M: #return-recursive remove-dead-code* ( node -- nodes )
+:: drop-recursive-inputs ( node -- shuffle )
-    dup [ in-d>> ] [ out-d>> ] bi drop-dead-inputs
+    [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
-    [ drop [ filter-live ] change-out-d drop ]
+            new-outputs [ shuffle out-d>> ] |
-    [ out-d>> >>in-d drop ]
+        node new-outputs
-    [ swap 2array ]
+        [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
-    2tri ;
+        shuffle
+    ] ;
+
+:: drop-recursive-outputs ( node -- shuffle )
+    [let* | return [ node label>> return>> ]
+            new-inputs [ return in-d>> filter-live ]
+            new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
+        return
+        [ new-inputs >>in-d new-outputs >>out-d drop ]
+        [ drop-dead-outputs ]
+        bi
+    ] ;
+
+M:: #recursive remove-dead-code* ( node -- nodes )
+    [let* | drop-inputs [ node drop-recursive-inputs ]
+            drop-outputs [ node drop-recursive-outputs ] |
+         node [ (remove-dead-code) ] change-child drop
+         node label>> [ filter-live ] change-enter-out drop
+         drop-inputs node drop-outputs 3array
+    ] ;
+
+M: #return-recursive remove-dead-code* ;

basis/compiler/tree/dead-code/simple/simple.factor

@@ -1,7 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors words assocs sequences arrays namespaces
-fry locals classes.algebra stack-checker.backend
+fry locals definitions classes.algebra
+stack-checker.state
+stack-checker.backend
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.dead-code.liveness ;
@@ -80,11 +82,10 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
     ] ;
 
 : drop-dead-outputs ( node -- nodes )
-    dup out-d>> drop-dead-values
+    dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
-    [ in-d>> >>out-d drop ] [ 2array ] 2bi ;
 
 M: #introduce remove-dead-code* ( #introduce -- nodes )
-    drop-dead-outputs ;
+    dup drop-dead-outputs 2array ;
 
 M: #>r remove-dead-code*
     [ filter-live ] change-out-r
@@ -105,7 +106,9 @@ M: #push remove-dead-code*
     ] [ drop f ] if ;
 
 : remove-flushable-call ( #call -- node )
-    in-d>> #drop remove-dead-code* ;
+    [ word>> +inlined+ depends-on ]
+    [ in-d>> #drop remove-dead-code* ]
+    bi ;
 
 : some-outputs-dead? ( #call -- ? )
     out-d>> [ live-value? not ] contains? ;
@@ -115,7 +118,7 @@ M: #call remove-dead-code*
         remove-flushable-call
     ] [
         dup some-outputs-dead? [
-            drop-dead-outputs
+            dup drop-dead-outputs 2array
         ] when
     ] if ;
 

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -7,7 +7,7 @@ compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
 prettyprint classes.tuple.private classes classes.tuple
 compiler.tree.intrinsics namespaces compiler.tree.propagation.info
-stack-checker.errors ;
+stack-checker.errors kernel.private ;
 
 \ escape-analysis must-infer
 
@@ -316,3 +316,7 @@ C: <ro-box> ro-box
     [ \ too-many->r boa f f \ inference-error boa ]
     count-unboxed-allocations
 ] unit-test
+
+[ 0 ] [
+    [ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
+] unit-test

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -125,21 +125,20 @@ SYMBOL: history
 : remember-inlining ( word -- )
     history [ swap suffix ] change ;
 
-: inline-word ( #call word -- )
+: inline-word ( #call word -- ? )
     dup history get memq? [
-        2drop
+        2drop f
     ] [
         [
             dup remember-inlining
             dupd def>> splicing-nodes >>body
             propagate-body
         ] with-scope
+        t
     ] if ;
 
 : inline-method-body ( #call word -- ? )
-    2dup should-inline? [ inline-word t ] [ 2drop f ] if ;
+    2dup should-inline? [ inline-word ] [ 2drop f ] if ;
 
 : always-inline-word? ( word -- ? )
     { curry compose } memq? ;
-
-: always-inline-word ( #call word -- ? ) inline-word t ;

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

@@ -571,6 +571,8 @@ MIXIN: empty-mixin
 
 [ ] [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test
 
+[ V{ fixnum } ] [ [ [ bignum-shift drop ] keep ] final-classes ] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

basis/compiler/tree/propagation/simple/simple.factor

@@ -93,7 +93,7 @@ M: #declare propagate-before
 
 : do-inlining ( #call word -- ? )
     {
-        { [ dup always-inline-word? ] [ always-inline-word ] }
+        { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }
         { [ dup math-partial? ] [ inline-math-partial ] }

basis/cpu/x86/64/64.factor

@@ -3,7 +3,7 @@
 USING: accessors alien.c-types arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
 cpu.x86.allot cpu.architecture kernel kernel.private math
-namespaces sequences compiler.generator.registers
+namespaces sequences compiler.generator compiler.generator.registers
 compiler.generator.fixup system layouts alien alien.accessors
 alien.structs slots splitting assocs ;
 IN: cpu.x86.64

basis/cpu/x86/intrinsics/intrinsics.factor

@@ -404,10 +404,8 @@ IN: cpu.x86.intrinsics
 
 : %alien-integer-set ( quot reg -- )
     small-reg PUSH
-    "offset" get "value" get = [
-        "value" operand %untag-fixnum
-    ] unless
     small-reg "value" operand MOV
+    small-reg %untag-fixnum
     swap %alien-accessor
     small-reg POP ; inline
 

basis/io/servers/connection/connection.factor

@@ -87,7 +87,7 @@ M: threaded-server handle-client* handler>> call ;
         [ [ accept-connection ] with-semaphore ]
         [ accept-connection ]
         if*
-    ] [ accept-loop ] bi ; inline
+    ] [ accept-loop ] bi ; inline recursive
 
 : started-accept-loop ( server -- )
     threaded-server get

basis/stack-checker/inlining/inlining.factor

@@ -67,8 +67,10 @@ SYMBOL: enter-out
     [ entry-stack-height current-stack-height swap - ]
     bi*
     = [ 2drop ] [
-        word>> current-stack-height
+        terminated? get [ 2drop ] [
-        unbalanced-recursion-error inference-error
+            word>> current-stack-height
+            unbalanced-recursion-error inference-error
+        ] if
     ] if ;
 
 : end-recursive-word ( word label -- )
@@ -79,7 +81,7 @@ SYMBOL: enter-out
 : recursive-word-inputs ( label -- n )
     entry-stack-height d-in get + ;
 
-: (inline-recursive-word) ( word -- label in out visitor )
+: (inline-recursive-word) ( word -- label in out visitor terminated? )
     dup prepare-stack
     [
         init-inference
@@ -96,11 +98,13 @@ SYMBOL: enter-out
         dup recursive-word-inputs
         meta-d get
         stack-visitor get
+        terminated? get
     ] with-scope ;
 
 : inline-recursive-word ( word -- )
     (inline-recursive-word)
-    [ consume-d ] [ output-d ] [ ] tri* #recursive, ;
+    [ [ consume-d ] [ output-d ] [ ] tri* #recursive, ] dip
+    [ terminate ] when ;
 
 : check-call-height ( label -- )
     dup entry-stack-height current-stack-height >

basis/stack-checker/known-words/known-words.factor

@@ -331,7 +331,7 @@ SYMBOL: +primitive+
 \ bignum-bitnot { bignum } { bignum } define-primitive
 \ bignum-bitnot make-foldable
 
-\ bignum-shift { bignum bignum } { bignum } define-primitive
+\ bignum-shift { bignum fixnum } { bignum } define-primitive
 \ bignum-shift make-foldable
 
 \ bignum< { bignum bignum } { object } define-primitive

basis/stack-checker/stack-checker-tests.factor

@@ -575,3 +575,8 @@ DEFER: eee'
 : eee' ( ? -- ) >r swap [ ] r> ddd' call ; inline recursive
 
 [ [ eee' ] infer ] [ inference-error? ] must-fail-with
+
+: bogus-error ( x -- )
+    dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
+
+[ bogus-error ] must-infer

basis/state-parser/state-parser.factor

@@ -88,13 +88,12 @@ SYMBOL: prolog-data
 : next* ( -- )
     get-char [ (next) record ] when ;
 
-: skip-until ( quot -- )
+: skip-until ( quot: ( -- ? ) -- )
-    #! quot: ( -- ? )
     get-char [
         [ call ] keep swap [ drop ] [
             next skip-until
         ] if
-    ] [ drop ] if ; inline
+    ] [ drop ] if ; inline recursive
 
 : take-until ( quot -- string )
     #! Take the substring of a string starting at spot

basis/xml-rpc/xml-rpc.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel xml arrays math generic http.client combinators
+USING: accessors kernel xml arrays math generic http.client
-    hashtables namespaces io base64 sequences strings calendar
+combinators hashtables namespaces io base64 sequences strings
-    xml.data xml.writer xml.utilities assocs math.parser debugger
+calendar xml.data xml.writer xml.utilities assocs math.parser
-    calendar.format math.order ;
+debugger calendar.format math.order ;
 IN: xml-rpc
 
 ! * Sending RPC requests
@@ -17,7 +17,7 @@ M: integer item>xml
     [ "Integers must fit in 32 bits" throw ] unless
     number>string "i4" build-tag ;
 
-PREDICATE: boolean < object { t f } member? ;
+UNION: boolean t POSTPONE: f ;
 
 M: boolean item>xml
     "1" "0" ? "boolean" build-tag ;
@@ -147,10 +147,10 @@ TAG: array xml>item
     xml>item [ "faultCode" get "faultString" get ] bind ;
 
 : receive-rpc ( xml -- rpc )
-    dup name-tag dup "methodCall" =
+    dup main>> dup "methodCall" =
     [ drop parse-method <rpc-method> ] [
         "methodResponse" = [
-            dup first-child-tag name-tag "fault" =
+            dup first-child-tag main>> "fault" =
             [ parse-fault <rpc-fault> ]
             [ parse-rpc-response <rpc-response> ] if
         ] [ "Bad main tag name" server-error ] if

basis/xml/data/data.factor

@@ -1,25 +1,26 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private assocs arrays
-delegate.protocols delegate vectors ;
+delegate.protocols delegate vectors accessors multiline
+macros words quotations combinators ;
 IN: xml.data
 
-TUPLE: name space tag url ;
+TUPLE: name space main url ;
 C: <name> name
 
 : ?= ( object/f object/f -- ? )
     2dup and [ = ] [ 2drop t ] if ;
 
 : names-match? ( name1 name2 -- ? )
-    [ name-space swap name-space ?= ] 2keep
+    [ [ space>> ] bi@ ?= ]
-    [ name-url swap name-url ?= ] 2keep
+    [ [ url>> ] bi@ ?= ]
-    name-tag swap name-tag ?= and and ;
+    [ [ main>> ] bi@ ?= ] 2tri and and ;
 
-: <name-tag> ( string -- name )
+: <simple-name> ( string -- name )
     f swap f <name> ;
 
 : assure-name ( string/name -- name )
-    dup name? [ <name-tag> ] unless ;
+    dup name? [ <simple-name> ] unless ;
 
 TUPLE: opener name attrs ;
 C: <opener> opener
@@ -42,13 +43,11 @@ C: <instruction> instruction
 TUPLE: prolog version encoding standalone ;
 C: <prolog> prolog
 
-TUPLE: tag attrs children ;
-
 TUPLE: attrs alist ;
 C: <attrs> attrs
 
 : attr@ ( key alist -- index {key,value} )
-    >r assure-name r> attrs-alist
+    >r assure-name r> alist>>
     [ first names-match? ] with find ;
 
 M: attrs at*
@@ -58,12 +57,12 @@ M: attrs set-at
         2nip set-second
     ] [
         >r assure-name swap 2array r>
-        [ attrs-alist ?push ] keep set-attrs-alist
+        [ alist>> ?push ] keep (>>alist)
     ] if* ;
 
-M: attrs assoc-size attrs-alist length ;
+M: attrs assoc-size alist>> length ;
 M: attrs new-assoc drop V{ } new-sequence <attrs> ;
-M: attrs >alist attrs-alist ;
+M: attrs >alist alist>> ;
 
 : >attrs ( assoc -- attrs )
     dup [
@@ -74,61 +73,71 @@ M: attrs assoc-like
     drop dup attrs? [ >attrs ] unless ;
 
 M: attrs clear-assoc
-    f swap set-attrs-alist ;
+    f >>alist drop ;
 M: attrs delete-at
-    tuck attr@ drop [ swap attrs-alist delete-nth ] [ drop ] if* ;
+    tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
 
 M: attrs clone
-    attrs-alist clone <attrs> ;
+    alist>> clone <attrs> ;
 
 INSTANCE: attrs assoc
 
+TUPLE: tag name attrs children ;
+
 : <tag> ( name attrs children -- tag )
-    >r >r assure-name r> T{ attrs } assoc-like r>
+    [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
-    { set-delegate set-tag-attrs set-tag-children }
+    tag boa ;
-    tag construct ;
 
 ! For convenience, tags follow the assoc protocol too (for attrs)
 CONSULT: assoc-protocol tag tag-attrs ;
 INSTANCE: tag assoc
 
 ! They also follow the sequence protocol (for children)
-CONSULT: sequence-protocol tag tag-children ;
+CONSULT: sequence-protocol tag children>> ;
 INSTANCE: tag sequence
 
+CONSULT: name tag name>> ;
+
 M: tag like
     over tag? [ drop ] [
-        [ delegate ] keep tag-attrs
+        [ name>> ] keep tag-attrs
         rot dup [ V{ } like ] when <tag>
     ] if ;
 
+MACRO: clone-slots ( class -- tuple )
+    [
+        "slots" word-prop
+        [ reader>> 1quotation [ clone ] compose ] map
+        [ cleave ] curry
+    ] [ [ boa ] curry ] bi compose ;
+
 M: tag clone
-    [ delegate clone ] keep [ tag-attrs clone ] keep
+    tag clone-slots ;
-    tag-children clone
-    { set-delegate set-tag-attrs set-tag-children } tag construct ;
 
-TUPLE: xml prolog before main after ;
+TUPLE: xml prolog before body after ;
-: <xml> ( prolog before main after -- xml )
+C: <xml> xml
-    { set-xml-prolog set-xml-before set-delegate set-xml-after }
-    xml construct ;
 
-CONSULT: sequence-protocol xml delegate ;
+CONSULT: sequence-protocol xml body>> ;
 INSTANCE: xml sequence
 
-CONSULT: assoc-protocol xml delegate ;
+CONSULT: assoc-protocol xml body>> ;
 INSTANCE: xml assoc
 
+CONSULT: tag xml body>> ;
+
+CONSULT: name xml body>> ;
+
 <PRIVATE
 : tag>xml ( xml tag -- newxml )
-    swap [ dup xml-prolog swap xml-before rot ] keep xml-after <xml> ;
+    >r [ prolog>> ] [ before>> ] [ after>> ] tri r>
+    swap <xml> ;
 
 : seq>xml ( xml seq -- newxml )
-    over delegate like tag>xml ;
+    over body>> like tag>xml ;
 PRIVATE>
 
 M: xml clone
-    [ xml-prolog clone ] keep [ xml-before clone ] keep
+   xml clone-slots ;
-    [ delegate clone ] keep xml-after clone <xml> ;
 
 M: xml like
     swap dup xml? [ nip ] [
@@ -139,5 +148,5 @@ M: xml like
 : <contained-tag> ( name attrs -- tag )
     f <tag> ;
 
-PREDICATE: contained-tag < tag tag-children not ;
+PREDICATE: contained-tag < tag children>> not ;
-PREDICATE: open-tag < tag tag-children ;
+PREDICATE: open-tag < tag children>> ;

basis/xml/generator/generator.factor

@@ -27,7 +27,7 @@ IN: xml.generator
 
 ! Word-based XML literal syntax
 : parsed-name ( accum -- accum )
-    scan ":" split1 [ f <name> ] [ <name-tag> ] if* parsed ;
+    scan ":" split1 [ f <name> ] [ <simple-name> ] if* parsed ;
 
 : run-combinator ( accum quot1 quot2 -- accum )
     >r [ ] like parsed r> [ parsed ] each ;

basis/xml/tests/templating.factor

@@ -1,5 +1,5 @@
 USING: kernel xml sequences assocs tools.test io arrays namespaces
-    xml.data xml.utilities xml.writer generic sequences.deep ;
+accessors xml.data xml.utilities xml.writer generic sequences.deep ;
 IN: xml.tests
 
 : sub-tag
@@ -11,7 +11,7 @@ GENERIC: (r-ref) ( xml -- )
 M: tag (r-ref)
     sub-tag over at* [
         ref-table get at
-        swap set-tag-children
+        >>children drop
     ] [ 2drop ] if ;
 M: object (r-ref) drop ;
 
@@ -34,7 +34,7 @@ M: object (r-ref) drop ;
     [
         H{
             { "foo" { "foo" } }
-            { "bar" { "blah" T{ tag T{ name f "" "a" "" } V{ } f } } }
+            { "bar" { "blah" T{ tag f T{ name f "" "a" "" } f f } } }
             { "baz" f }
         } ref-table set
         sample-doc string>xml dup template xml>string

basis/xml/tests/test.factor

@@ -3,7 +3,7 @@
 IN: xml.tests
 USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
     parser strings xml.data io.files xml.writer xml.utilities state-parser 
-    continuations assocs sequences.deep ;
+    continuations assocs sequences.deep accessors ;
 
 ! This is insufficient
 \ read-xml must-infer
@@ -11,22 +11,22 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities
 SYMBOL: xml-file
 [ ] [ "resource:basis/xml/tests/test.xml"
     [ file>xml ] with-html-entities xml-file set ] unit-test
-[ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test
+[ "1.0" ] [ xml-file get prolog>> version>> ] unit-test
-[ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test
+[ f ] [ xml-file get prolog>> standalone>> ] unit-test
-[ "a" ] [ xml-file get name-space ] unit-test
+[ "a" ] [ xml-file get space>> ] unit-test
-[ "http://www.hello.com" ] [ xml-file get name-url ] unit-test
+[ "http://www.hello.com" ] [ xml-file get url>> ] unit-test
 [ "that" ] [
     xml-file get T{ name f "" "this" "http://d.de" } swap at
 ] unit-test
-[ t ] [ xml-file get tag-children second contained-tag? ] unit-test
+[ t ] [ xml-file get children>> second contained-tag? ] unit-test
 [ "<a></b>" string>xml ] [ xml-parse-error? ] must-fail-with
 [ T{ comment f "This is where the fun begins!" } ] [
     xml-file get xml-before [ comment? ] find nip
 ] unit-test
 [ "xsl stylesheet=\"that-one.xsl\"" ] [
-    xml-file get xml-after [ instruction? ] find nip instruction-text
+    xml-file get after>> [ instruction? ] find nip text>>
 ] unit-test
-[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test
+[ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test
 [ "that" ] [ xml-file get "this" swap at ] unit-test
 [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
     [ "<a b='c'/>" string>xml xml>string ] unit-test

basis/xml/tokenize/tokenize.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: xml.errors xml.data xml.utilities xml.char-classes sets
 xml.entities kernel state-parser kernel namespaces strings math
-math.parser sequences assocs arrays splitting combinators unicode.case ;
+math.parser sequences assocs arrays splitting combinators unicode.case
+accessors ;
 IN: xml.tokenize
 
 ! XML namespace processing: ns = namespace
@@ -14,8 +15,8 @@ SYMBOL: ns-stack
     ! this should check to make sure URIs are valid
     [
         [
-            swap dup name-space "xmlns" =
+            swap dup space>> "xmlns" =
-            [ name-tag set ]
+            [ main>> set ]
             [
                 T{ name f "" "xmlns" f } names-match?
                 [ "" set ] [ drop ] if
@@ -24,8 +25,8 @@ SYMBOL: ns-stack
     ] { } make-assoc f like ;
 
 : add-ns ( name -- )
-    dup name-space dup ns-stack get assoc-stack
+    dup space>> dup ns-stack get assoc-stack
-    [ nip ] [ <nonexist-ns> throw ] if* swap set-name-url ;
+    [ nip ] [ <nonexist-ns> throw ] if* >>url drop ;
 
 : push-ns ( hash -- )
     ns-stack get push ;

basis/xml/utilities/utilities.factor

@@ -10,13 +10,13 @@ IN: xml.utilities
 TUPLE: process-missing process tag ;
 M: process-missing error.
     "Tag <" write
-    dup process-missing-tag print-name
+    dup tag>> print-name
     "> not implemented on process process " write
-    process-missing-process name>> print ;
+    name>> print ;
 
 : run-process ( tag word -- )
     2dup "xtable" word-prop
-    >r dup name-tag r> at* [ 2nip call ] [
+    >r dup main>> r> at* [ 2nip call ] [
         drop \ process-missing boa throw
     ] if ;
 
@@ -48,17 +48,18 @@ M: process-missing error.
     standard-prolog { } rot { } <xml> ;
 
 : children>string ( tag -- string )
-    tag-children {
+    children>> {
         { [ dup empty? ] [ drop "" ] }
-        { [ dup [ string? not ] contains? ] [ "XML tag unexpectedly contains non-text children" throw ] }
+        { [ dup [ string? not ] contains? ]
+          [ "XML tag unexpectedly contains non-text children" throw ] }
         [ concat ]
     } cond ;
 
 : children-tags ( tag -- sequence )
-    tag-children [ tag? ] filter ;
+    children>> [ tag? ] filter ;
 
 : first-child-tag ( tag -- tag )
-    tag-children [ tag? ] find nip ;
+    children>> [ tag? ] find nip ;
 
 ! * Accessing part of an XML document
 ! for tag- words, a start means that it searches all children
@@ -91,7 +92,7 @@ M: process-missing error.
     assure-name [ tag-with-attr? ] 2curry find nip ;
 
 : tags-with-attr ( tag attr-value attr-name -- tags-seq )
-    tags@ [ tag-with-attr? ] 2curry filter tag-children ;
+    tags@ [ tag-with-attr? ] 2curry filter children>> ;
 
 : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
     assure-name [ tag-with-attr? ] 2curry deep-find ;
@@ -109,8 +110,8 @@ M: process-missing error.
     names-match? [ "Unexpected XML tag found" throw ] unless ;
 
 : insert-children ( children tag -- )
-    dup tag-children [ push-all ]
+    dup children>> [ push-all ]
-    [ >r V{ } like r> set-tag-children ] if ;
+    [ swap V{ } like >>children drop ] if ;
 
 : insert-child ( child tag -- )
     >r 1vector r> insert-children ;

basis/xml/writer/writer.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: hashtables kernel math namespaces sequences strings
-assocs combinators io io.streams.string
+assocs combinators io io.streams.string accessors
 xml.data wrap xml.entities unicode.categories ;
 IN: xml.writer
 
@@ -38,9 +38,9 @@ SYMBOL: indenter
     ] when ;
 
 : print-name ( name -- )
-    dup name-space f like
+    dup space>> f like
     [ write CHAR: : write1 ] when*
-    name-tag write ;
+    main>> write ;
 
 : print-attrs ( assoc -- )
     [
@@ -59,7 +59,7 @@ M: string write-item
 
 : write-tag ( tag -- )
     ?indent CHAR: < write1
-    dup print-name tag-attrs print-attrs ;
+    dup print-name attrs>> print-attrs ;
 
 : write-start-tag ( tag -- )
     write-tag ">" write ;
@@ -68,7 +68,7 @@ M: contained-tag write-item
     write-tag "/>" write ;
 
 : write-children ( tag -- )
-    indent tag-children ?filter-children
+    indent children>> ?filter-children
     [ write-item ] each unindent ;
 
 : write-end-tag ( tag -- )
@@ -85,18 +85,18 @@ M: open-tag write-item
     r> xml-pprint? set ;
 
 M: comment write-item
-    "<!--" write comment-text write "-->" write ;
+    "<!--" write text>> write "-->" write ;
 
 M: directive write-item
-    "<!" write directive-text write CHAR: > write1 ;
+    "<!" write text>> write CHAR: > write1 ;
 
 M: instruction write-item
-    "<?" write instruction-text write "?>" write ;
+    "<?" write text>> write "?>" write ;
 
 : write-prolog ( xml -- )
-    "<?xml version=\"" write dup prolog-version write
+    "<?xml version=\"" write dup version>> write
-    "\" encoding=\"" write dup prolog-encoding write
+    "\" encoding=\"" write dup encoding>> write
-    prolog-standalone [ "\" standalone=\"yes" write ] when
+    standalone>> [ "\" standalone=\"yes" write ] when
     "\"?>" write ;
 
 : write-chunk ( seq -- )
@@ -104,10 +104,10 @@ M: instruction write-item
 
 : write-xml ( xml -- )
     {
-        [ xml-prolog write-prolog ]
+        [ prolog>> write-prolog ]
-        [ xml-before write-chunk ]
+        [ before>> write-chunk ]
-        [ write-item ]
+        [ body>> write-item ]
-        [ xml-after write-chunk ]
+        [ after>> write-chunk ]
     } cleave ;
 
 : print-xml ( xml -- )

basis/xml/xml.factor

@@ -38,19 +38,19 @@ M: directive process
     add-child ;
 
 M: contained process
-    [ contained-name ] keep contained-attrs 
+    [ name>> ] [ attrs>> ] bi
     <contained-tag> add-child ;
 
 M: opener process push-xml ;
 
 : check-closer ( name opener -- name opener )
     dup [ <unopened> throw ] unless
-    2dup opener-name =
+    2dup name>> =
-    [ opener-name swap <mismatched> throw ] unless ;
+    [ name>> swap <mismatched> throw ] unless ;
 
 M: closer process
-    closer-name pop-xml first2
+    name>> pop-xml first2
-    >r check-closer opener-attrs r>
+    >r check-closer attrs>> r>
     <tag> add-child ;
 
 : init-xml-stack ( -- )
@@ -102,10 +102,10 @@ TUPLE: pull-xml scope ;
         init-parser reset-prolog init-ns-stack
         text-now? on
     ] H{ } make-assoc
-    { set-pull-xml-scope } pull-xml construct ;
+    pull-xml boa ;
 
 : pull-event ( pull -- xml-event/f )
-    pull-xml-scope [
+    scope>> [
         text-now? get [ parse-text f ] [
             get-char [ make-tag t ] [ f f ] if
         ] if text-now? set
@@ -127,17 +127,17 @@ TUPLE: pull-xml scope ;
 : call-under ( quot object -- quot )
     swap dup slip ; inline
 
-: sax-loop ( quot -- ) ! quot: xml-elem --
+: sax-loop ( quot: ( xml-elem -- ) -- )
     parse-text call-under
     get-char [ make-tag call-under sax-loop ]
-    [ drop ] if ; inline
+    [ drop ] if ; inline recursive
 
-: sax ( stream quot -- ) ! quot: xml-elem --
+: sax ( stream quot: ( xml-elem -- ) -- )
     swap [
         reset-prolog init-ns-stack
         prolog-data get call-under
         sax-loop
-    ] state-parse ; inline
+    ] state-parse ; inline recursive
 
 : (read-xml) ( -- )
     [ process ] sax-loop ; inline

core/classes/mixin/mixin-tests.factor

@@ -105,3 +105,7 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
 [ ] [ "IN: classes.mixin.tests MIXIN: blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
 
 [ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
+
+MIXIN: empty-mixin
+
+[ f ] [ "hi" empty-mixin? ] unit-test

core/classes/mixin/mixin.factor

@@ -20,7 +20,9 @@ M: mixin-class rank-class drop 3 ;
     dup mixin-class? [
         drop
     ] [
-        { } redefine-mixin-class
+        [ { } redefine-mixin-class ]
+        [ update-classes ]
+        bi
     ] if ;
 
 TUPLE: check-mixin-class mixin ;

core/classes/tuple/tuple.factor

@@ -270,6 +270,9 @@ M: tuple-class define-tuple-class
         tri* define-declared
     ] 3tri ;
 
+M: tuple-class update-generic
+    over new-class? [ 2drop ] [ call-next-method ] if ;
+
 M: tuple-class reset-class
     [
         dup "slots" word-prop [

core/generic/generic.factor

@@ -62,7 +62,9 @@ TUPLE: check-method class generic ;
     [ nip [ classes-intersect? ] [ class<= ] 2bi or ] curry assoc-filter
     values ;
 
-: update-generic ( class generic -- )
+GENERIC# update-generic 1 ( class generic -- )
+
+M: class update-generic
     affected-methods [ +called+ changed-definition ] each ;
 
 : with-methods ( class generic quot -- )

core/io/binary/binary-tests.factor

@@ -2,7 +2,9 @@ USING: io.binary tools.test classes math ;
 IN: io.binary.tests
 
 [ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test
+[ B{ 0 0 0 0 0 0 4 HEX: d2 } ] [ 1234 8 >be ] unit-test
 [ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test
+[ B{ HEX: d2 4 0 0 0 0 0 0 } ] [ 1234 8 >le ] unit-test
 
 [ 1234 ] [ 1234 4 >be be> ] unit-test
 [ 1234 ] [ 1234 4 >le le> ] unit-test

core/parser/parser.factor

@@ -24,7 +24,7 @@ t parser-notes set-global
 
 : note. ( str -- )
     parser-notes? [
-        file get [ path>> write ] when*
+        file get [ path>> write ":" write ] when* 
         lexer get line>> number>string write ": " write
         "Note: " write dup print
     ] when drop ;

extra/db/db.factor

@@ -96,12 +96,12 @@ M: object execute-statement* ( statement type -- )
 : sql-row-typed ( result-set -- seq )
     dup #columns [ row-column-typed ] with map ;
 
-: query-each ( statement quot -- )
+: query-each ( statement quot: ( statement -- ) -- )
     over more-rows? [
         [ call ] 2keep over advance-row query-each
     ] [
         2drop
-    ] if ; inline
+    ] if ; inline recursive
 
 : query-map ( statement quot -- seq )
     accumulator >r query-each r> { } like ; inline

extra/db/queries/queries.factor

@@ -14,7 +14,7 @@ GENERIC: where ( specs obj -- )
 
 : query-make ( class quot -- )
     >r sql-props r>
-    [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
+    [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
     <simple-statement> maybe-make-retryable ; inline
 
 M: db begin-transaction ( -- ) "BEGIN" sql-command ;

extra/html/templates/chloe/chloe.factor

@@ -28,6 +28,7 @@ DEFER: process-template
     [ drop name-url chloe-ns = not ] assoc-filter ;
 
 : chloe-tag? ( tag -- ? )
+    dup xml? [ body>> ] when
     {
         { [ dup tag? not ] [ f ] }
         { [ dup url>> chloe-ns = not ] [ f ] }
@@ -112,12 +113,12 @@ CHLOE-TUPLE: checkbox
 CHLOE-TUPLE: code
 
 : process-chloe-tag ( tag -- )
-    dup name-tag dup tags get at
+    dup main>> dup tags get at
     [ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
 
 : process-tag ( tag -- )
     {
-        [ name-tag >lower tag-stack get push ]
+        [ main>> >lower tag-stack get push ]
         [ write-start-tag ]
         [ process-tag-children ]
         [ write-end-tag ]
@@ -125,7 +126,7 @@ CHLOE-TUPLE: code
     } cleave ;
 
 : expand-attrs ( tag -- tag )
-    dup [ tag? ] is? [
+    dup [ tag? ] [ xml? ] bi or [
         clone [
             [ "@" ?head [ value present ] when ] assoc-map
         ] change-attrs
@@ -134,8 +135,8 @@ CHLOE-TUPLE: code
 : process-template ( xml -- )
     expand-attrs
     {
-        { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
+        { [ dup chloe-tag? ] [ process-chloe-tag ] }
-        { [ dup [ tag? ] is? ] [ process-tag ] }
+        { [ dup [ tag? ] [ xml? ] bi or ] [ process-tag ] }
         { [ t ] [ write-item ] }
     } cond ;
 

extra/html/templates/chloe/syntax/syntax.factor

@@ -23,7 +23,7 @@ tags global [ H{ } clone or ] change-at
 
 MEMO: chloe-name ( string -- name )
     name new
-        swap >>tag
+        swap >>main
         chloe-ns >>url ;
 
 : required-attr ( tag name -- value )
@@ -45,7 +45,7 @@ MEMO: chloe-name ( string -- name )
 : attrs>slots ( tag tuple -- )
     [ attrs>> ] [ <mirror> ] bi*
     '[
-        swap tag>> dup "name" =
+        swap main>> dup "name" =
         [ 2drop ] [ , set-at ] if
     ] assoc-each ;
 

extra/inverse/inverse-tests.factor

@@ -62,10 +62,10 @@ C: <nil> nil
 [ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
 
 : empty-cons ( -- cons ) cons new ;
-: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
+: cons* ( cdr car -- cons ) cons boa ;
 
 [ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
-[ 1 2 ] [ 2 1 <cons> [ cons* ] undo ] unit-test
+[ 1 2 ] [ 1 2 <cons> [ cons* ] undo ] unit-test
 
 [ t ] [ pi [ pi ] matches? ] unit-test
 [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test

extra/io/files/unique/unique-tests.factor

@@ -1,3 +1,5 @@
+USING: io.encodings.ascii sequences strings io io.files accessors
+tools.test kernel io.files.unique ;
 IN: io.files.unique.tests
 
 [ 123 ] [

extra/math/bitfields/lib/lib.factor

@@ -1,14 +1,14 @@
 USING: hints kernel math ;
 IN: math.bitfields.lib
 
-: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
+: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
-: set-bit ( x n -- y ) 2^ bitor ; foldable
+: set-bit ( x n -- y ) 2^ bitor ; inline
-: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
+: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
-: unmask ( x n -- ? ) bitnot bitand ; foldable
+: unmask ( x n -- ? ) bitnot bitand ; inline
-: unmask? ( x n -- ? ) unmask 0 > ; foldable
+: unmask? ( x n -- ? ) unmask 0 > ; inline
-: mask ( x n -- ? ) bitand ; foldable
+: mask ( x n -- ? ) bitand ; inline
-: mask? ( x n -- ? ) mask 0 > ; foldable
+: mask? ( x n -- ? ) mask 0 > ; inline
-: wrap ( m n -- m' ) 1- bitand ; foldable
+: wrap ( m n -- m' ) 1- bitand ; inline
 : bits ( m n -- m' ) 2^ wrap ; inline
 : mask-bit ( m n -- m' ) 1- 2^ mask ; inline
 

extra/math/matrices/elimination/elimination.factor

@@ -31,10 +31,10 @@ SYMBOL: matrix
     >r over r> nth dup zero? [
         3drop 0
     ] [
-        >r nth dup zero? [
+        >r nth dup zero? r> swap [
-            r> 2drop 0
+            2drop 0
         ] [
-            r> swap / neg
+            swap / neg
         ] if
     ] if ;
 

extra/namespaces/lib/lib-tests.factor

@@ -1,6 +1,8 @@
 IN: namespaces.lib.tests
-USING: namespaces.lib tools.test ;
+USING: namespaces.lib kernel tools.test ;
 
 [ ] [ [ ] { } nmake ] unit-test
 
 [ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test
+
+[ [ ] [ call ] curry { { } } nmake ] must-infer

extra/namespaces/lib/lib.factor

@@ -1,8 +1,6 @@
-
-! USING: kernel quotations namespaces sequences assocs.lib ;
-
 USING: kernel namespaces namespaces.private quotations sequences
-       assocs.lib math.parser math generalizations locals mirrors ;
+       assocs.lib math.parser math generalizations locals mirrors
+       macros ;
 
 IN: namespaces.lib
 
@@ -42,22 +40,20 @@ SYMBOL: building-seq
 : 4% ( seq -- ) 4 n% ;
 : 4# ( num -- ) 4 n# ;
 
-MACRO:: nmake ( quot exemplars -- )
+MACRO: finish-nmake ( exemplars -- )
-    [let | n [ exemplars length ] |
+    length [ firstn ] curry ;
-        [
-            [
-                exemplars
-                [ 0 swap new-resizable ] map
-                building-seq set
 
-                quot call
+:: nmake ( quot exemplars -- )
+    [
+        exemplars
+        [ 0 swap new-resizable ] map
+        building-seq set
 
-                building-seq get
+        quot call
-                exemplars [ like ] 2map
+
-                n firstn
+        building-seq get
-            ] with-scope
+        exemplars [ [ like ] 2map ] [ finish-nmake ] bi
-        ]
+    ] with-scope ; inline
-    ] ;
 
 : make-object ( quot class -- object )
     new [ <mirror> swap bind ] keep ; inline

extra/sequences/lib/lib.factor

@@ -193,7 +193,7 @@ USE: continuations
     [
         iterate-step roll
         [ 3nip ] [ iterate-next (attempt-each-integer) ] if*
-    ] [ 3drop f ] if-iterate? ; inline
+    ] [ 3drop f ] if-iterate? ; inline recursive
 PRIVATE>
 
 : attempt-each ( seq quot -- result )

extra/syndication/syndication.factor

@@ -76,8 +76,8 @@ TUPLE: entry title url description date ;
         [ "link" tag-named "href" swap at >url >>url ]
         [
             { "content" "summary" } any-tag-named
-            dup tag-children [ string? not ] contains?
+            dup children>> [ string? not ] contains?
-            [ tag-children [ write-chunk ] with-string-writer ]
+            [ children>> [ write-chunk ] with-string-writer ]
             [ children>string ] if >>description
         ]
         [
@@ -96,7 +96,7 @@ TUPLE: entry title url description date ;
     tri ;
 
 : xml>feed ( xml -- feed )
-    dup name-tag {
+    dup main>> {
         { "RDF" [ rss1.0 ] }
         { "rss" [ rss2.0 ] }
         { "feed" [ atom1.0 ] }

extra/xmode/loader/syntax/syntax.factor

@@ -1,4 +1,4 @@
-USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
+USING: accessors xmode.tokens xmode.rules xmode.keyword-map xml.data
 xml.utilities xml assocs kernel combinators sequences
 math.parser namespaces parser lexer xmode.utilities regexp io.files ;
 IN: xmode.loader.syntax
@@ -7,7 +7,7 @@ SYMBOL: ignore-case?
 
 ! Rule tag parsing utilities
 : (parse-rule-tag) ( rule-set tag specs class -- )
-    construct-rule swap init-from-tag swap add-rule ; inline
+    new swap init-from-tag swap add-rule ; inline
 
 : RULE:
     scan scan-word
@@ -98,4 +98,4 @@ TAGS>
 : init-eol-span-tag ( -- ) [ drop init-eol-span ] , ;
 
 : parse-keyword-tag ( tag keyword-map -- )
-    >r dup name-tag string>token swap children>string r> set-at ;
+    >r dup main>> string>token swap children>string r> set-at ;

extra/xmode/marker/context/context.factor

@@ -1,4 +1,4 @@
-USING: kernel ;
+USING: accessors kernel ;
 IN: xmode.marker.context
 
 ! Based on org.gjt.sp.jedit.syntax.TokenMarker.LineContext
@@ -11,10 +11,9 @@ end
 
 : <line-context> ( ruleset parent -- line-context )
     over [ "no context" throw ] unless
-    { set-line-context-in-rule-set set-line-context-parent }
+    line-context new
-    line-context construct ;
+        swap >>parent
+        swap >>in-rule-set ;
 
 M: line-context clone
-    (clone)
+    call-next-method [ clone ] change-parent ;
-    dup line-context-parent clone
-    over set-line-context-parent ;

extra/xmode/rules/rules.factor

@@ -66,14 +66,11 @@ delegate
 chars
 ;
 
-: construct-rule ( class -- rule )
+TUPLE: seq-rule < rule ;
-    >r rule new r> construct-delegate ; inline
 
-TUPLE: seq-rule ;
+TUPLE: span-rule < rule ;
 
-TUPLE: span-rule ;
+TUPLE: eol-span-rule < rule ;
-
-TUPLE: eol-span-rule ;
 
 : init-span ( rule -- )
     dup rule-delegate [ drop ] [
@@ -85,16 +82,15 @@ TUPLE: eol-span-rule ;
     dup init-span
     t swap set-rule-no-line-break? ;
 
-TUPLE: mark-following-rule ;
+TUPLE: mark-following-rule < rule ;
 
-TUPLE: mark-previous-rule ;
+TUPLE: mark-previous-rule < rule ;
 
-TUPLE: escape-rule ;
+TUPLE: escape-rule < rule ;
 
 : <escape-rule> ( string -- rule )
     f <string-matcher> f f f <matcher>
-    escape-rule construct-rule
+    escape-rule new swap >>start ;
-    [ set-rule-start ] keep ;
 
 GENERIC: text-hash-char ( text -- ch )
 

extra/xmode/utilities/utilities-tests.factor

@@ -1,7 +1,7 @@
 IN: xmode.utilities.tests
-USING: xmode.utilities tools.test xml xml.data kernel strings
+USING: accessors xmode.utilities tools.test xml xml.data kernel
-vectors sequences io.files prettyprint assocs unicode.case ;
+strings vectors sequences io.files prettyprint assocs
-
+unicode.case ;
 [ "hi" 3 ] [
     { 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find
 ] unit-test
@@ -35,7 +35,7 @@ TAGS>
         { { "type" >upper set-company-type } }
         init-from-tag dup
     ] keep
-    tag-children [ tag? ] filter
+    children>> [ tag? ] filter
     [ parse-employee-tag ] with each ;
 
 [

extra/xmode/utilities/utilities.factor

@@ -1,10 +1,10 @@
-USING: sequences assocs kernel quotations namespaces xml.data
+USING: accessors sequences assocs kernel quotations namespaces
-xml.utilities combinators macros parser lexer words ;
+xml.data xml.utilities combinators macros parser lexer words ;
 IN: xmode.utilities
 
 : implies >r not r> or ; inline
 
-: child-tags ( tag -- seq ) tag-children [ tag? ] filter ;
+: child-tags ( tag -- seq ) children>> [ tag? ] filter ;
 
 : map-find ( seq quot -- result elt )
     f -rot
@@ -53,5 +53,5 @@ SYMBOL: tag-handler-word
 
 : TAGS>
     tag-handler-word get
-    tag-handlers get >alist [ >r dup name-tag r> case ] curry
+    tag-handlers get >alist [ >r dup main>> r> case ] curry
     define ; parsing