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

Conflicts:

	core/classes/tuple/tuple.factor

core/bootstrap/image/image.factor

@@ -12,7 +12,7 @@ io.encodings.binary ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
-    cpu dup "ppc" = [ os "-" rot 3append ] when ;
+    cpu dup "ppc" = [ >r os "-" r> 3append ] when ;
 
 : boot-image-name ( arch -- string )
     "boot." swap ".image" 3append ;
@@ -55,7 +55,7 @@ IN: bootstrap.image
 : quot-xt@ 3 bootstrap-cells object tag-number - ;
 
 : jit-define ( quot rc rt offset name -- )
-    >r >r >r >r { } make r> r> r> 4array r> set ;
+    >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
 
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
@@ -134,10 +134,10 @@ SYMBOL: undefined-quot
 
 : here ( -- size ) heap-size data-base + ;
 
-: here-as ( tag -- pointer ) here swap bitor ;
+: here-as ( tag -- pointer ) here bitor ;
 
 : align-here ( -- )
-    here 8 mod 4 = [ heap-size drop 0 emit ] when ;
+    here 8 mod 4 = [ 0 emit ] when ;
 
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
@@ -164,7 +164,7 @@ GENERIC: ' ( obj -- ptr )
     userenv-size [ f ' emit ] times ;
 
 : emit-userenv ( symbol -- )
-    dup get ' swap userenv-offset fixup ;
+    [ get ' ] [ userenv-offset ] bi fixup ;
 
 ! Bignums
 
@@ -175,14 +175,15 @@ GENERIC: ' ( obj -- ptr )
 : bignum>seq ( n -- seq )
     #! n is positive or zero.
     [ dup 0 > ]
-    [ dup bignum-bits neg shift swap bignum-radix bitand ]
+    [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
     [ ] unfold nip ;
 
-USE: continuations
 : emit-bignum ( n -- )
-    dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
+    dup dup 0 < [ neg ] when bignum>seq
-    dup length 1+ emit-fixnum
+    [ nip length 1+ emit-fixnum ]
-    swap emit emit-seq ;
+    [ drop 0 < 1 0 ? emit ]
+    [ nip emit-seq ]
+    2tri ;
 
 M: bignum '
     bignum tag-number dup [ emit-bignum ] emit-object ;
@@ -221,28 +222,33 @@ M: f '
 ! Words
 
 : emit-word ( word -- )
-    dup subwords [ emit-word ] each
     [
-        dup hashcode ' ,
+        [ subwords [ emit-word ] each ]
-        dup word-name ' ,
+        [
-        dup word-vocabulary ' ,
+            [
-        dup word-def ' ,
+                {
-        dup word-props ' ,
+                    [ hashcode , ]
-        f ' ,
+                    [ word-name , ]
-        0 , ! count
+                    [ word-vocabulary , ]
-        0 , ! xt
+                    [ word-def , ]
-        0 , ! code
+                    [ word-props , ]
-        0 , ! profiling
+                } cleave
-    ] { } make
+                f ,
-    \ word type-number object tag-number
+                0 , ! count
-    [ emit-seq ] emit-object
+                0 , ! xt
-    swap objects get set-at ;
+                0 , ! code
+                0 , ! profiling
+            ] { } make [ ' ] map
+        ] bi
+        \ word type-number object tag-number
+        [ emit-seq ] emit-object
+    ] keep objects get set-at ;
 
 : word-error ( word msg -- * )
     [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
 
 : transfer-word ( word -- word )
-    dup target-word swap or ;
+    [ target-word ] keep or ;
 
 : fixup-word ( word -- offset )
     transfer-word dup objects get at
@@ -285,9 +291,10 @@ M: string '
     length 0 assert= ;
 
 : emit-dummy-array ( obj type -- ptr )
-    swap assert-empty
+    [ assert-empty ] [
-    type-number object tag-number
+        type-number object tag-number
-    [ 0 emit-fixnum ] emit-object ;
+        [ 0 emit-fixnum ] emit-object
+    ] bi* ;
 
 M: byte-array ' byte-array emit-dummy-array ;
 
@@ -296,29 +303,28 @@ M: bit-array ' bit-array emit-dummy-array ;
 M: float-array ' float-array emit-dummy-array ;
 
 ! Tuples
+: (emit-tuple) ( tuple -- pointer )
+    [ tuple>array 1 tail-slice ]
+    [ class transfer-word tuple-layout ] bi add* [ ' ] map
+    tuple type-number dup [ emit-seq ] emit-object ;
+
 : emit-tuple ( tuple -- pointer )
-    [
+    dup class word-name "tombstone" =
-        [
+    [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
-            dup class transfer-word tuple-layout ' ,
-            tuple>array 1 tail-slice [ ' ] map %
-        ] { } make
-        tuple type-number dup [ emit-seq ] emit-object
-    ]
-    ! Hack
-    over class word-name "tombstone" =
-    [ objects get swap cache ] [ call ] if ;
 
 M: tuple ' emit-tuple ;
 
 M: tuple-layout '
     objects get [
         [
-            dup layout-hashcode ' ,
+            {
-            dup layout-class ' ,
+                [ layout-hashcode , ]
-            dup layout-size ' ,
+                [ layout-class , ]
-            dup layout-superclasses ' ,
+                [ layout-size , ]
-            layout-echelon ' ,
+                [ layout-superclasses , ]
-        ] { } make
+                [ layout-echelon , ]
+            } cleave
+        ] { } make [ ' ] map
         \ tuple-layout type-number
         object tag-number [ emit-seq ] emit-object
     ] cache ;
@@ -329,14 +335,9 @@ M: tombstone '
     word-def first objects get [ emit-tuple ] cache ;
 
 ! Arrays
-: emit-array ( list type tag -- pointer )
-    >r >r [ ' ] map r> r> [
-        dup length emit-fixnum
-        emit-seq
-    ] emit-object ;
-
 M: array '
-    array type-number object tag-number emit-array ;
+    [ ' ] map array type-number object tag-number
+    [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 
 ! Quotations
 
@@ -351,13 +352,6 @@ M: quotation '
         ] emit-object
     ] cache ;
 
-! Curries
-
-M: curry '
-    dup curry-quot ' swap curry-obj '
-    \ curry type-number object tag-number
-    [ emit emit ] emit-object ;
-
 ! End of the image
 
 : emit-words ( -- )
@@ -437,8 +431,8 @@ M: curry '
 : write-image ( image -- )
     "Writing image to " write
     architecture get boot-image-name resource-path
-    dup write "..." print flush
+    [ write "..." print flush ]
-    binary <file-writer> [ (write-image) ] with-stream ;
+    [ binary <file-writer> [ (write-image) ] with-stream ] bi ;
 
 PRIVATE>
 

core/bootstrap/primitives.factor

@@ -5,7 +5,8 @@ hashtables.private io kernel math namespaces parser sequences
 strings vectors words quotations assocs layouts classes
 classes.tuple classes.tuple.private kernel.private vocabs
 vocabs.loader source-files definitions slots.deprecated
-classes.union compiler.units bootstrap.image.private io.files ;
+classes.union compiler.units bootstrap.image.private io.files
+accessors combinators ;
 IN: bootstrap.primitives
 
 "Creating primitives and basic runtime structures..." print flush
@@ -102,33 +103,36 @@ num-types get f <array> builtins set
 ! Builtin classes
 : builtin-predicate-quot ( class -- quot )
     [
-        "type" word-prop dup
+        "type" word-prop
-        \ tag-mask get < \ tag \ type ? , , \ eq? ,
+        [ tag-mask get < \ tag \ type ? , ] [ , ] bi
+        \ eq? ,
     ] [ ] make ;
 
 : define-builtin-predicate ( class -- )
-    dup
+    [ dup builtin-predicate-quot define-predicate ]
-    dup builtin-predicate-quot define-predicate
+    [ predicate-word make-inline ]
-    predicate-word make-inline ;
+    bi ;
 
 : lookup-type-number ( word -- n )
     global [ target-word ] bind type-number ;
 
 : register-builtin ( class -- )
-    dup
+    [ dup lookup-type-number "type" set-word-prop ]
-    dup lookup-type-number "type" set-word-prop
+    [ dup "type" word-prop builtins get set-nth ]
-    dup "type" word-prop builtins get set-nth ;
+    bi ;
 
 : define-builtin-slots ( symbol slotspec -- )
-    dupd 1 simple-slots
+    [ drop ] [ 1 simple-slots ] 2bi
-    2dup "slots" set-word-prop
+    [ "slots" set-word-prop ] [ define-slots ] 2bi ;
-    define-slots ;
 
 : define-builtin ( symbol slotspec -- )
     >r
-    dup register-builtin
+    {
-    dup f f builtin-class define-class
+        [ register-builtin ]
-    dup define-builtin-predicate
+        [ f f builtin-class define-class ]
+        [ define-builtin-predicate ]
+        [ ]
+    } cleave
     r> define-builtin-slots ;
 
 ! Forward definitions
@@ -335,7 +339,10 @@ define-builtin
         { "set-delegate" "kernel" }
     }
 }
-define-tuple-slots
+[ drop ] [ generate-tuple-slots ] 2bi
+[ [ name>> ] map "slot-names" set-word-prop ]
+[ "slots" set-word-prop ]
+[ define-slots ] 2tri
 
 "tuple" "kernel" lookup define-tuple-layout
 
@@ -495,8 +502,9 @@ f builtins get num-tags get tail union-class define-class
 } define-tuple-class
 
 "curry" "kernel" lookup
-dup f "inline" set-word-prop
+[ f "inline" set-word-prop ]
-dup tuple-layout [ <tuple-boa> ] curry define
+[ ]
+[ tuple-layout [ <tuple-boa> ] curry ] tri define
 
 "compose" "kernel" create
 "tuple" "kernel" lookup
@@ -515,8 +523,9 @@ dup tuple-layout [ <tuple-boa> ] curry define
 } define-tuple-class
 
 "compose" "kernel" lookup
-dup f "inline" set-word-prop
+[ f "inline" set-word-prop ]
-dup tuple-layout [ <tuple-boa> ] curry define
+[ ]
+[ tuple-layout [ <tuple-boa> ] curry ] tri define
 
 ! Primitive words
 : make-primitive ( word vocab n -- )

core/classes/tuple/tuple-docs.factor

@@ -153,23 +153,11 @@ HELP: tuple=
 { $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
 { $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
 
-HELP: permutation
-{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
-{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
-
-HELP: reshape-tuple
-{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } }
-{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ;
-
-HELP: reshape-tuples
-{ $values { "class" tuple-class } { "superclass" class } { "newslots" "a sequence of strings" } }
-{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
-
 HELP: removed-slots
 { $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
 { $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
 
-HELP: forget-slots
+HELP: forget-removed-slots
 { $values { "class" tuple-class } { "slots" "a sequence of strings" } }
 { $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
 

core/classes/tuple/tuple-tests.factor

@@ -3,7 +3,7 @@ math.constants parser sequences tools.test words assocs
 namespaces quotations sequences.private classes continuations
 generic.standard effects classes.tuple classes.tuple.private
 arrays vectors strings compiler.units accessors classes.algebra
-calendar prettyprint io.streams.string splitting ;
+calendar prettyprint io.streams.string splitting inspector ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -265,9 +265,13 @@ C: <laptop> laptop
 [ t ] [ "laptop" get computer? ] unit-test
 [ t ] [ "laptop" get tuple? ] unit-test
 
-[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
+: test-laptop-slot-values
-[ 128 ] [ "laptop" get ram>> ] unit-test
+    [ laptop ] [ "laptop" get class ] unit-test
-[ t ] [ "laptop" get battery>> 3 hours = ] unit-test
+    [ "Pentium" ] [ "laptop" get cpu>> ] unit-test
+    [ 128 ] [ "laptop" get ram>> ] unit-test
+    [ t ] [ "laptop" get battery>> 3 hours = ] unit-test ;
+
+test-laptop-slot-values
 
 [ laptop ] [
     "laptop" get tuple-layout
@@ -294,9 +298,13 @@ C: <server> server
 [ t ] [ "server" get computer? ] unit-test
 [ t ] [ "server" get tuple? ] unit-test
 
-[ "PowerPC" ] [ "server" get cpu>> ] unit-test
+: test-server-slot-values
-[ 64 ] [ "server" get ram>> ] unit-test
+    [ server ] [ "server" get class ] unit-test
-[ "1U" ] [ "server" get rackmount>> ] unit-test
+    [ "PowerPC" ] [ "server" get cpu>> ] unit-test
+    [ 64 ] [ "server" get ram>> ] unit-test
+    [ "1U" ] [ "server" get rackmount>> ] unit-test ;
+
+test-server-slot-values
 
 [ f ] [ "server" get laptop? ] unit-test
 [ f ] [ "laptop" get server? ] unit-test
@@ -316,10 +324,10 @@ C: <server> server
     "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
 ] must-fail
 
-! Reshaping with inheritance
+! Dynamically changing inheritance hierarchy
 TUPLE: electronic-device ;
 
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
 
 [ f ] [ electronic-device laptop class< ] unit-test
 [ t ] [ server electronic-device class< ] unit-test
@@ -335,11 +343,123 @@ TUPLE: electronic-device ;
 [ f ] [ "server" get laptop? ] unit-test
 [ t ] [ "server" get server? ] unit-test
 
-[ ] [ "IN: classes.tuple.tests TUPLE: computer ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test
 
 [ f ] [ "laptop" get electronic-device? ] unit-test
 [ t ] [ "laptop" get computer? ] unit-test
 
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+TUPLE: make-me-some-accessors voltage grounded? ;
+
+[ f ] [ "laptop" get voltage>> ] unit-test
+[ f ] [ "server" get voltage>> ] unit-test
+
+[ ] [ "laptop" get 220 >>voltage drop ] unit-test
+[ ] [ "server" get 110 >>voltage drop ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+! Reshaping superclass and subclass simultaneously
+"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+! Reshape crash
+TUPLE: test1 a ; TUPLE: test2 < test1 b ;
+
+T{ test2 f "a" "b" } "test" set
+
+: test-a/b
+    [ "a" ] [ "test" get a>> ] unit-test
+    [ "b" ] [ "test" get b>> ] unit-test ;
+
+test-a/b
+
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test
+
+test-a/b
+
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test
+
+test-a/b
+
+! Twice in the same compilation unit
+[
+    test1 tuple { "a" "x" "y" } define-tuple-class
+    test1 tuple { "a" "y" } define-tuple-class
+] with-compilation-unit
+
+test-a/b
+
+! Moving slots up and down
+TUPLE: move-up-1 a b ;
+TUPLE: move-up-2 < move-up-1 c ;
+
+T{ move-up-2 f "a" "b" "c" } "move-up" set
+
+: test-move-up
+    [ "a" ] [ "move-up" get a>> ] unit-test
+    [ "b" ] [ "move-up" get b>> ] unit-test
+    [ "c" ] [ "move-up" get c>> ] unit-test ;
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test
+
+! Constructors must be recompiled when changing superclass
+TUPLE: constructor-update-1 xxx ;
+
+TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
+
+C: <constructor-update-2> constructor-update-2
+
+{ 3 1 } [ <constructor-update-2> ] must-infer-as
+
+[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test
+
+{ 5 1 } [ <constructor-update-2> ] must-infer-as
+
+[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
+
 ! Redefinition problem
 TUPLE: redefinition-problem ;
 

core/classes/tuple/tuple.factor

@@ -23,8 +23,16 @@ M: class tuple-layout "layout" word-prop ;
 
 M: tuple tuple-layout 1 slot ;
 
+M: tuple-layout tuple-layout ;
+
 : tuple-size tuple-layout layout-size ; inline
 
+: prepare-tuple>array ( tuple -- n tuple layout )
+    [ tuple-size ] [ ] [ tuple-layout ] tri ;
+
+: copy-tuple-slots ( n tuple -- array )
+    [ array-nth ] curry map ;
+
 PRIVATE>
 
 : check-tuple ( class -- )
@@ -32,28 +40,29 @@ PRIVATE>
     [ drop ] [ no-tuple-class ] if ;
 
 : tuple>array ( tuple -- array )
-    dup tuple-layout
+    prepare-tuple>array >r copy-tuple-slots r> layout-class prefix ;
-    [ layout-size swap [ array-nth ] curry map ] keep
-    layout-class prefix ;
 
-: >tuple ( seq -- tuple )
+: tuple-slots ( tuple -- array )
-    dup first tuple-layout <tuple> [
+    prepare-tuple>array drop copy-tuple-slots ;
-        >r 1 tail-slice dup length r>
+
-        [ tuple-size min ] keep
+: slots>tuple ( tuple class -- array )
-        [ set-array-nth ] curry
+    tuple-layout <tuple> [
-        2each
+        [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
     ] keep ;
 
+: >tuple ( tuple -- array )
+    unclip slots>tuple ;
+
 : slot-names ( class -- seq )
-    "slots" word-prop [ name>> ] map ;
+    "slot-names" word-prop ;
 
 <PRIVATE
 
 : tuple= ( tuple1 tuple2 -- ? )
-    over tuple-layout over tuple-layout eq? [
+    2dup [ tuple-layout ] bi@ eq? [
-        dup tuple-size -rot
+        [ drop tuple-size ]
-        [ >r over r> array-nth >r array-nth r> = ] 2curry
+        [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
-        all-integers?
+        2bi all-integers?
     ] [
         2drop f
     ] if ;
@@ -92,18 +101,19 @@ PRIVATE>
     superclasses 1 head-slice*
     [ slot-names length ] map sum ;
 
-: generate-tuple-slots ( class slots -- slots )
+: generate-tuple-slots ( class slots -- slot-specs )
     over superclass-size 2 + simple-slots ;
 
-: define-tuple-slots ( class slots -- )
+: define-tuple-slots ( class -- )
-    dupd generate-tuple-slots
+    dup dup slot-names generate-tuple-slots
     [ "slots" set-word-prop ]
-    [ define-accessors ]
+    [ define-accessors ] ! new
-    [ define-slots ] 2tri ;
+    [ define-slots ] ! old
+    2tri ;
 
 : make-tuple-layout ( class -- layout )
     [ ]
-    [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
+    [ [ superclass-size ] [ slot-names length ] bi + ]
     [ superclasses dup length 1- ] tri
     <tuple-layout> ;
 
@@ -113,49 +123,75 @@ PRIVATE>
 : removed-slots ( class newslots -- seq )
     swap slot-names seq-diff ;
 
-: forget-slots ( class slots -- )
+: forget-removed-slots ( class slots -- )
     dupd removed-slots [
         [ reader-word forget-method ]
         [ writer-word forget-method ] 2bi
     ] with each ;
 
-: permutation ( seq1 seq2 -- permutation )
+: all-slot-names ( class -- slots )
-    swap [ index ] curry map ;
+    superclasses [ slot-names ] map concat \ class add* ;
 
-: reshape-tuple ( oldtuple permutation -- newtuple )
+: compute-slot-permutation ( class old-slot-names -- permutation )
-    >r tuple>array 2 cut r>
+    >r all-slot-names r> [ index ] curry map ;
-    [ [ swap ?nth ] [ drop f ] if* ] with map
-    append >tuple ;
 
-: reshape-tuples ( class superclass newslots -- )
+: apply-slot-permutation ( old-values permutation -- new-values )
-    nip
+    [ [ swap ?nth ] [ drop f ] if* ] with map ;
-    >r dup slot-names r> permutation
+
-    [
+: permute-slots ( old-values -- new-values )
-        >r "predicate" word-prop instances dup
+    dup first dup outdated-tuples get at
-        r> [ reshape-tuple ] curry map
+    compute-slot-permutation
-        become
+    apply-slot-permutation ;
-    ] 2curry after-compilation ;
+
+: change-tuple ( tuple quot -- newtuple )
+    >r tuple>array r> call >tuple ; inline
+
+: update-tuple ( tuple -- newtuple )
+    [ permute-slots ] change-tuple ;
+
+: update-tuples ( -- )
+    outdated-tuples get
+    dup assoc-empty? [ drop ] [
+        [ >r class r> key? ] curry instances
+        dup [ update-tuple ] map become
+    ] if ;
+
+[ update-tuples ] update-tuples-hook set-global
+
+: update-tuples-after ( class -- )
+    outdated-tuples get [ all-slot-names ] cache drop ;
+
+: subclasses ( class -- classes )
+    class-usages keys [ tuple-class? ] subset ;
+
+: each-subclass ( class quot -- )
+    >r subclasses r> each ; inline
+
+: define-tuple-shape ( class -- )
+    [ define-tuple-slots ]
+    [ define-tuple-layout ]
+    [ define-tuple-predicate ]
+    tri ;
 
 : define-new-tuple-class ( class superclass slots -- )
     [ drop f tuple-class define-class ]
-    [ nip define-tuple-slots ] [
+    [ nip "slot-names" set-word-prop ]
+    [
         2drop
-        class-usages keys [ tuple-class? ] subset [
+        [ define-tuple-shape ] each-subclass
-            [ define-tuple-layout ]
-            [ define-tuple-predicate ]
-            bi
-        ] each
     ] 3tri ;
 
 : redefine-tuple-class ( class superclass slots -- )
-    [ reshape-tuples ]
     [
-        nip
+        2drop
-        [ forget-slots ]
+        [
-        [ drop changed-word ]
+            [ update-tuples-after ]
-        [ drop redefined ]
+            [ changed-word ]
-        2tri
+            [ redefined ]
+            tri
+        ] each-subclass
     ]
+    [ nip forget-removed-slots ]
     [ define-new-tuple-class ]
     3tri ;
 
@@ -175,7 +211,7 @@ M: tuple-class define-tuple-class
     3drop ;
 
 : define-error-class ( class superclass slots -- )
-    pick >r define-tuple-class r>
+    [ define-tuple-class ] [ 2drop ] 3bi
     dup [ construct-boa throw ] curry define ;
 
 M: tuple clone
@@ -184,11 +220,6 @@ M: tuple clone
 M: tuple equal?
     over tuple? [ tuple= ] [ 2drop f ] if ;
 
-: delegates ( obj -- seq )
-    [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
-
-: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
-
 M: tuple hashcode*
     [
         dup tuple-size -rot 0 -rot [
@@ -196,23 +227,26 @@ M: tuple hashcode*
         ] 2curry reduce
     ] recursive-hashcode ;
 
-: tuple-slots ( tuple -- seq ) tuple>array 2 tail ;
-
-! Definition protocol
 M: tuple-class reset-class
     { "metaclass" "superclass" "slots" "layout" } reset-props ;
 
 M: object get-slots ( obj slots -- ... )
     [ execute ] with each ;
 
-M: object set-slots ( ... obj slots -- )
-    <reversed> get-slots ;
-
 M: object construct-empty ( class -- tuple )
     tuple-layout <tuple> ;
 
+M: object construct-boa ( ... class -- tuple )
+    tuple-layout <tuple-boa> ;
+
+! Deprecated
+M: object set-slots ( ... obj slots -- )
+    <reversed> get-slots ;
+
 M: object construct ( ... slots class -- tuple )
     construct-empty [ swap set-slots ] keep ;
 
-M: object construct-boa ( ... class -- tuple )
+: delegates ( obj -- seq )
-    tuple-layout <tuple-boa> ;
+    [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
+
+: is? ( obj quot -- ? ) >r delegates r> contains? ; inline

core/compiler/units/units.factor

@@ -69,21 +69,19 @@ GENERIC: definitions-changed ( assoc obj -- )
     dup [ drop crossref? ] assoc-contains?
     modify-code-heap ;
 
-SYMBOL: post-compile-tasks
+SYMBOL: outdated-tuples
-
+SYMBOL: update-tuples-hook
-: after-compilation ( quot -- )
-    post-compile-tasks get push ;
 
 : call-recompile-hook ( -- )
     changed-words get keys
     compiled-usages recompile-hook get call ;
 
-: call-post-compile-tasks ( -- )
+: call-update-tuples-hook ( -- )
-    post-compile-tasks get [ call ] each ;
+    update-tuples-hook get call ;
 
 : finish-compilation-unit ( -- )
     call-recompile-hook
-    call-post-compile-tasks
+    call-update-tuples-hook
     dup [ drop crossref? ] assoc-contains? modify-code-heap
     changed-definitions notify-definition-observers ;
 
@@ -91,7 +89,7 @@ SYMBOL: post-compile-tasks
     [
         H{ } clone changed-words set
         H{ } clone forgotten-definitions set
-        V{ } clone post-compile-tasks set
+        H{ } clone outdated-tuples set
         <definitions> new-definitions set
         <definitions> old-definitions set
         [ finish-compilation-unit ]

core/continuations/continuations-docs.factor

@@ -29,6 +29,7 @@ $nl
 { $subsection ignore-errors }
 "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
 { $subsection "errors-restartable" }
+{ $subsection "debugger" }
 { $subsection "errors-post-mortem" }
 "When Factor encouters a critical error, it calls the following word:"
 { $subsection die } ;

core/debugger/debugger-docs.factor

@@ -86,7 +86,15 @@ HELP: error-hook
 
 HELP: try
 { $values { "quot" "a quotation" } }
-{ $description "Calls the quotation. If it throws an error, calls " { $link error-hook } " with the error and restores the data stack." } ;
+{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
+{ $examples
+    "The following example prints an error and keeps going:"
+    { $code
+        "[ \"error\" throw ] try"
+        "\"still running...\" print"
+    }
+    { $link "listener" } " uses " { $link try } " to recover from user errors."
+} ;
 
 HELP: expired-error.
 { $error-description "Thrown by " { $link alien-address } " and " { $link alien-invoke } " if an " { $link alien } " object passed in as a parameter has expired. Alien objects expire if they are saved an image which is subsequently loaded; this prevents a certain class of programming errors, usually attempts to use uninitialized objects, since holding a C address is meaningless between sessions." }

core/io/files/files.factor

@@ -267,6 +267,7 @@ M: object copy-file
 DEFER: copy-tree-into
 
 : copy-tree ( from to -- )
+    normalize-pathname
     over link-info type>>
     {
         { +symbolic-link+ [ copy-link ] }

core/kernel/kernel-docs.factor

@@ -7,6 +7,8 @@ IN: kernel
 ARTICLE: "shuffle-words" "Shuffle words"
 "Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
 $nl
+"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
+$nl
 "Removing stack elements:"
 { $subsection drop }
 { $subsection 2drop }
@@ -39,9 +41,28 @@ $nl
 { $code
     ": foo ( m ? n -- m+n/n )"
     "    >r [ r> + ] [ drop r> ] if ; ! This is OK"
-}
+} ;
-"An alternative to using " { $link >r } " and " { $link r> } " is the following:"
+
-{ $subsection dip } ;
+ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
+"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
+$nl
+"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
+{ $code
+    ": keep  [ ] bi ;"
+    ": 2keep [ ] 2bi ;"
+    ": 3keep [ ] 3bi ;"
+    ""
+    ": dup   [ ] [ ] bi ;"
+    ": 2dup  [ ] [ ] 2bi ;"
+    ": 3dup  [ ] [ ] 3bi ;"
+    ""
+    ": tuck  [ nip ] [ ] 2bi ;"
+    ": swap  [ nip ] [ drop ] 2bi ;"
+    ""
+    ": over  [ ] [ drop ] 2bi ;"
+    ": pick  [ ] [ 2drop ] 3bi ;"
+    ": 2over [ ] [ drop ] 3bi ;"
+} ;
 
 ARTICLE: "cleave-combinators" "Cleave combinators"
 "The cleave combinators apply multiple quotations to a single value."
@@ -49,9 +70,11 @@ $nl
 "Two quotations:"
 { $subsection bi }
 { $subsection 2bi }
+{ $subsection 3bi }
 "Three quotations:"
 { $subsection tri }
 { $subsection 2tri }
+{ $subsection 3tri }
 "Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
 { $code
     "! First alternative; uses keep"
@@ -66,13 +89,38 @@ $nl
 "The latter is more aesthetically pleasing than the former."
 $nl
 "A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+{ $subsection "cleave-shuffle-equivalence" } ;
+
+ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
+"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
 $nl
-"From the Merriam-Webster Dictionary: "
+"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
-$nl
+{ $code
-{ $strong "cleave" }
+    ": dip   [ ] bi* ;"
-{ $list
+    ""
-  { $emphasis "To divide by or as if by a cutting blow" }
+    ": slip  [ call ] [ ] bi* ;"
-  { $emphasis "To separate into distinct parts and especially into groups having divergent views" }
+    ": 2slip [ call ] [ ] [ ] tri* ;"
+    ""
+    ": nip   [ drop ] [ ] bi* ;"
+    ": 2nip  [ drop ] [ drop ] [ ] tri* ;"
+    ""
+    ": rot"
+    "    [ [ drop ] [      ] [ drop ] tri* ]"
+    "    [ [ drop ] [ drop ] [      ] tri* ]"
+    "    [ [      ] [ drop ] [ drop ] tri* ]"
+    "    3tri ;"
+    ""
+    ": -rot"
+    "    [ [ drop ] [ drop ] [      ] tri* ]"
+    "    [ [      ] [ drop ] [ drop ] tri* ]"
+    "    [ [ drop ] [      ] [ drop ] tri* ]"
+    "    3tri ;"
+    ""
+    ": spin"
+    "    [ [ drop ] [ drop ] [      ] tri* ]"
+    "    [ [ drop ] [      ] [ drop ] tri* ]"
+    "    [ [      ] [ drop ] [ drop ] tri* ]"
+    "    3tri ;"
 } ;
 
 ARTICLE: "spread-combinators" "Spread combinators"
@@ -96,7 +144,8 @@ $nl
 }
 
 $nl
-"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." ;
+"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+{ $subsection "spread-shuffle-equivalence" } ;
 
 ARTICLE: "apply-combinators" "Apply combinators"
 "The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application."
@@ -496,7 +545,7 @@ HELP: 2bi
     "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- z )" } ", then the following two lines are equivalent:"
     { $code
         "[ p ] [ q ] 2bi"
-        "2dup p swap q"
+        "2dup p -rot q"
     }
     "In general, the following two lines are equivalent:"
     { $code
@@ -505,6 +554,27 @@ HELP: 2bi
     }
 } ;
 
+HELP: 3bi
+{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." }
+{ $examples
+    "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
+    { $code
+        "[ p ] [ q ] 3bi"
+        "3dup p q"
+    }
+    "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- w )" } ", then the following two lines are equivalent:"
+    { $code
+        "[ p ] [ q ] 3bi"
+        "3dup p -roll q"
+    }
+    "In general, the following two lines are equivalent:"
+    { $code
+        "[ p ] [ q ] 3bi"
+        "[ p ] 3keep q"
+    }
+} ;
+
 HELP: tri
 { $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
 { $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "x" } "." }
@@ -542,6 +612,22 @@ HELP: 2tri
     }
 } ;
 
+HELP: 3tri
+{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values, and finally applies " { $snippet "r" } " to the three input values." }
+{ $examples
+    "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
+    { $code
+        "[ p ] [ q ] [ r ] 3tri"
+        "3dup p 3dup q r"
+    }
+    "In general, the following two lines are equivalent:"
+    { $code
+        "[ p ] [ q ] [ r ] 3tri"
+        "[ p ] 3keep [ q ] 3keep r"
+    }
+} ;
+
 
 HELP: bi*
 { $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } }

core/slots/slots.factor

@@ -23,9 +23,6 @@ C: <slot-spec> slot-spec
         [ drop ] [ 1array , \ declare , ] if
     ] [ ] make ;
 
-: slot-named ( name specs -- spec/f )
-    [ slot-spec-name = ] with find nip ;
-
 : create-accessor ( name effect -- word )
     >r "accessors" create dup r>
     "declared-effect" set-word-prop ;
@@ -82,3 +79,6 @@ C: <slot-spec> slot-spec
         dup slot-spec-offset swap slot-spec-name
         define-slot-methods
     ] with each ;
+
+: slot-named ( name specs -- spec/f )
+    [ slot-spec-name = ] with find nip ;

extra/db/types/types.factor

@@ -131,25 +131,17 @@ TUPLE: no-sql-modifier ;
 
 HOOK: bind% db ( spec -- )
 
-TUPLE: no-slot-named ;
-: no-slot-named ( -- * ) T{ no-slot-named } throw ;
-
-: slot-spec-named ( str class -- slot-spec )
-    "slots" word-prop [ slot-spec-name = ] with find nip
-    [ no-slot-named ] unless* ;
-
 : offset-of-slot ( str obj -- n )
-    class slot-spec-named slot-spec-offset ;
+    class "slots" word-prop slot-named slot-spec-offset ;
 
-: get-slot-named ( str obj -- value )
+: get-slot-named ( name obj -- value )
-    tuck offset-of-slot [ no-slot-named ] unless* slot ;
+    tuck offset-of-slot slot ;
 
-: set-slot-named ( value str obj -- )
+: set-slot-named ( value name obj -- )
-    tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
+    tuck offset-of-slot set-slot ;
 
 : tuple>filled-slots ( tuple -- alist )
-    dup <mirror> mirror-slots [ slot-spec-name ] map
+    <mirror> [ nip ] assoc-subset ;
-    swap tuple-slots 2array flip [ nip ] assoc-subset ;
 
 : tuple>params ( specs tuple -- obj )
     [

extra/help/cookbook/cookbook.factor

@@ -267,16 +267,33 @@ $nl
 } ;
 
 ARTICLE: "cookbook-philosophy" "Factor philosophy"
-"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might be related to the amount of code you " { $emphasis "don't" } " have to write."
+"Learning a stack language is like learning to ride a bicycle: it takes a bit of practice and you might graze your knees a couple of times, but once you get the hang of it, it becomes second nature."
 $nl
-"If you try to write Factor word definitions which are longer than a couple of lines, you will find it hard to keep track of the stack contents. Well-written Factor code is " { $emphasis "factored" } " into short definitions, where each definition is easy to test interactively, and has a clear purpose. Well-chosen word names are critical, and having a thesaurus on hand really helps."
+"The most common difficulty encountered by beginners is trouble reading and writing code as a result of trying to place too many values on the stack at a time."
-$nl
-"If you run into problems with stack shuffling, take a deep breath and a step back, and reconsider the problem. A much simpler solution is waiting right around the corner, a natural solution which requires far less stack shuffling and far less code. As a last resort, if no simple solution exists, consider defining a domain-specific language."
-$nl
-"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition and save yourself some debugging time."
-$nl
-"In addition to writing short definitions and testing them interactively, a great habit to get into is writing unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } "."
 $nl
+"Keep the following guidelines in mind to avoid losing your sense of balance:"
+{ $list
+    "SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
+    "In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code."
+    "If your code looks repetitive, factor it some more."
+    "If after factoring, your code still looks repetitive, introduce combinators."
+    "If after introducing combinators, your code still looks repetitive, look into using meta-programming techniques."
+    "Try to place items on the stack in the order in which they are needed. If everything is in the correct order, no shuffling needs to be performed."
+    "If you find yourself writing a stack comment in the middle of a word, break the word up."
+    { "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." }
+    { "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." }
+    "Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition."
+    { "Learn to use the " { $link "inference" } " tool." }
+    { "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." }
+    "Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution."
+    { "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." }
+    { "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." }
+    { "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." }
+    { "If you find yourself wishing you could iterate over the datastack, or capture the contents of the datastack into a sequence, or push each element of a sequence onto the datastack, there is almost always a better way. Use " { $link "sequences" } " instead." }
+    "Don't use meta-programming if there's a simpler way."
+    "Don't worry about efficiency unless your program is too slow. Don't prefer complex code to simple code just because you feel it will be more efficient. The Factor compiler is designed to make idiomatic code run fast."
+    { "None of the above are hard-and-fast rules: there are exceptions to all of them. But one rule unconditionally holds: " { $emphasis "there is always a simpler way" } "." }
+}
 "Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code."
 $nl
 "Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ;

extra/help/handbook/handbook.factor

@@ -206,6 +206,7 @@ ARTICLE: "tools" "Developer tools"
 { $subsection "tools.vocabs" }
 "Exploratory tools:"
 { $subsection "editor" }
+{ $subsection "listener" }
 { $subsection "tools.crossref" }
 { $subsection "inspector" }
 "Debugging tools:"

extra/help/markup/markup.factor

@@ -138,8 +138,7 @@ M: f print-element drop ;
     link-style get [ write-object ] with-style ;
 
 : ($link) ( article -- )
-    dup article-name swap >link write-link
+    [ dup article-name swap >link write-link ] ($span) ;
-    span last-element set ;
 
 : $link ( element -- )
     first ($link) ;

extra/io/sockets/sockets-tests.factor

@@ -0,0 +1,4 @@
+IN: io.sockets.tests
+USING: io.sockets sequences math tools.test ;
+
+[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test

extra/io/sockets/sockets.factor

@@ -6,7 +6,8 @@ IN: io.sockets
 
 TUPLE: local path ;
 
-C: <local> local
+: <local> ( path -- addrspec )
+    normalize-pathname local construct-boa ;
 
 TUPLE: inet4 host port ;
 

extra/io/unix/linux/linux.factor

@@ -3,8 +3,8 @@
 USING: kernel io.backend io.monitors io.monitors.private
 io.files io.buffers io.nonblocking io.timeouts io.unix.backend
 io.unix.select io.unix.launcher unix.linux.inotify assocs
-namespaces threads continuations init math
+namespaces threads continuations init math alien.c-types alien
-alien.c-types alien vocabs.loader ;
+vocabs.loader accessors ;
 IN: io.unix.linux
 
 TUPLE: linux-io ;
@@ -18,18 +18,16 @@ TUPLE: linux-monitor ;
 
 TUPLE: inotify watches ;
 
-: watches ( -- assoc ) inotify get-global inotify-watches ;
+: watches ( -- assoc ) inotify get-global watches>> ;
 
 : wd>monitor ( wd -- monitor ) watches at ;
 
 : <inotify> ( -- port/f )
     H{ } clone
-    inotify_init dup 0 < [ 2drop f ] [
+    inotify_init [ io-error ] [ inotify <buffered-port> ] bi
-        inotify <buffered-port>
+    { set-inotify-watches set-delegate } inotify construct ;
-        { set-inotify-watches set-delegate } inotify construct
-    ] if ;
 
-: inotify-fd inotify get-global port-handle ;
+: inotify-fd inotify get-global handle>> ;
 
 : (add-watch) ( path mask -- wd )
     inotify-fd -rot inotify_add_watch dup io-error ;
@@ -80,10 +78,10 @@ M: linux-monitor dispose ( monitor -- )
     parse-action swap alien>char-string ;
 
 : events-exhausted? ( i buffer -- ? )
-    buffer-fill >= ;
+    fill>> >= ;
 
 : inotify-event@ ( i buffer -- alien )
-    buffer-ptr <displaced-alien> ;
+    ptr>> <displaced-alien> ;
 
 : next-event ( i buffer -- i buffer )
     2dup inotify-event@
@@ -111,14 +109,17 @@ TUPLE: inotify-task ;
     f inotify-task <input-task> ;
 
 : init-inotify ( mx -- )
-    <inotify> dup inotify set-global
+    <inotify>
+    dup inotify set-global
     <inotify-task> swap register-io-task ;
 
 M: inotify-task do-io-task ( task -- )
     io-task-port read-notifications f ;
 
 M: linux-io init-io ( -- )
-    <select-mx> dup mx set-global init-inotify ;
+    <select-mx>
+    [ mx set-global ]
+    [ [ init-inotify ] curry ignore-errors ] bi ;
 
 T{ linux-io } set-io-backend
 

extra/io/unix/sockets/sockets.factor

@@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
 io.nonblocking parser threads unix sequences
 byte-arrays io.sockets io.binary io.unix.backend
 io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators ;
+combinators io.backend io.files ;
 IN: io.unix.sockets
 
 : pending-init-error ( port -- )
@@ -189,7 +189,7 @@ M: local protocol-family drop PF_UNIX ;
 M: local sockaddr-type drop "sockaddr-un" c-type ;
 
 M: local make-sockaddr
-    local-path
+    local-path cwd prepend-path
     dup length 1 + max-un-path > [ "Path too long" throw ] when
     "sockaddr-un" <c-object>
     AF_UNIX over set-sockaddr-un-family

extra/json/writer/writer.factor

@@ -26,32 +26,27 @@ M: number json-print ( num -- )
 M: integer json-print ( num -- )  
   number>string write ;
 
-M: sequence json-print ( array -- string ) 
+M: sequence json-print ( array -- ) 
   CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ;
 
-: (jsvar-encode) ( char -- char )
-  #! Convert the given character to a character usable in
-  #! javascript variable names.
-  dup H{ { CHAR: - CHAR: _ } } at dup [ nip ] [ drop ] if ;
-
 : jsvar-encode ( string -- string )
   #! Convert the string so that it contains characters usable within
   #! javascript variable names.
-  [ (jsvar-encode) ] map ;
+  { { CHAR: - CHAR: _ } } substitute ;
   
-: tuple>fields ( object -- string )
+: tuple>fields ( object -- seq )
   <mirror> [
     [ swap jsvar-encode >json % " : " % >json % ] "" make
   ] { } assoc>map ;
 
-M: tuple json-print ( tuple -- string )
+M: tuple json-print ( tuple -- )
   CHAR: { write1 tuple>fields "," join write CHAR: } write1 ;
 
-M: hashtable json-print ( hashtable -- string )
+M: hashtable json-print ( hashtable -- )
   CHAR: { write1 
   [ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ]
   { } assoc>map "," join write 
   CHAR: } write1 ;
 
-M: object json-print ( object -- string )
+M: object json-print ( object -- )
     unparse json-print ;

extra/match/match.factor

@@ -65,3 +65,26 @@ MACRO: match-cond ( assoc -- )
     -rot
     match [ "Pattern does not match" throw ] unless*
     [ replace-patterns ] bind ;
+
+: ?1-tail ( seq -- tail/f )
+    dup length zero? not [ 1 tail ] [ drop f ] if ;
+
+: (match-first) ( seq pattern-seq -- bindings leftover/f )
+    2dup [ length ] bi@ < [ 2drop f f ]
+    [
+        2dup length head over match
+        [ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if*
+    ] if ;
+    
+: match-first ( seq pattern-seq -- bindings )
+    (match-first) drop ;
+
+: (match-all) ( seq pattern-seq -- )
+    tuck (match-first) swap 
+    [ 
+        , [ swap (match-all) ] [ drop ] if* 
+    ] [ 2drop ] if* ;
+
+: match-all ( seq pattern-seq -- bindings-seq )
+    [ (match-all) ] { } make ;
+    

extra/openssl/openssl-tests.factor

@@ -11,11 +11,12 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
 ]
 [ "Hello world from the openssl binding" >md5 ] unit-test
 
-[
+! Not found on netbsd, windows -- why?
-    B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49
+! [
-    82 115 0 }
+    ! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49
-]
+    ! 82 115 0 }
-[ "Hello world from the openssl binding" >sha1 ] unit-test
+! ]
+! [ "Hello world from the openssl binding" >sha1 ] unit-test
 
 ! =========================================================
 ! Initialize context

extra/peg/ebnf/ebnf-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel tools.test peg peg.ebnf words ;
+USING: kernel tools.test peg peg.ebnf words math math.parser ;
 IN: peg.ebnf.tests
 
 { T{ ebnf-non-terminal f "abc" } } [
@@ -160,6 +160,25 @@ IN: peg.ebnf.tests
   "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast
 ] unit-test
 
+{ 6 } [
+  "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call parse-result-ast
+] unit-test
+
+{ 6 } [
+  "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast
+] unit-test
+
+{ 10 } [
+  { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+  { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call 
+] unit-test
+
+{ 3 } [
+  { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
+] unit-test
 
 { V{ V{ 49 } "+" V{ 49 } } } [ 
   #! Test direct left recursion. 

extra/peg/ebnf/ebnf.factor

@@ -3,7 +3,7 @@
 USING: kernel compiler.units parser words arrays strings math.parser sequences 
        quotations vectors namespaces math assocs continuations peg
        peg.parsers unicode.categories multiline combinators.lib 
-       splitting accessors ;
+       splitting accessors effects sequences.deep ;
 IN: peg.ebnf
 
 TUPLE: ebnf-non-terminal symbol ;
@@ -19,6 +19,8 @@ TUPLE: ebnf-repeat1 group ;
 TUPLE: ebnf-optional group ;
 TUPLE: ebnf-rule symbol elements ;
 TUPLE: ebnf-action parser code ;
+TUPLE: ebnf-var parser name ;
+TUPLE: ebnf-semantic parser code ;
 TUPLE: ebnf rules ;
 
 C: <ebnf-non-terminal> ebnf-non-terminal
@@ -34,6 +36,8 @@ C: <ebnf-repeat1> ebnf-repeat1
 C: <ebnf-optional> ebnf-optional
 C: <ebnf-rule> ebnf-rule
 C: <ebnf-action> ebnf-action
+C: <ebnf-var> ebnf-var
+C: <ebnf-semantic> ebnf-semantic
 C: <ebnf> ebnf
 
 : syntax ( string -- parser )
@@ -79,6 +83,7 @@ C: <ebnf> ebnf
       [ dup CHAR: * = ]
       [ dup CHAR: + = ]
       [ dup CHAR: ? = ]
+      [ dup CHAR: : = ]
     } || not nip    
   ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
 
@@ -99,7 +104,7 @@ C: <ebnf> ebnf
     "]" syntax ,
   ] seq* [ first >string <ebnf-range> ] action ;
  
-: 'element' ( -- parser )
+: ('element') ( -- parser )
   #! An element of a rule. It can be a terminal or a 
   #! non-terminal but must not be followed by a "=". 
   #! The latter indicates that it is the beginning of a
@@ -117,6 +122,12 @@ C: <ebnf> ebnf
     ] choice* ,
   ] seq* [ first ] action ;
 
+: 'element' ( -- parser )
+  [
+    [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
+    ('element') ,
+  ] choice* ;
+
 DEFER: 'choice'
 
 : grouped ( quot suffix  -- parser )
@@ -147,6 +158,7 @@ DEFER: 'choice'
 : 'factor-code' ( -- parser )
   [
     "]]" token ensure-not ,
+    "]?" token ensure-not ,
     [ drop t ] satisfy ,
   ] seq* [ first ] action repeat0 [ >string ] action ;
 
@@ -184,14 +196,15 @@ DEFER: 'choice'
 : 'action' ( -- parser )
    "[[" 'factor-code' "]]" syntax-pack ;
 
+: 'semantic' ( -- parser )
+   "?[" 'factor-code' "]?" syntax-pack ;
+
 : 'sequence' ( -- parser )
   #! A sequence of terminals and non-terminals, including
   #! groupings of those. 
   [
-    [ 
+    [ ('sequence') , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
-      ('sequence') ,
+    [ ('sequence') , 'semantic' , ] seq* [ first2 <ebnf-semantic> ] action ,
-      'action' ,
-    ] seq* [ first2 <ebnf-action> ] action ,
     ('sequence') ,
   ] choice* repeat1 [ 
      dup length 1 = [ first ] [ <ebnf-sequence> ] if
@@ -200,6 +213,7 @@ DEFER: 'choice'
 : 'actioned-sequence' ( -- parser )
   [
     [ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 <ebnf-action> ] action ,
+    [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,
     'sequence' ,
   ] choice* ;
   
@@ -223,15 +237,17 @@ GENERIC: (transform) ( ast -- parser )
 
 SYMBOL: parser
 SYMBOL: main
+SYMBOL: vars
 
 : transform ( ast -- object )
-  H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
+  H{ } clone dup dup [ parser set V{ } vars set swap (transform) main set ] bind ;
 
 M: ebnf (transform) ( ast -- parser )
   rules>> [ (transform) ] map peek ;
   
 M: ebnf-rule (transform) ( ast -- parser )
-  dup elements>> (transform) [
+  dup elements>> 
+  vars get clone vars [ (transform) ] with-variable [
     swap symbol>> set
   ] keep ;
 
@@ -266,9 +282,30 @@ M: ebnf-repeat1 (transform) ( ast -- parser )
 M: ebnf-optional (transform) ( ast -- parser )
   transform-group optional ;
 
+: build-locals ( string vars -- string )
+  dup empty? [
+    drop
+  ] [
+    [
+      "USING: locals namespaces ;  [let* | " %
+      [ dup % " [ \"" % % "\" get ] " % ] each
+      " | " %
+      %  
+      " ] with-locals" %     
+    ] "" make 
+  ] if ;
+
 M: ebnf-action (transform) ( ast -- parser )
   [ parser>> (transform) ] keep
-  code>> string-lines [ parse-lines ] with-compilation-unit action ;
+  code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit action ;
+
+M: ebnf-semantic (transform) ( ast -- parser )
+  [ parser>> (transform) ] keep
+  code>> vars get build-locals string-lines [ parse-lines ] with-compilation-unit semantic ;
+
+M: ebnf-var (transform) ( ast -- parser )
+  [ parser>> (transform) ] [ name>> ] bi 
+  dup vars get push [ dupd set ] curry action ;
 
 M: ebnf-terminal (transform) ( ast -- parser )
   symbol>> token sp ;
@@ -296,12 +333,12 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
 : ebnf>quot ( string -- hashtable quot )
   'ebnf' parse check-parse-result 
   parse-result-ast transform dup dup parser [ main swap at compile ] with-variable
-  [ compiled-parse ] curry ;
+  [ compiled-parse ] curry [ with-scope ] curry ;
 
 : [EBNF "EBNF]" parse-multiline-string ebnf>quot nip parsed ; parsing
 
 : EBNF: 
   CREATE-WORD dup 
   ";EBNF" parse-multiline-string
-  ebnf>quot swapd define "ebnf-parser" set-word-prop ; parsing
+  ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing
 

extra/peg/peg-docs.factor

@@ -95,6 +95,19 @@ HELP: optional
     "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
     "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
 
+HELP: semantic
+{ $values 
+  { "parser" "a parser" } 
+  { "quot" "a quotation with stack effect ( object -- bool )" } 
+}
+{ $description 
+    "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
+    "the AST produced by 'p1' on the stack returns true." }
+{ $examples 
+  { $example "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse" "f" } 
+  { $example "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast " "67" } 
+} ;
+
 HELP: ensure
 { $values 
   { "parser" "a parser" } 
@@ -124,7 +137,7 @@ HELP: action
     "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
     "from that parse. The result of the quotation is then used as the final AST. This can be used "
     "for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
-    "the default AST." }
+    "the default AST. If the quotation returns " { $link fail } " then the parser fails." }
 { $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
 
 HELP: sp

extra/peg/peg-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 !
-USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words ;
+USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ;
 IN: peg.tests
 
 { f } [
@@ -182,4 +182,13 @@ IN: peg.tests
   [ f , "a" token , ] seq*
   dup parsers>>
   dupd 0 swap set-nth compile word?
-] unit-test
+] unit-test
+
+{ f } [
+  "A" [ drop t ] satisfy [ 66 >= ] semantic parse 
+] unit-test
+
+{ CHAR: B } [
+  "B" [ drop t ] satisfy [ 66 >= ] semantic parse parse-result-ast
+] unit-test
+

extra/peg/peg.factor

@@ -3,7 +3,7 @@
 USING: kernel sequences strings namespaces math assocs shuffle 
        vectors arrays combinators.lib math.parser match
        unicode.categories sequences.lib compiler.units parser
-       words quotations effects memoize accessors locals ;
+       words quotations effects memoize accessors locals effects ;
 IN: peg
 
 USE: prettyprint
@@ -208,7 +208,7 @@ GENERIC: (compile) ( parser -- quot )
 :: parser-body ( parser -- quot )
   #! Return the body of the word that is the compiled version
   #! of the parser.
-  [let* | rule [ parser (compile) define-temp dup parser "peg" set-word-prop ] 
+  [let* | rule [ gensym dup parser (compile) 0 1 <effect> define-declared dup parser "peg" set-word-prop ] 
         |
     [
       rule pos get apply-rule dup fail = [ 
@@ -218,7 +218,7 @@ GENERIC: (compile) ( parser -- quot )
       ] if
     ] 
   ] ;
- 
+
 : compiled-parser ( parser -- word )
   #! Look to see if the given parser has been compiled.
   #! If not, compile it to a temporary word, cache it,
@@ -229,7 +229,7 @@ GENERIC: (compile) ( parser -- quot )
   dup compiled>> [
     nip
   ] [
-    gensym tuck >>compiled 2dup parser-body define dupd "peg" set-word-prop
+    gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop
   ] if* ;
 
 : compile ( parser -- word )
@@ -414,6 +414,23 @@ TUPLE: optional-parser p1 ;
 M: optional-parser (compile) ( parser -- quot )
   p1>> compiled-parser \ ?quot optional-pattern match-replace ;
 
+TUPLE: semantic-parser p1 quot ;
+
+MATCH-VARS: ?parser ;
+
+: semantic-pattern ( -- quot )
+  [
+    ?parser [
+      dup parse-result-ast ?quot call [ drop f ] unless
+    ] [
+      f
+    ] if*
+  ] ;
+
+M: semantic-parser (compile) ( parser -- quot )
+  [ p1>> compiled-parser ] [ quot>> ] bi  
+  2array { ?parser ?quot } semantic-pattern match-replace ;
+
 TUPLE: ensure-parser p1 ;
 
 : ensure-pattern ( -- quot )
@@ -490,8 +507,11 @@ M: box-parser (compile) ( parser -- quot )
   #! Calls the quotation at compile time
   #! to produce the parser to be compiled.
   #! This differs from 'delay' which calls
-  #! it at run time.
+  #! it at run time. Due to using the runtime
-  quot>> call compiled-parser 1quotation ;
+  #! environment at compile time, this parser
+  #! must not be cached, so we clear out the
+  #! delgates cache.
+  f >>compiled quot>> call compiled-parser 1quotation ;
 
 PRIVATE>
 
@@ -543,6 +563,9 @@ PRIVATE>
 : optional ( parser -- parser )
   optional-parser construct-boa init-parser ;
 
+: semantic ( parser quot -- parser )
+  semantic-parser construct-boa init-parser ;
+
 : ensure ( parser -- parser )
   ensure-parser construct-boa init-parser ;
 
@@ -562,7 +585,12 @@ PRIVATE>
   delay-parser construct-boa init-parser ;
 
 : box ( quot -- parser )
-  box-parser construct-boa init-parser ;
+  #! because a box has its quotation run at compile time
+  #! it must always have a new parser delgate created, 
+  #! not a cached one. This is because the same box,
+  #! compiled twice can have a different compiled word
+  #! due to running at compile time.
+  box-parser construct-boa next-id f <parser> over set-delegate ;
 
 : PEG:
   (:) [

extra/random/mersenne-twister/mersenne-twister.factor

@@ -4,7 +4,7 @@
 ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
 
 USING: arrays kernel math namespaces sequences system init
-accessors math.ranges new-effects random ;
+accessors math.ranges random ;
 IN: random.mersenne-twister
 
 <PRIVATE
@@ -19,34 +19,33 @@ TUPLE: mersenne-twister seq i ;
 : wrap ( x n -- y ) 2dup >= [ - ] [ drop ] if ; inline
 : mt-wrap ( x -- y ) mt-n wrap ; inline
 
-: set-generated ( mt y from-elt to -- )
+: set-generated ( y from-elt to seq -- )
-    >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi
+    >r >r >r [ 2/ ] [ odd? mt-a 0 ? ] bi
-    r> bitxor bitxor r> new-set-nth drop ; inline
+    r> bitxor bitxor r> r> set-nth ; inline
 
-: calculate-y ( mt y1 y2 -- y )
+: calculate-y ( y1 y2 mt -- y )
-    >r over r>
+    tuck [ nth mt-hi ] [ nth mt-lo ] 2bi* bitor ; inline
-    [ new-nth mt-hi ] [ new-nth mt-lo ] 2bi* bitor ; inline
 
-: (mt-generate) ( mt-seq n -- y to from-elt )
+: (mt-generate) ( n mt-seq -- y to from-elt )
-    [ dup 1+ mt-wrap calculate-y ]
+    [ >r dup 1+ mt-wrap r> calculate-y ]
-    [ mt-m + mt-wrap new-nth ]
+    [ >r mt-m + mt-wrap r> nth ]
-    [ nip ] 2tri ;
+    [ drop ] 2tri ;
 
 : mt-generate ( mt -- )
-    [ seq>> mt-n [ dupd (mt-generate) set-generated ] with each ]
+    [ >r mt-n r> seq>> [ [ (mt-generate) ] keep set-generated ] curry each ]
     [ 0 >>i drop ] bi ;
 
 : init-mt-first ( seed -- seq )
     >r mt-n 0 <array> r>
-    HEX: ffffffff bitand 0 new-set-nth ;
+    HEX: ffffffff bitand 0 pick set-nth ;
 
 : init-mt-formula ( seq i -- f(seq[i]) )
-    tuck new-nth dup -30 shift bitxor 1812433253 * +
+    tuck swap nth dup -30 shift bitxor 1812433253 * +
     1+ HEX: ffffffff bitand ;
 
 : init-mt-rest ( seq -- )
     mt-n 1- [0,b) [
-        dupd [ init-mt-formula ] keep 1+ new-set-nth drop
+        dupd [ init-mt-formula ] keep 1+ rot set-nth
     ] with each ;
 
 : init-mt-seq ( seed -- seq )
@@ -68,7 +67,7 @@ M: mersenne-twister seed-random ( mt seed -- )
     init-mt-seq >>seq drop ;
 
 M: mersenne-twister random-32* ( mt -- r )
-    dup [ seq>> ] [ i>> ] bi
+    dup [ i>> ] [ seq>> ] bi
-    dup mt-n < [ drop 0 pick mt-generate ] unless
+    over mt-n < [ nip >r dup mt-generate 0 r> ] unless
-    new-nth mt-temper
+    nth mt-temper
     swap [ 1+ ] change-i drop ;

extra/serialize/serialize.factor

@@ -90,13 +90,13 @@ M: float (serialize) ( obj -- )
 
 M: complex (serialize) ( obj -- )
     CHAR: c write1
-    dup real-part (serialize)
+    [ real-part (serialize) ]
-    imaginary-part (serialize) ;
+    [ imaginary-part (serialize) ] bi ;
 
 M: ratio (serialize) ( obj -- )
     CHAR: r write1
-    dup numerator (serialize)
+    [ numerator (serialize) ]
-    denominator (serialize) ;
+    [ denominator (serialize) ] bi ;
 
 : serialize-seq ( obj code -- )
     [
@@ -120,7 +120,8 @@ M: array (serialize) ( obj -- )
 
 M: quotation (serialize) ( obj -- )
     [
-        CHAR: q write1 [ >array (serialize) ] [ add-object ] bi
+        CHAR: q write1
+        [ >array (serialize) ] [ add-object ] bi
     ] serialize-shared ;
 
 M: hashtable (serialize) ( obj -- )
@@ -234,10 +235,12 @@ SYMBOL: deserialized
     ] if ;
 
 : deserialize-gensym ( -- word )
-    gensym
+    gensym {
-    dup intern-object
+        [ intern-object ]
-    dup (deserialize) define
+        [ (deserialize) define ]
-    dup (deserialize) swap set-word-props ;
+        [ (deserialize) swap set-word-props ]
+        [ ]
+    } cleave ;
 
 : deserialize-wrapper ( -- wrapper )
     (deserialize) <wrapper> ;

extra/tools/disassembler/disassembler.factor

@@ -26,11 +26,14 @@ M: pair make-disassemble-cmd
 M: method-spec make-disassemble-cmd
     first2 method make-disassemble-cmd ;
 
+: gdb-binary ( -- string )
+    os "freebsd" = "gdb66" "gdb" ? ;
+
 : run-gdb ( -- lines )
     <process>
         +closed+ >>stdin
         out-file >>stdout
-        [ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command
+        [ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
     try-process
     out-file ascii file-lines ;
 

extra/unix/bsd/bsd.factor

@@ -24,16 +24,6 @@ IN: unix
 : F_SETFL 4 ; inline
 : O_NONBLOCK 4 ; inline
 
-C-STRUCT: addrinfo
-    { "int" "flags" }
-    { "int" "family" }
-    { "int" "socktype" }
-    { "int" "protocol" }
-    { "socklen_t" "addrlen" }
-    { "char*" "canonname" }
-    { "void*" "addr" }
-    { "addrinfo*" "next" } ;
-
 C-STRUCT: sockaddr-in
     { "uchar" "len" }
     { "uchar" "family" }

extra/unix/bsd/freebsd/freebsd.factor

@@ -1,3 +1,14 @@
+USING: alien.syntax ;
 IN: unix
 
 : FD_SETSIZE 1024 ;
+
+C-STRUCT: addrinfo
+    { "int" "flags" }
+    { "int" "family" } 
+    { "int" "socktype" }
+    { "int" "protocol" }
+    { "socklen_t" "addrlen" }
+    { "char*" "canonname" }
+    { "void*" "addr" }
+    { "addrinfo*" "next" } ;

extra/unix/bsd/macosx/macosx.factor

@@ -1,3 +1,14 @@
+USING: alien.syntax ;
 IN: unix
 
 : FD_SETSIZE 1024 ; inline
+
+C-STRUCT: addrinfo
+    { "int" "flags" }
+    { "int" "family" } 
+    { "int" "socktype" }
+    { "int" "protocol" }
+    { "socklen_t" "addrlen" }
+    { "char*" "canonname" }
+    { "void*" "addr" }
+    { "addrinfo*" "next" } ;

extra/unix/bsd/netbsd/netbsd.factor

@@ -1,3 +1,14 @@
+USING: alien.syntax ;
 IN: unix
 
 : FD_SETSIZE 256 ; inline
+
+C-STRUCT: addrinfo
+    { "int" "flags" }
+    { "int" "family" } 
+    { "int" "socktype" }
+    { "int" "protocol" }
+    { "socklen_t" "addrlen" }
+    { "char*" "canonname" }
+    { "void*" "addr" }
+    { "addrinfo*" "next" } ;

extra/unix/bsd/openbsd/openbsd.factor

@@ -1,3 +1,14 @@
+USING: alien.syntax ;
 IN: unix
 
 : FD_SETSIZE 1024 ; inline
+
+C-STRUCT: addrinfo
+    { "int" "flags" }
+    { "int" "family" } 
+    { "int" "socktype" }
+    { "int" "protocol" }
+    { "socklen_t" "addrlen" }
+    { "void*" "addr" }
+    { "char*" "canonname" }
+    { "addrinfo*" "next" } ;