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

Conflicts:

	extra/delegate/delegate.factor

build-support/grovel.c

@@ -42,6 +42,7 @@
 	#include <sys/socket.h>
 	#include <sys/errno.h>
     #include <sys/mman.h>
+    #include <sys/syslimits.h>
 	#include <fcntl.h>
 	#include <unistd.h>
 #endif
@@ -146,6 +147,7 @@ void unix_constants()
 	constant(PROT_WRITE);
 	constant(MAP_FILE);
 	constant(MAP_SHARED);
+	constant(PATH_MAX);
 	grovel(pid_t);
 
 }

core/alien/alien-docs.factor

@@ -76,8 +76,8 @@ $nl
 { $examples "Here is a typical usage of " { $link add-library } ":"
 { $code
     "<< \"freetype\" {"
-    "    { [ macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
+    "    { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
-    "    { [ windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
+    "    { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
     "    { [ t ] [ drop ] }"
     "} cond >>"
 }

core/alien/alien.factor

@@ -29,7 +29,7 @@ M: f expired? drop t ;
     f <displaced-alien> { simple-c-ptr } declare ; inline
 
 : alien>native-string ( alien -- string )
-    windows? [ alien>u16-string ] [ alien>char-string ] if ;
+    os windows? [ alien>u16-string ] [ alien>char-string ] if ;
 
 : dll-path ( dll -- string )
     (dll-path) alien>native-string ;

core/alien/c-types/c-types.factor

@@ -45,7 +45,7 @@ GENERIC: c-type ( name -- type ) foldable
 
 : parse-array-type ( name -- array )
     "[" split unclip
-    >r [ "]" ?tail drop string>number ] map r> add* ;
+    >r [ "]" ?tail drop string>number ] map r> prefix ;
 
 M: string c-type ( name -- type )
     CHAR: ] over member? [
@@ -162,7 +162,7 @@ DEFER: >c-ushort-array
     >r >c-ushort-array r> byte-array>memory ;
 
 : (define-nth) ( word type quot -- )
-    >r heap-size [ rot * ] swap add* r> append define-inline ;
+    >r heap-size [ rot * ] swap prefix r> append define-inline ;
 
 : nth-word ( name vocab -- word )
     >r "-nth" append r> create ;
@@ -199,12 +199,12 @@ M: long-long-type box-return ( type -- )
     f swap box-parameter ;
 
 : define-deref ( name vocab -- )
-    >r dup CHAR: * add* r> create
+    >r dup CHAR: * prefix r> create
-    swap c-getter 0 add* define-inline ;
+    swap c-getter 0 prefix define-inline ;
 
 : define-out ( name vocab -- )
     over [ <c-object> tuck 0 ] over c-setter append swap
-    >r >r constructor-word r> r> add* define-inline ;
+    >r >r constructor-word r> r> prefix define-inline ;
 
 : c-bool> ( int -- ? )
     zero? not ;
@@ -257,7 +257,7 @@ M: long-long-type box-return ( type -- )
     #! staging violations
     dup array? [
         unclip >r [ dup word? [ word-def call ] when ] map
-        r> add*
+        r> prefix
     ] when ;
 
 : malloc-file-contents ( path -- alien len )
@@ -388,6 +388,6 @@ M: long-long-type box-return ( type -- )
 
     [ string>u16-alien ] "ushort*" c-type set-c-type-prep
     
-    win64? "longlong" "long" ? "ptrdiff_t" typedef
+    os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
     
 ] with-compilation-unit

core/alien/compiler/compiler.factor

@@ -18,7 +18,7 @@ IN: alien.compiler
 
 : alien-node-parameters* ( node -- seq )
     dup parameters>>
-    swap return>> large-struct? [ "void*" add* ] when ;
+    swap return>> large-struct? [ "void*" prefix ] when ;
 
 : alien-node-return* ( node -- ctype )
     return>> dup large-struct? [ drop "void" ] when ;

core/alien/structs/structs-docs.factor

@@ -8,7 +8,7 @@ kernel words slots assocs namespaces ;
     dup ?word-name swap 2array
     over slot-spec-name
     rot slot-spec-type 2array 2array
-    [ { $instance } swap add ] assoc-map ;
+    [ { $instance } swap suffix ] assoc-map ;
 
 : $spec-reader-values ( slot-spec class -- )
     ($spec-reader-values) $values ;
@@ -16,9 +16,9 @@ kernel words slots assocs namespaces ;
 : $spec-reader-description ( slot-spec class -- )
     [
         "Outputs the value stored in the " ,
-        { $snippet } rot slot-spec-name add ,
+        { $snippet } rot slot-spec-name suffix ,
         " slot of " ,
-        { $instance } swap add ,
+        { $instance } swap suffix ,
         " instance." ,
     ] { } make $description ;
 
@@ -43,9 +43,9 @@ M: word slot-specs "slots" word-prop ;
 : $spec-writer-description ( slot-spec class -- )
     [
         "Stores a new value to the " ,
-        { $snippet } rot slot-spec-name add ,
+        { $snippet } rot slot-spec-name suffix ,
         " slot of " ,
-        { $instance } swap add ,
+        { $instance } swap suffix ,
         " instance." ,
     ] { } make $description ;
 

core/alien/structs/structs.factor

@@ -16,7 +16,7 @@ IN: alien.structs
     ] reduce ;
 
 : define-struct-slot-word ( spec word quot -- )
-    rot slot-spec-offset add* define-inline ;
+    rot slot-spec-offset prefix define-inline ;
 
 : define-getter ( type spec -- )
     [ set-reader-props ] keep

core/assocs/assocs-docs.factor

@@ -16,6 +16,22 @@ $nl
 "To make an assoc into an alist:"
 { $subsection >alist } ;
 
+ARTICLE: "enums" "Enumerations"
+"An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:"
+{ $subsection enum }
+{ $subsection <enum> }
+"Inverting a permutation using enumerations:"
+{ $example "USING: assocs sorting prettyprint ;" ": invert <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
+
+HELP: enum
+{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
+$nl
+"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
+
+HELP: <enum>
+{ $values { "seq" sequence } { "enum" enum } }
+{ $description "Creates a new enumeration." } ;
+
 ARTICLE: "assocs-protocol" "Associative mapping protocol"
 "All associative mappings must be instances of a mixin class:"
 { $subsection assoc }

core/assocs/assocs.factor

@@ -1,6 +1,7 @@
-! Copyright (C) 2007 Daniel Ehrenberg
+! Copyright (C) 2007, 2008 Daniel Ehrenberg, Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays math sequences.private vectors ;
+USING: kernel sequences arrays math sequences.private vectors
+accessors ;
 IN: assocs
 
 MIXIN: assoc
@@ -189,3 +190,24 @@ M: f clear-assoc drop ;
 M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
 
 INSTANCE: sequence assoc
+
+TUPLE: enum seq ;
+
+C: <enum> enum
+
+M: enum at*
+    seq>> 2dup bounds-check?
+    [ nth t ] [ 2drop f f ] if ;
+
+M: enum set-at seq>> set-nth ;
+
+M: enum delete-at enum-seq delete-nth ;
+
+M: enum >alist ( enum -- alist )
+    seq>> [ length ] keep 2array flip ;
+
+M: enum assoc-size seq>> length ;
+
+M: enum clear-assoc seq>> delete-all ;
+
+INSTANCE: enum assoc

core/bootstrap/compiler/compiler.factor

@@ -14,13 +14,7 @@ IN: bootstrap.compiler
     "alien.remote-control" require
 ] unless
 
-"cpu." cpu append require
+"cpu." cpu word-name append require
-
-: enable-compiler ( -- )
-    [ optimized-recompile-hook ] recompile-hook set-global ;
-
-: disable-compiler ( -- )
-    [ default-recompile-hook ] recompile-hook set-global ;
 
 enable-compiler
 

core/bootstrap/image/image.factor

@@ -12,7 +12,8 @@ io.encodings.binary ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
-    cpu dup "ppc" = [ os "-" rot 3append ] when ;
+    cpu word-name
+    dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
 
 : boot-image-name ( arch -- string )
     "boot." swap ".image" 3append ;
@@ -55,7 +56,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 +135,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 +165,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 +176,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 +223,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 , ]
+                    [ word-vocabulary , ]
+                    [ word-def , ]
+                    [ word-props , ]
+                } cleave
+                f ,
                 0 , ! count
                 0 , ! xt
                 0 , ! code
                 0 , ! profiling
-    ] { } make
+            ] { } make [ ' ] map
+        ] bi
         \ word type-number object tag-number
         [ emit-seq ] emit-object
-    swap objects get set-at ;
+    ] 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 +292,10 @@ M: string '
     length 0 assert= ;
 
 : emit-dummy-array ( obj type -- ptr )
-    swap assert-empty
+    [ assert-empty ] [
         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 +304,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 prefix [ ' ] 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 +336,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 +353,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 +432,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/layouts/layouts.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math words kernel alien byte-arrays
 hashtables vectors strings sbufs arrays bit-arrays
-float-arrays quotations assocs layouts classes.tuple.private ;
+float-arrays quotations assocs layouts classes.tuple.private
+kernel.private ;
 
 BIN: 111 tag-mask set
 8 num-tags set
@@ -15,6 +16,7 @@ H{
     { bignum      BIN: 001 }
     { tuple       BIN: 010 }
     { object      BIN: 011 }
+    { hi-tag      BIN: 011 }
     { ratio       BIN: 100 }
     { float       BIN: 101 }
     { complex     BIN: 110 }

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
@@ -30,6 +31,7 @@ crossref off
 "syntax" vocab vocab-words bootstrap-syntax set
 H{ } clone dictionary set
 H{ } clone changed-words set
+H{ } clone forgotten-definitions set
 H{ } clone root-cache set
 H{ } clone source-files set
 H{ } clone update-map set
@@ -100,42 +102,81 @@ num-types get f <array> builtins set
 } [ create-vocab drop ] each
 
 ! Builtin classes
-: builtin-predicate-quot ( class -- quot )
+: lo-tag-eq-quot ( n -- quot )
+    [ \ tag , , \ eq? , ] [ ] make ;
+
+: hi-tag-eq-quot ( n -- quot )
     [
-        "type" word-prop dup
+        [ dup tag ] % \ hi-tag tag-number , \ eq? ,
-        \ tag-mask get < \ tag \ type ? , , \ eq? ,
+        [ [ hi-tag ] % , \ eq? , ] [ ] make ,
+        [ drop f ] ,
+        \ if ,
     ] [ ] make ;
 
+: builtin-predicate-quot ( class -- quot )
+    "type" word-prop
+    dup tag-mask get <
+    [ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
+
 : define-builtin-predicate ( class -- )
-    dup
+    dup builtin-predicate-quot define-predicate ;
-    dup builtin-predicate-quot define-predicate
-    predicate-word make-inline ;
 
 : 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 ;
+    [ f f builtin-class define-class ]
+    tri ;
 
 : 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
+    >r [ define-builtin-predicate ] keep
-    dup register-builtin
-    dup f f builtin-class define-class
-    dup define-builtin-predicate
     r> define-builtin-slots ;
 
-! Forward definitions
+"fixnum" "math" create register-builtin
-"object" "kernel" create t "class" set-word-prop
+"bignum" "math" create register-builtin
-"object" "kernel" create union-class "metaclass" set-word-prop
+"tuple" "kernel" create register-builtin
+"ratio" "math" create register-builtin
+"float" "math" create register-builtin
+"complex" "math" create register-builtin
+"f" "syntax" lookup register-builtin
+"array" "arrays" create register-builtin
+"wrapper" "kernel" create register-builtin
+"float-array" "float-arrays" create register-builtin
+"callstack" "kernel" create register-builtin
+"string" "strings" create register-builtin
+"bit-array" "bit-arrays" create register-builtin
+"quotation" "quotations" create register-builtin
+"dll" "alien" create register-builtin
+"alien" "alien" create register-builtin
+"word" "words" create register-builtin
+"byte-array" "byte-arrays" create register-builtin
+"tuple-layout" "classes.tuple.private" create register-builtin
 
-"null" "kernel" create drop
+! Catch-all class for providing a default method.
+"object" "kernel" create
+[ f builtins get [ ] subset union-class define-class ]
+[ [ drop t ] "predicate" set-word-prop ]
+bi
+
+"object?" "kernel" vocab-words delete-at
+
+! Class of objects with object tag
+"hi-tag" "kernel.private" create
+builtins get num-tags get tail define-union-class
+
+! Empty class with no instances
+"null" "kernel" create
+[ f { } union-class define-class ]
+[ [ drop f ] "predicate" set-word-prop ]
+bi
+
+"null?" "kernel" vocab-words delete-at
 
 "fixnum" "math" create { } define-builtin
 "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@@ -324,44 +365,28 @@ define-builtin
     }
 } define-builtin
 
-"tuple" "kernel" create { } define-builtin
+"tuple" "kernel" create {
-
+    [ { } define-builtin ]
-"tuple" "kernel" lookup
+    [ { "delegate" } "slot-names" set-word-prop ]
-{
+    [ define-tuple-layout ]
+    [
+        {
             {
                 { "object" "kernel" }
                 "delegate"
                 { "delegate" "kernel" }
                 { "set-delegate" "kernel" }
             }
-}
+        }
-define-tuple-slots
+        [ drop ] [ generate-tuple-slots ] 2bi
-
+        [ "slots" set-word-prop ]
-"tuple" "kernel" lookup define-tuple-layout
+        [ define-slots ]
-
+        2bi
-! Define general-t type, which is any object that is not f.
+    ]
-"general-t" "kernel" create
+} cleave
-f "f" "syntax" lookup builtins get remove [ ] subset union-class
-define-class
 
 "f" "syntax" create [ not ] "predicate" set-word-prop
-"f?" "syntax" create "syntax" vocab-words delete-at
+"f?" "syntax" vocab-words delete-at
-
-"general-t" "kernel" create [ ] "predicate" set-word-prop
-"general-t?" "kernel" create "syntax" vocab-words delete-at
-
-! Catch-all class for providing a default method.
-"object" "kernel" create [ drop t ] "predicate" set-word-prop
-"object" "kernel" create
-f builtins get [ ] subset union-class define-class
-
-! Class of objects with object tag
-"hi-tag" "classes.private" create
-f builtins get num-tags get tail union-class define-class
-
-! Null class with no instances.
-"null" "kernel" create [ drop f ] "predicate" set-word-prop
-"null" "kernel" create f { } union-class define-class
 
 ! Create special tombstone values
 "tombstone" "hashtables.private" create
@@ -495,8 +520,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 +541,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 -- )
@@ -629,7 +656,6 @@ dup tuple-layout [ <tuple-boa> ] curry define
     { "code-room" "memory" }
     { "os-env" "system" }
     { "millis" "system" }
-    { "type" "kernel.private" }
     { "tag" "kernel.private" }
     { "modify-code-heap" "compiler.units" }
     { "dlopen" "alien" }
@@ -701,7 +727,6 @@ dup tuple-layout [ <tuple-boa> ] curry define
     { "(sleep)" "threads.private" }
     { "<float-array>" "float-arrays" }
     { "<tuple-boa>" "classes.tuple.private" }
-    { "class-hash" "kernel.private" }
     { "callstack>array" "kernel" }
     { "innermost-frame-quot" "kernel.private" }
     { "innermost-frame-scan" "kernel.private" }

core/bootstrap/stage1.factor

@@ -19,7 +19,6 @@ vocabs.loader system debugger continuations ;
         ! Rehash hashtables, since bootstrap.image creates them
         ! using the host image's hashing algorithms
         [ hashtable? ] instances [ rehash ] each
-
         boot
     ] %
 

core/bootstrap/stage2.factor

@@ -11,7 +11,7 @@ IN: bootstrap.stage2
 SYMBOL: bootstrap-time
 
 : default-image-name ( -- string )
-    vm file-name windows? [ "." split1 drop ] when
+    vm file-name os windows? [ "." split1 drop ] when
     ".image" append resource-path ;
 
 : do-crossref ( -- )
@@ -65,8 +65,8 @@ parse-command-line
 "-no-crossref" cli-args member? [ do-crossref ] unless
 
 ! Set dll paths
-wince? [ "windows.ce" require ] when
+os wince? [ "windows.ce" require ] when
-winnt? [ "windows.nt" require ] when
+os winnt? [ "windows.nt" require ] when
 
 "deploy-vocab" get [
     "stage2: deployment mode" print

core/bootstrap/syntax.factor

@@ -43,6 +43,7 @@ IN: bootstrap.syntax
     "PRIMITIVE:"
     "PRIVATE>"
     "SBUF\""
+    "SINGLETON:"
     "SYMBOL:"
     "TUPLE:"
     "T{"
@@ -66,6 +67,7 @@ IN: bootstrap.syntax
     "CS{"
     "<<"
     ">>"
+    "call-next-method"
 } [ "syntax" create drop ] each
 
 "t" "syntax" lookup define-symbol

core/classes/algebra/algebra-tests.factor

@@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes classes.algebra
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units growable
-random inference effects ;
+random inference effects kernel.private ;
 
 : class= [ class< ] 2keep swap class< and ;
 
@@ -23,8 +23,8 @@ random inference effects ;
 [ t ] [ number    object   number class-and* ] unit-test
 [ t ] [ object    number   number class-and* ] unit-test
 [ t ] [ slice     reversed null   class-and* ] unit-test
-[ t ] [ general-t \ f      null   class-and* ] unit-test
+[ t ] [ \ f class-not \ f      null   class-and* ] unit-test
-[ t ] [ general-t \ f      object class-or*  ] unit-test
+[ t ] [ \ f class-not \ f      object class-or*  ] unit-test
 
 TUPLE: first-one ;
 TUPLE: second-one ;
@@ -96,7 +96,7 @@ UNION: z1 b1 c1 ;
 
 [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
 
-[ f ] [ growable hi-tag classes-intersect? ] unit-test
+[ f ] [ growable \ hi-tag classes-intersect? ] unit-test
 
 [ t ] [
     growable tuple sequence class-and class<

core/classes/algebra/algebra.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes combinators accessors sequences arrays
 vectors assocs namespaces words sorting layouts math hashtables
-;
+kernel.private ;
 IN: classes.algebra
 
 : 2cache ( key1 key2 assoc quot -- value )
@@ -138,10 +138,10 @@ C: <anonymous-complement> anonymous-complement
     members>> [ class-and ] with map <anonymous-union> ;
 
 : left-anonymous-intersection-and ( first second -- class )
-    >r members>> r> add <anonymous-intersection> ;
+    >r members>> r> suffix <anonymous-intersection> ;
 
 : right-anonymous-intersection-and ( first second -- class )
-    members>> swap add <anonymous-intersection> ;
+    members>> swap suffix <anonymous-intersection> ;
 
 : (class-and) ( first second -- class )
     {
@@ -158,10 +158,10 @@ C: <anonymous-complement> anonymous-complement
     } cond ;
 
 : left-anonymous-union-or ( first second -- class )
-    >r members>> r> add <anonymous-union> ;
+    >r members>> r> suffix <anonymous-union> ;
 
 : right-anonymous-union-or ( first second -- class )
-    members>> swap add <anonymous-union> ;
+    members>> swap suffix <anonymous-union> ;
 
 : (class-or) ( first second -- class )
     {
@@ -211,12 +211,6 @@ C: <anonymous-complement> anonymous-complement
 : flatten-class ( class -- assoc )
     [ (flatten-class) ] H{ } make-assoc ;
 
-: class-hashes ( class -- seq )
-    flatten-class keys [
-        dup builtin-class?
-        [ "type" word-prop ] [ hashcode ] if
-    ] map ;
-
 : flatten-builtin-class ( class -- assoc )
     flatten-class [
         dup tuple class< [ 2drop tuple tuple ] when
@@ -229,5 +223,5 @@ C: <anonymous-complement> anonymous-complement
 : class-tags ( class -- tag/f )
     class-types [
         dup num-tags get >=
-        [ drop object tag-number ] when
+        [ drop \ hi-tag tag-number ] when
     ] map prune ;

core/classes/classes-docs.factor

@@ -21,7 +21,6 @@ $nl
     { { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } }
     { { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } }
     { { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } }
-    { { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } }
 }
 "The set of class predicate words is a class:"
 { $subsection predicate }
@@ -47,6 +46,7 @@ $nl
 "Other sorts of classes:"
 { $subsection "builtin-classes" }
 { $subsection "unions" }
+{ $subsection "singletons" }
 { $subsection "mixins" }
 { $subsection "predicates" }
 "Classes can be inspected and operated upon:"

core/classes/classes-tests.factor

@@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes
 classes.private classes.union classes.mixin classes.predicate
 classes.algebra vectors definitions source-files
-compiler.units ;
+compiler.units kernel.private ;
 IN: classes.tests
 
 ! DEFER: bah
@@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
 ! Test generic see and parsing
 [ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
 [ [ \ bah see ] with-string-writer ] unit-test
+
+[ t ] [ 3 object instance? ] unit-test
+[ t ] [ 3 fixnum instance? ] unit-test
+[ f ] [ 3 float instance? ] unit-test
+[ t ] [ 3 number instance? ] unit-test
+[ f ] [ 3 null instance? ] unit-test
+[ t ] [ "hi" \ hi-tag instance? ] unit-test

core/classes/classes.factor

@@ -25,9 +25,11 @@ SYMBOL: class-or-cache
     class-and-cache get clear-assoc
     class-or-cache get clear-assoc ;
 
-PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
-
 SYMBOL: update-map
+
+PREDICATE: class < word
+    "class" word-prop ;
+
 SYMBOL: builtins
 
 PREDICATE: builtin-class < class
@@ -58,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     dup class? [ "superclass" word-prop ] [ drop f ] if ;
 
 : superclasses ( class -- supers )
-    [ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
+    [ superclass ] follow reverse ;
 
 : members ( class -- seq )
     #! Output f for non-classes to work with algebra code
@@ -72,7 +74,7 @@ M: word reset-class drop ;
 
 ! update-map
 : class-uses ( class -- seq )
-    dup members swap superclass [ add ] when* ;
+    [ members ] [ superclass ] bi [ suffix ] when* ;
 
 : class-usages ( class -- assoc )
     [ update-map get at ] closure ;
@@ -83,7 +85,7 @@ M: word reset-class drop ;
 : update-map- ( class -- )
     dup class-uses update-map get remove-vertex ;
 
-: define-class-props ( superclass members metaclass -- assoc )
+: make-class-props ( superclass members metaclass -- assoc )
     [
         [ dup [ bootstrap-word ] when "superclass" set ]
         [ [ bootstrap-word ] map "members" set ]
@@ -92,12 +94,16 @@ M: word reset-class drop ;
     ] H{ } make-assoc ;
 
 : (define-class) ( word props -- )
-    over reset-class
+    >r
-    over deferred? [ over define-symbol ] when
+    dup reset-class
-    >r dup word-props r> union over set-word-props
+    dup deferred? [ dup define-symbol ] when
-    dup predicate-word 2dup 1quotation "predicate" set-word-prop
+    dup word-props
-    over "predicating" set-word-prop
+    r> union over set-word-props
-    t "class" set-word-prop ;
+    dup predicate-word
+    [ 1quotation "predicate" set-word-prop ]
+    [ swap "predicating" set-word-prop ]
+    [ drop t "class" set-word-prop ]
+    2tri ;
 
 PRIVATE>
 
@@ -105,25 +111,28 @@ GENERIC: update-class ( class -- )
 
 M: class update-class drop ;
 
-: update-classes ( assoc -- )
-    [ drop update-class ] assoc-each ;
-
 GENERIC: update-methods ( assoc -- )
 
+: update-classes ( class -- )
+    class-usages
+    [ [ drop update-class ] assoc-each ]
+    [ update-methods ]
+    bi ;
+
 : define-class ( word superclass members metaclass -- )
     #! If it was already a class, update methods after.
     reset-caches
-    define-class-props
+    make-class-props
     [ drop update-map- ]
-    [ (define-class) ] [
+    [ (define-class) ]
-        drop
+    [ drop update-map+ ]
-        [ update-map+ ] [
+    2tri ;
-            class-usages
-            [ update-classes ]
-            [ update-methods ] bi
-        ] bi
-    ] 2tri ;
 
-GENERIC: class ( object -- class ) inline
+GENERIC: class ( object -- class )
 
-M: object class type type>class ;
+M: hi-tag class hi-tag type>class ;
+
+M: object class tag type>class ;
+
+: instance? ( obj class -- ? )
+    "predicate" word-prop call ;

core/classes/mixin/mixin.factor

@@ -7,7 +7,7 @@ IN: classes.mixin
 PREDICATE: mixin-class < union-class "mixin" word-prop ;
 
 M: mixin-class reset-class
-    { "metaclass" "members" "mixin" } reset-props ;
+    { "class" "metaclass" "members" "mixin" } reset-props ;
 
 : redefine-mixin-class ( class members -- )
     dupd define-union-class
@@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ;
     swap redefine-mixin-class ; inline
 
 : add-mixin-instance ( class mixin -- )
-    [ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ;
+    [ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
 
 : remove-mixin-instance ( class mixin -- )
     [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;

core/classes/predicate/predicate.factor

@@ -14,11 +14,19 @@ PREDICATE: predicate-class < class
     ] [ ] make ;
 
 : define-predicate-class ( class superclass definition -- )
-    >r dupd f predicate-class define-class
+    [ drop f predicate-class define-class ]
-    r> dupd "predicate-definition" set-word-prop
+    [ nip "predicate-definition" set-word-prop ]
-    dup predicate-quot define-predicate ;
+    [
+        2drop
+        [ dup predicate-quot define-predicate ]
+        [ update-classes ]
+        bi
+    ] 3tri ;
 
 M: predicate-class reset-class
     {
-        "metaclass" "predicate-definition" "superclass"
+        "class"
+        "metaclass"
+        "predicate-definition"
+        "superclass"
     } reset-props ;

core/classes/singleton/singleton-docs.factor

@@ -0,0 +1,28 @@
+USING: help.markup help.syntax kernel words ;
+IN: classes.singleton
+
+ARTICLE: "singletons" "Singleton classes"
+"A singleton is a class with only one instance and with no state.  Methods may dispatch off of singleton classes."
+{ $subsection POSTPONE: SINGLETON: }
+{ $subsection define-singleton-class } ;
+
+HELP: SINGLETON:
+{ $syntax "SINGLETON: class"
+} { $values
+    { "class" "a new singleton to define" }
+} { $description
+    "Defines a new predicate class whose superclass is " { $link word } ".  Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves.  Methods may be defined on a singleton."
+} { $examples
+    { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
+} { $see-also
+    POSTPONE: PREDICATE:
+} ;
+
+HELP: define-singleton-class
+{ $values { "word" "a new word" } }
+{ $description
+    "Defines a newly created word to be a singleton class." } ;
+
+{ POSTPONE: SINGLETON: define-singleton-class } related-words
+
+ABOUT: "singletons"

core/classes/singleton/singleton-tests.factor

@@ -0,0 +1,12 @@
+USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
+IN: classes.singleton.tests
+
+[ ] [ SINGLETON: bzzt ] unit-test
+[ t ] [ bzzt bzzt? ] unit-test
+[ t ] [ bzzt bzzt eq? ] unit-test
+GENERIC: zammo ( obj -- str )
+[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
+[ "yes!" ] [ bzzt zammo ] unit-test
+[ ] [ SINGLETON: omg ] unit-test
+[ t ] [ omg singleton-class? ] unit-test
+[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test

core/classes/singleton/singleton.factor

@@ -0,0 +1,11 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.predicate kernel sequences words ;
+IN: classes.singleton
+
+PREDICATE: singleton-class < predicate-class
+    [ "predicate-definition" word-prop ]
+    [ [ eq? ] curry ] bi sequence= ;
+
+: define-singleton-class ( word -- )
+    \ word over [ eq? ] curry define-predicate-class ;

core/classes/tuple/tuple-docs.factor

@@ -153,26 +153,6 @@ 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
-{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
-{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
-
 HELP: tuple
 { $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
 $nl

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 ;
@@ -62,13 +62,13 @@ C: <point> point
 [ 200 ] [ "p" get y>> ] unit-test
 [ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
 
-"p" get 300 ">>z" "accessors" lookup execute drop
+[ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
 
 [ 4 ] [ "p" get tuple-size ] unit-test
 
 [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
 
-"IN: classes.tuple.tests TUPLE: point z y ;" eval
+[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
 
 [ 3 ] [ "p" get tuple-size ] unit-test
 
@@ -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,125 @@ 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 ;
+
+C: <test2> test2
+
+"a" "b" <test2> "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 ;
 
@@ -389,3 +511,45 @@ USE: vocabs
         define-tuple-class
     ] with-compilation-unit
 ] unit-test
+
+[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with
+
+! Accessors not being forgotten...
+[ [ ] ] [
+    "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
+    <string-reader>
+    "forget-accessors-test" parse-stream
+] unit-test
+
+[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
+
+: accessor-exists? ( class name -- ? )
+    >r "forget-accessors-test" "classes.tuple.tests" lookup r>
+    ">>" append "accessors" lookup method >boolean ;
+
+[ t ] [ "x" accessor-exists? ] unit-test
+[ t ] [ "y" accessor-exists? ] unit-test
+[ t ] [ "z" accessor-exists? ] unit-test
+
+[ [ ] ] [
+    "IN: classes.tuple.tests GENERIC: forget-accessors-test"
+    <string-reader>
+    "forget-accessors-test" parse-stream
+] unit-test
+
+[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
+
+[ f ] [ "x" accessor-exists? ] unit-test
+[ f ] [ "y" accessor-exists? ] unit-test
+[ f ] [ "z" accessor-exists? ] unit-test
+
+TUPLE: another-forget-accessors-test ;
+
+
+[ [ ] ] [
+    "IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
+    <string-reader>
+    "another-forget-accessors-test" parse-stream
+] unit-test
+
+[ t ] [ \ another-forget-accessors-test class? ] unit-test

core/classes/tuple/tuple.factor

@@ -19,12 +19,20 @@ ERROR: no-tuple-class class ;
 
 GENERIC: tuple-layout ( object -- layout )
 
-M: class tuple-layout "layout" word-prop ;
+M: tuple-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,31 @@ PRIVATE>
     [ drop ] [ no-tuple-class ] if ;
 
 : tuple>array ( tuple -- array )
-    dup tuple-layout
+    prepare-tuple>array
-    [ layout-size swap [ array-nth ] curry map ] keep
+    >r copy-tuple-slots r>
-    layout-class add* ;
+    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,72 +103,87 @@ 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> ;
 
 : define-tuple-layout ( class -- )
     dup make-tuple-layout "layout" set-word-prop ;
 
-: removed-slots ( class newslots -- seq )
+: all-slot-names ( class -- slots )
-    swap slot-names seq-diff ;
+    superclasses [ slot-names ] map concat \ class prefix ;
 
-: forget-slots ( class slots -- )
+: compute-slot-permutation ( class old-slot-names -- permutation )
-    dupd removed-slots [
+    >r all-slot-names r> [ index ] curry map ;
-        [ reader-word forget-method ]
-        [ writer-word forget-method ] 2bi
-    ] with each ;
 
-: permutation ( seq1 seq2 -- permutation )
+: apply-slot-permutation ( old-values permutation -- new-values )
-    swap [ index ] curry map ;
+    [ [ swap ?nth ] [ drop f ] if* ] with map ;
 
-: reshape-tuple ( oldtuple permutation -- newtuple )
+: permute-slots ( old-values -- new-values )
-    >r tuple>array 2 cut r>
+    dup first dup outdated-tuples get at
-    [ [ swap ?nth ] [ drop f ] if* ] with map
+    compute-slot-permutation
-    append >tuple ;
+    apply-slot-permutation ;
 
-: reshape-tuples ( class superclass newslots -- )
+: change-tuple ( tuple quot -- newtuple )
-    nip
+    >r tuple>array r> call >tuple ; inline
-    >r dup slot-names r> permutation
+
-    [
+: update-tuple ( tuple -- newtuple )
-        >r "predicate" word-prop instances dup
+    [ permute-slots ] change-tuple ;
-        r> [ reshape-tuple ] curry map
+
-        become
+: update-tuples ( -- )
-    ] 2curry after-compilation ;
+    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 ;
+
+M: tuple-class update-class
+    [ define-tuple-layout ]
+    [ define-tuple-slots ]
+    [ 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
+    [ 2drop update-classes ]
-        class-usages keys [ tuple-class? ] subset [
+    3tri ;
-            [ define-tuple-layout ]
+
-            [ define-tuple-predicate ]
+: subclasses ( class -- classes )
-            bi
+    class-usages keys [ tuple-class? ] subset ;
-        ] each
+
-    ] 3tri ;
+: each-subclass ( class quot -- )
+    >r subclasses r> each ; inline
 
 : 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
     ]
     [ define-new-tuple-class ]
-    3tri ;
+    3bi ;
 
 : tuple-class-unchanged? ( class superclass slots -- ? )
     rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
@@ -175,20 +201,31 @@ 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-class reset-class
+    [
+        dup "slot-names" word-prop [
+            [ reader-word method forget ]
+            [ writer-word method forget ] 2bi
+        ] with each
+    ] [
+        {
+            "class"
+            "metaclass"
+            "superclass"
+            "layout"
+            "slots"
+        } reset-props
+    ] bi ;
+
 M: tuple clone
     (clone) dup delegate clone over set-delegate ;
 
 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 +233,13 @@ M: tuple hashcode*
         ] 2curry reduce
     ] recursive-hashcode ;
 
-: tuple-slots ( tuple -- seq ) tuple>array 2 tail ;
+! Deprecated
-
-! 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 )
+: delegates ( obj -- seq ) [ delegate ] follow ;
-    tuple-layout <tuple> ;
 
-M: object construct ( ... slots class -- tuple )
+: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
-    construct-empty [ swap set-slots ] keep ;
-
-M: object construct-boa ( ... class -- tuple )
-    tuple-layout <tuple-boa> ;

core/classes/union/union.factor

@@ -1,33 +1,21 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel assocs combinators classes
-generic.standard namespaces arrays math quotations ;
+namespaces arrays math quotations ;
 IN: classes.union
 
 PREDICATE: union-class < class
     "metaclass" word-prop union-class eq? ;
 
 ! Union classes for dispatch on multiple classes.
-: small-union-predicate-quot ( members -- quot )
+: union-predicate-quot ( members -- quot )
     dup empty? [
         drop [ drop f ]
     ] [
-        unclip first "predicate" word-prop swap
+        unclip "predicate" word-prop swap [
-        [ >r "predicate" word-prop [ dup ] prepend r> ]
+            "predicate" word-prop [ dup ] prepend
-        assoc-map alist>quot
+            [ drop t ]
-    ] if ;
+        ] { } map>assoc alist>quot
-
-: big-union-predicate-quot ( members -- quot )
-    [ small-union-predicate-quot ] [ dup ]
-    class-hash-dispatch-quot ;
-
-: union-predicate-quot ( members -- quot )
-    [ [ drop t ] ] { } map>assoc
-    dup length 4 <= [
-        small-union-predicate-quot
-    ] [
-        flatten-methods
-        big-union-predicate-quot
     ] if ;
 
 : define-union-predicate ( class -- )
@@ -36,7 +24,9 @@ PREDICATE: union-class < class
 M: union-class update-class define-union-predicate ;
 
 : define-union-class ( class members -- )
-    f swap union-class define-class ;
+    [ f swap union-class define-class ]
+    [ drop update-classes ]
+    2bi ;
 
 M: union-class reset-class
-    { "metaclass" "members" } reset-props ;
+    { "class" "metaclass" "members" } reset-props ;

core/combinators/combinators.factor

@@ -9,18 +9,24 @@ hashtables sorting ;
     [ call ] with each ;
 
 : cleave>quot ( seq -- quot )
-    [ [ keep ] curry ] map concat [ drop ] append ;
+    [ [ keep ] curry ] map concat [ drop ] append [ ] like ;
 
 : 2cleave ( x seq -- )
-    [ [ call ] 3keep drop ] each 2drop ;
+    [ 2keep ] each 2drop ;
 
 : 2cleave>quot ( seq -- quot )
-    [ [ 2keep ] curry ] map concat [ 2drop ] append ;
+    [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
+
+: 3cleave ( x seq -- )
+    [ 3keep ] each 3drop ;
+
+: 3cleave>quot ( seq -- quot )
+    [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
 
 : spread>quot ( seq -- quot )
     [ length [ >r ] <repetition> concat ]
     [ [ [ r> ] prepend ] map concat ] bi
-    append ;
+    append [ ] like ;
 
 : spread ( objs... seq -- )
     spread>quot call ;
@@ -43,7 +49,7 @@ ERROR: no-case ;
 : with-datastack ( stack quot -- newstack )
     datastack >r
     >r >array set-datastack r> call
-    datastack r> swap add set-datastack 2nip ; inline
+    datastack r> swap suffix set-datastack 2nip ; inline
 
 : recursive-hashcode ( n obj quot -- code )
     pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
@@ -66,7 +72,7 @@ M: hashtable hashcode*
     reverse [ no-cond ] swap alist>quot ;
 
 : linear-case-quot ( default assoc -- quot )
-    [ >r [ dupd = ] curry r> \ drop add* ] assoc-map
+    [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
     alist>quot ;
 
 : (distribute-buckets) ( buckets pair keys -- )

core/command-line/command-line.factor

@@ -47,7 +47,7 @@ SYMBOL: main-vocab-hook
     ] bind ;
 
 : ignore-cli-args? ( -- ? )
-    macosx? "run" get "ui" = and ;
+    os macosx? "run" get "ui" = and ;
 
 : script-mode ( -- )
     t "quiet" set-global

core/compiler/compiler-docs.factor

@@ -2,14 +2,21 @@ USING: generator help.markup help.syntax words io parser
 assocs words.private sequences compiler.units ;
 IN: compiler
 
+HELP: enable-compiler
+{ $description "Enables the optimizing compiler." } ;
+
+HELP: disable-compiler
+{ $description "Enables the optimizing compiler." } ;
+
 ARTICLE: "compiler-usage" "Calling the optimizing compiler"
-"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
+"Normally, new word definitions are recompiled automatically. This can be changed:"
-$nl
+{ $subsection disable-compiler }
-"The main entry point to the optimizing compiler:"
+{ $subsection enable-compiler }
+"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
 { $subsection optimized-recompile-hook }
 "Removing a word's optimized definition:"
 { $subsection decompile }
-"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ;
+"Higher-level words can be found in " { $link "compilation-units" } "." ;
 
 ARTICLE: "compiler" "Optimizing compiler"
 "Factor is a fully compiled language implementation with two distinct compilers:"

core/compiler/compiler.factor

@@ -56,5 +56,11 @@ IN: compiler
         compiled get >alist
     ] with-scope ;
 
+: enable-compiler ( -- )
+    [ optimized-recompile-hook ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+    [ default-recompile-hook ] recompile-hook set-global ;
+
 : recompile-all ( -- )
     forget-errors all-words compile ;

core/compiler/tests/intrinsics.factor

@@ -174,11 +174,6 @@ sequences.private ;
 [ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
 [ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
 
-[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
-[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
-[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
-[ t ] [ f type f [ type ] compile-call eq? ] unit-test
-
 [ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 [ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
 [ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
@@ -223,9 +218,6 @@ sequences.private ;
 
 [ t ] [ f [ f eq? ] compile-call ] unit-test
 
-! regression
-[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test
-
 ! regression
 [ 3 ] [
     100001 f <array> 3 100000 pick set-nth

core/compiler/tests/templates.factor

@@ -26,10 +26,6 @@ IN: compiler.tests
 [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
 unit-test
 
-[ { 1 2 3 } { 1 4 3 } 8 8 ]
-[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ]
-unit-test
-
 ! Test literals in either side of a shuffle
 [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
 
@@ -176,14 +172,14 @@ TUPLE: my-tuple ;
 [ 1 t ] [
     B{ 1 2 3 4 } [
         { c-ptr } declare
-        [ 0 alien-unsigned-1 ] keep type
+        [ 0 alien-unsigned-1 ] keep hi-tag
     ] compile-call byte-array type-number =
 ] unit-test
 
 [ t ] [
     B{ 1 2 3 4 } [
         { c-ptr } declare
-        0 alien-cell type
+        0 alien-cell hi-tag
     ] compile-call alien type-number =
 ] unit-test
 

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/cpu/architecture/architecture.factor

@@ -5,8 +5,6 @@ namespaces sequences layouts system hashtables classes alien
 byte-arrays bit-arrays float-arrays combinators words ;
 IN: cpu.architecture
 
-SYMBOL: compiler-backend
-
 ! A pseudo-register class for parameters spilled on the stack
 TUPLE: stack-params ;
 
@@ -26,122 +24,122 @@ GENERIC: vregs ( register-class -- regs )
 ! Load a literal (immediate or indirect)
 GENERIC# load-literal 1 ( obj vreg -- )
 
-HOOK: load-indirect compiler-backend ( obj reg -- )
+HOOK: load-indirect cpu ( obj reg -- )
 
-HOOK: stack-frame compiler-backend ( frame-size -- n )
+HOOK: stack-frame cpu ( frame-size -- n )
 
 : stack-frame* ( -- n )
     \ stack-frame get stack-frame ;
 
 ! Set up caller stack frame
-HOOK: %prologue compiler-backend ( n -- )
+HOOK: %prologue cpu ( n -- )
 
 : %prologue-later \ %prologue-later , ;
 
 ! Tear down stack frame
-HOOK: %epilogue compiler-backend ( n -- )
+HOOK: %epilogue cpu ( n -- )
 
 : %epilogue-later \ %epilogue-later , ;
 
 ! Store word XT in stack frame
-HOOK: %save-word-xt compiler-backend ( -- )
+HOOK: %save-word-xt cpu ( -- )
 
 ! Store dispatch branch XT in stack frame
-HOOK: %save-dispatch-xt compiler-backend ( -- )
+HOOK: %save-dispatch-xt cpu ( -- )
 
 M: object %save-dispatch-xt %save-word-xt ;
 
 ! Call another word
-HOOK: %call compiler-backend ( word -- )
+HOOK: %call cpu ( word -- )
 
 ! Local jump for branches
-HOOK: %jump-label compiler-backend ( label -- )
+HOOK: %jump-label cpu ( label -- )
 
 ! Test if vreg is 'f' or not
-HOOK: %jump-t compiler-backend ( label -- )
+HOOK: %jump-t cpu ( label -- )
 
-HOOK: %dispatch compiler-backend ( -- )
+HOOK: %dispatch cpu ( -- )
 
-HOOK: %dispatch-label compiler-backend ( word -- )
+HOOK: %dispatch-label cpu ( word -- )
 
 ! Return to caller
-HOOK: %return compiler-backend ( -- )
+HOOK: %return cpu ( -- )
 
 ! Change datastack height
-HOOK: %inc-d compiler-backend ( n -- )
+HOOK: %inc-d cpu ( n -- )
 
 ! Change callstack height
-HOOK: %inc-r compiler-backend ( n -- )
+HOOK: %inc-r cpu ( n -- )
 
 ! Load stack into vreg
-HOOK: %peek compiler-backend ( vreg loc -- )
+HOOK: %peek cpu ( vreg loc -- )
 
 ! Store vreg to stack
-HOOK: %replace compiler-backend ( vreg loc -- )
+HOOK: %replace cpu ( vreg loc -- )
 
 ! Box and unbox floats
-HOOK: %unbox-float compiler-backend ( dst src -- )
+HOOK: %unbox-float cpu ( dst src -- )
-HOOK: %box-float compiler-backend ( dst src -- )
+HOOK: %box-float cpu ( dst src -- )
 
 ! FFI stuff
 
 ! Is this integer small enough to appear in value template
 ! slots?
-HOOK: small-enough? compiler-backend ( n -- ? )
+HOOK: small-enough? cpu ( n -- ? )
 
 ! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? compiler-backend ( size -- ? )
+HOOK: struct-small-enough? cpu ( size -- ? )
 
 ! Do we pass explode value structs?
-HOOK: value-structs? compiler-backend ( -- ? )
+HOOK: value-structs? cpu ( -- ? )
 
 ! If t, fp parameters are shadowed by dummy int parameters
-HOOK: fp-shadows-int? compiler-backend ( -- ? )
+HOOK: fp-shadows-int? cpu ( -- ? )
 
-HOOK: %prepare-unbox compiler-backend ( -- )
+HOOK: %prepare-unbox cpu ( -- )
 
-HOOK: %unbox compiler-backend ( n reg-class func -- )
+HOOK: %unbox cpu ( n reg-class func -- )
 
-HOOK: %unbox-long-long compiler-backend ( n func -- )
+HOOK: %unbox-long-long cpu ( n func -- )
 
-HOOK: %unbox-small-struct compiler-backend ( size -- )
+HOOK: %unbox-small-struct cpu ( size -- )
 
-HOOK: %unbox-large-struct compiler-backend ( n size -- )
+HOOK: %unbox-large-struct cpu ( n size -- )
 
-HOOK: %box compiler-backend ( n reg-class func -- )
+HOOK: %box cpu ( n reg-class func -- )
 
-HOOK: %box-long-long compiler-backend ( n func -- )
+HOOK: %box-long-long cpu ( n func -- )
 
-HOOK: %prepare-box-struct compiler-backend ( size -- )
+HOOK: %prepare-box-struct cpu ( size -- )
 
-HOOK: %box-small-struct compiler-backend ( size -- )
+HOOK: %box-small-struct cpu ( size -- )
 
-HOOK: %box-large-struct compiler-backend ( n size -- )
+HOOK: %box-large-struct cpu ( n size -- )
 
 GENERIC: %save-param-reg ( stack reg reg-class -- )
 
 GENERIC: %load-param-reg ( stack reg reg-class -- )
 
-HOOK: %prepare-alien-invoke compiler-backend ( -- )
+HOOK: %prepare-alien-invoke cpu ( -- )
 
-HOOK: %prepare-var-args compiler-backend ( -- )
+HOOK: %prepare-var-args cpu ( -- )
 
 M: object %prepare-var-args ;
 
-HOOK: %alien-invoke compiler-backend ( function library -- )
+HOOK: %alien-invoke cpu ( function library -- )
 
-HOOK: %cleanup compiler-backend ( alien-node -- )
+HOOK: %cleanup cpu ( alien-node -- )
 
-HOOK: %alien-callback compiler-backend ( quot -- )
+HOOK: %alien-callback cpu ( quot -- )
 
-HOOK: %callback-value compiler-backend ( ctype -- )
+HOOK: %callback-value cpu ( ctype -- )
 
 ! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind compiler-backend ( n -- )
+HOOK: %unwind cpu ( n -- )
 
-HOOK: %prepare-alien-indirect compiler-backend ( -- )
+HOOK: %prepare-alien-indirect cpu ( -- )
 
-HOOK: %alien-indirect compiler-backend ( -- )
+HOOK: %alien-indirect cpu ( -- )
 
 M: stack-params param-reg drop ;
 
@@ -179,15 +177,15 @@ PREDICATE: inline-array < integer 32 < ;
     ] if-small-struct ;
 
 ! Alien accessors
-HOOK: %unbox-byte-array compiler-backend ( dst src -- )
+HOOK: %unbox-byte-array cpu ( dst src -- )
 
-HOOK: %unbox-alien compiler-backend ( dst src -- )
+HOOK: %unbox-alien cpu ( dst src -- )
 
-HOOK: %unbox-f compiler-backend ( dst src -- )
+HOOK: %unbox-f cpu ( dst src -- )
 
-HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 
-HOOK: %box-alien compiler-backend ( dst src -- )
+HOOK: %box-alien cpu ( dst src -- )
 
 : operand ( var -- op ) get v>operand ; inline
 

core/cpu/ppc/allot/allot.factor

@@ -32,7 +32,7 @@ IN: cpu.ppc.allot
     12 11 float tag-number ORI
     f fresh-object ;
 
-M: ppc-backend %box-float ( dst src -- )
+M: ppc %box-float ( dst src -- )
     [ v>operand ] bi@ %allot-float 12 MR ;
 
 : %allot-bignum ( #digits -- )
@@ -78,7 +78,7 @@ M: ppc-backend %box-float ( dst src -- )
         "end" resolve-label
     ] with-scope ;
 
-M: ppc-backend %box-alien ( dst src -- )
+M: ppc %box-alien ( dst src -- )
     { "end" "f" } [ define-label ] each
     0 over v>operand 0 CMPI
     "f" get BEQ

core/cpu/ppc/architecture/architecture.factor

@@ -7,8 +7,6 @@ layouts classes words.private alien combinators
 compiler.constants ;
 IN: cpu.ppc.architecture
 
-TUPLE: ppc-backend ;
-
 ! PowerPC register assignments
 ! r3-r10, r16-r31: integer vregs
 ! f0-f13: float vregs
@@ -21,14 +19,14 @@ TUPLE: ppc-backend ;
 
 : reserved-area-size
     os {
-        { "linux" [ 2 ] }
+        { linux [ 2 ] }
-        { "macosx" [ 6 ] }
+        { macosx [ 6 ] }
     } case cells ; foldable
 
 : lr-save
     os {
-        { "linux" [ 1 ] }
+        { linux [ 1 ] }
-        { "macosx" [ 2 ] }
+        { macosx [ 2 ] }
     } case cells ; foldable
 
 : param@ ( n -- x ) reserved-area-size + ; inline
@@ -44,7 +42,7 @@ TUPLE: ppc-backend ;
 
 : xt-save ( n -- i ) 2 cells - ;
 
-M: ppc-backend stack-frame ( n -- i )
+M: ppc stack-frame ( n -- i )
     local@ factor-area-size + 4 cells align ;
 
 M: temp-reg v>operand drop 11 ;
@@ -60,8 +58,8 @@ M: int-regs vregs
 M: float-regs return-reg drop 1 ;
 M: float-regs param-regs 
     drop os H{
-        { "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
+        { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
-        { "linux" { 1 2 3 4 5 6 7 8 } }
+        { linux { 1 2 3 4 5 6 7 8 } }
     } at ;
 M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
 
@@ -73,14 +71,14 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
 M: immediate load-literal
     [ v>operand ] bi@ LOAD ;
 
-M: ppc-backend load-indirect ( obj reg -- )
+M: ppc load-indirect ( obj reg -- )
     [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
     dup 0 LWZ ;
 
-M: ppc-backend %save-word-xt ( -- )
+M: ppc %save-word-xt ( -- )
     0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
 
-M: ppc-backend %prologue ( n -- )
+M: ppc %prologue ( n -- )
     0 MFLR
     1 1 pick neg ADDI
     11 1 pick xt-save STW
@@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- )
     11 1 pick next-save STW
     0 1 rot lr-save + STW ;
 
-M: ppc-backend %epilogue ( n -- )
+M: ppc %epilogue ( n -- )
     #! At the end of each word that calls a subroutine, we store
     #! the previous link register value in r0 by popping it off
     #! the stack, set the link register to the contents of r0,
@@ -104,14 +102,14 @@ M: ppc-backend %epilogue ( n -- )
 : %load-dlsym ( symbol dll register -- )
     0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
 
-M: ppc-backend %call ( label -- ) BL ;
+M: ppc %call ( label -- ) BL ;
 
-M: ppc-backend %jump-label ( label -- ) B ;
+M: ppc %jump-label ( label -- ) B ;
 
-M: ppc-backend %jump-t ( label -- )
+M: ppc %jump-t ( label -- )
     0 "flag" operand f v>operand CMPI BNE ;
 
-M: ppc-backend %dispatch ( -- )
+M: ppc %dispatch ( -- )
     [
         %epilogue-later
         0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
@@ -124,25 +122,25 @@ M: ppc-backend %dispatch ( -- )
         { +scratch+ { { f "offset" } } }
     } with-template ;
 
-M: ppc-backend %dispatch-label ( word -- )
+M: ppc %dispatch-label ( word -- )
     0 , rc-absolute-cell rel-word ;
 
-M: ppc-backend %return ( -- ) %epilogue-later BLR ;
+M: ppc %return ( -- ) %epilogue-later BLR ;
 
-M: ppc-backend %unwind drop %return ;
+M: ppc %unwind drop %return ;
 
-M: ppc-backend %peek ( vreg loc -- )
+M: ppc %peek ( vreg loc -- )
     >r v>operand r> loc>operand LWZ ;
 
-M: ppc-backend %replace
+M: ppc %replace
     >r v>operand r> loc>operand STW ;
 
-M: ppc-backend %unbox-float ( dst src -- )
+M: ppc %unbox-float ( dst src -- )
     [ v>operand ] bi@ float-offset LFD ;
 
-M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
+M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
 
-M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
+M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
 
 M: int-regs %save-param-reg drop 1 rot local@ STW ;
 
@@ -166,19 +164,19 @@ M: stack-params %save-param-reg ( stack reg reg-class -- )
     0 1 rot param@ stack-frame* + LWZ
     0 1 rot local@ STW ;
 
-M: ppc-backend %prepare-unbox ( -- )
+M: ppc %prepare-unbox ( -- )
     ! First parameter is top of stack
     3 ds-reg 0 LWZ
     ds-reg dup cell SUBI ;
 
-M: ppc-backend %unbox ( n reg-class func -- )
+M: ppc %unbox ( n reg-class func -- )
     ! Value must be in r3
     ! Call the unboxer
     f %alien-invoke
     ! Store the return value on the C stack
     over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
 
-M: ppc-backend %unbox-long-long ( n func -- )
+M: ppc %unbox-long-long ( n func -- )
     ! Value must be in r3:r4
     ! Call the unboxer
     f %alien-invoke
@@ -188,7 +186,7 @@ M: ppc-backend %unbox-long-long ( n func -- )
         4 1 rot cell + local@ STW
     ] when* ;
 
-M: ppc-backend %unbox-large-struct ( n size -- )
+M: ppc %unbox-large-struct ( n size -- )
     ! Value must be in r3
     ! Compute destination address
     4 1 roll local@ ADDI
@@ -197,7 +195,7 @@ M: ppc-backend %unbox-large-struct ( n size -- )
     ! Call the function
     "to_value_struct" f %alien-invoke ;
 
-M: ppc-backend %box ( n reg-class func -- )
+M: ppc %box ( n reg-class func -- )
     ! If the source is a stack location, load it into freg #0.
     ! If the source is f, then we assume the value is already in
     ! freg #0.
@@ -205,7 +203,7 @@ M: ppc-backend %box ( n reg-class func -- )
     over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
     r> f %alien-invoke ;
 
-M: ppc-backend %box-long-long ( n func -- )
+M: ppc %box-long-long ( n func -- )
     >r [
         3 1 pick local@ LWZ
         4 1 rot cell + local@ LWZ
@@ -215,12 +213,12 @@ M: ppc-backend %box-long-long ( n func -- )
 
 : struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
 
-M: ppc-backend %prepare-box-struct ( size -- )
+M: ppc %prepare-box-struct ( size -- )
     #! Compute target address for value struct return
     3 1 rot f struct-return@ ADDI
     3 1 0 local@ STW ;
 
-M: ppc-backend %box-large-struct ( n size -- )
+M: ppc %box-large-struct ( n size -- )
     #! If n = f, then we're boxing a returned struct
     [ swap struct-return@ ] keep
     ! Compute destination address
@@ -230,7 +228,7 @@ M: ppc-backend %box-large-struct ( n size -- )
     ! Call the function
     "box_value_struct" f %alien-invoke ;
 
-M: ppc-backend %prepare-alien-invoke
+M: ppc %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
@@ -240,20 +238,20 @@ M: ppc-backend %prepare-alien-invoke
     ds-reg 11 8 STW
     rs-reg 11 12 STW ;
 
-M: ppc-backend %alien-invoke ( symbol dll -- )
+M: ppc %alien-invoke ( symbol dll -- )
     11 %load-dlsym (%call) ;
 
-M: ppc-backend %alien-callback ( quot -- )
+M: ppc %alien-callback ( quot -- )
     3 load-indirect "c_to_factor" f %alien-invoke ;
 
-M: ppc-backend %prepare-alien-indirect ( -- )
+M: ppc %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
     3 1 cell temp@ STW ;
 
-M: ppc-backend %alien-indirect ( -- )
+M: ppc %alien-indirect ( -- )
     11 1 cell temp@ LWZ (%call) ;
 
-M: ppc-backend %callback-value ( ctype -- )
+M: ppc %callback-value ( ctype -- )
      ! Save top of data stack
      3 ds-reg 0 LWZ
      3 1 0 local@ STW
@@ -264,7 +262,7 @@ M: ppc-backend %callback-value ( ctype -- )
      ! Unbox former top of data stack to return registers
      unbox-return ;
 
-M: ppc-backend %cleanup ( alien-node -- ) drop ;
+M: ppc %cleanup ( alien-node -- ) drop ;
 
 : %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
 
@@ -272,34 +270,34 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
 
 : %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
 
-M: ppc-backend value-structs?
+M: ppc value-structs?
     #! On Linux/PPC, value structs are passed in the same way
     #! as reference structs, we just have to make a copy first.
-    linux? not ;
+    os linux? not ;
 
-M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ;
+M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
 
-M: ppc-backend small-enough? ( n -- ? ) -32768 32767 between? ;
+M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
 
-M: ppc-backend struct-small-enough? ( size -- ? ) drop f ;
+M: ppc struct-small-enough? ( size -- ? ) drop f ;
 
-M: ppc-backend %box-small-struct
+M: ppc %box-small-struct
     drop "No small structs" throw ;
 
-M: ppc-backend %unbox-small-struct
+M: ppc %unbox-small-struct
     drop "No small structs" throw ;
 
 ! Alien intrinsics
-M: ppc-backend %unbox-byte-array ( dst src -- )
+M: ppc %unbox-byte-array ( dst src -- )
     [ v>operand ] bi@ byte-array-offset ADDI ;
 
-M: ppc-backend %unbox-alien ( dst src -- )
+M: ppc %unbox-alien ( dst src -- )
     [ v>operand ] bi@ alien-offset LWZ ;
 
-M: ppc-backend %unbox-f ( dst src -- )
+M: ppc %unbox-f ( dst src -- )
     drop 0 swap v>operand LI ;
 
-M: ppc-backend %unbox-any-c-ptr ( dst src -- )
+M: ppc %unbox-any-c-ptr ( dst src -- )
     { "is-byte-array" "end" "start" } [ define-label ] each
     ! Address is computed in R12
     0 12 LI

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -94,14 +94,14 @@ IN: cpu.ppc.intrinsics
 } define-intrinsics
 
 : fixnum-register-op ( op -- pair )
-    [ "out" operand "y" operand "x" operand ] swap add H{
+    [ "out" operand "y" operand "x" operand ] swap suffix H{
         { +input+ { { f "x" } { f "y" } } }
         { +scratch+ { { f "out" } } }
         { +output+ { "out" } }
     } 2array ;
 
 : fixnum-value-op ( op -- pair )
-    [ "out" operand "x" operand "y" operand ] swap add H{
+    [ "out" operand "x" operand "y" operand ] swap suffix H{
         { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
         { +scratch+ { { f "out" } } }
         { +output+ { "out" } }
@@ -205,11 +205,11 @@ IN: cpu.ppc.intrinsics
 } define-intrinsic
 
 : fixnum-register-jump ( op -- pair )
-    [ "x" operand 0 "y" operand CMP ] swap add
+    [ "x" operand 0 "y" operand CMP ] swap suffix
     { { f "x" } { f "y" } } 2array ;
 
 : fixnum-value-jump ( op -- pair )
-    [ 0 "x" operand "y" operand CMPI ] swap add
+    [ 0 "x" operand "y" operand CMPI ] swap suffix
     { { f "x" } { [ small-tagged? ] "y" } } 2array ;
 
 : define-fixnum-jump ( word op -- )
@@ -336,7 +336,7 @@ IN: cpu.ppc.intrinsics
 } define-intrinsic
 
 : define-float-op ( word op -- )
-    [ "z" operand "x" operand "y" operand ] swap add H{
+    [ "z" operand "x" operand "y" operand ] swap suffix H{
         { +input+ { { float "x" } { float "y" } } }
         { +scratch+ { { float "z" } } }
         { +output+ { "z" } }
@@ -352,7 +352,7 @@ IN: cpu.ppc.intrinsics
 ] each
 
 : define-float-jump ( word op -- )
-    [ "x" operand 0 "y" operand FCMPU ] swap add
+    [ "x" operand 0 "y" operand FCMPU ] swap suffix
     { { float "x" } { float "y" } } define-if-intrinsic ;
 
 {
@@ -402,55 +402,6 @@ IN: cpu.ppc.intrinsics
     { +output+ { "out" } }
 } define-intrinsic
 
-\ type [
-    "end" define-label
-    ! Get the tag
-    "y" operand "obj" operand tag-mask get ANDI
-    ! Tag the tag
-    "y" operand "x" operand %tag-fixnum
-    ! Compare with object tag number (3).
-    0 "y" operand object tag-number CMPI
-    ! Jump if the object doesn't store type info in its header
-    "end" get BNE
-    ! It does store type info in its header
-    "x" operand "obj" operand header-offset LWZ
-    "end" resolve-label
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } { f "y" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
-\ class-hash [
-    "end" define-label
-    "tuple" define-label
-    "object" define-label
-    ! Get the tag
-    "y" operand "obj" operand tag-mask get ANDI
-    ! Compare with tuple tag number (2).
-    0 "y" operand tuple tag-number CMPI
-    "tuple" get BEQ
-    ! Compare with object tag number (3).
-    0 "y" operand object tag-number CMPI
-    "object" get BEQ
-    ! Tag the tag
-    "y" operand "x" operand %tag-fixnum
-    "end" get B
-    "object" get resolve-label
-    ! Load header type
-    "x" operand "obj" operand header-offset LWZ
-    "end" get B
-    "tuple" get resolve-label
-    ! Load class hash
-    "x" operand "obj" operand tuple-class-offset LWZ
-    "x" operand dup class-hash-offset LWZ
-    "end" resolve-label
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } { f "y" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
 : userenv ( reg -- )
     #! Load the userenv pointer in a register.
     "userenv" f rot %load-dlsym ;

core/cpu/ppc/ppc.factor

@@ -2,18 +2,13 @@ USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture
 namespaces alien.c-types kernel system combinators ;
 
 {
-    { [ macosx? ] [
+    { [ os macosx? ] [
         4 "longlong" c-type set-c-type-align
         4 "ulonglong" c-type set-c-type-align
+        4 "double" c-type set-c-type-align
     ] }
-    { [ linux? ] [
+    { [ os linux? ] [
         t "longlong" c-type set-c-type-stack-align?
         t "ulonglong" c-type set-c-type-stack-align?
     ] }
 } cond
-
-T{ ppc-backend } compiler-backend set-global
-
-macosx? [
-    4 "double" c-type set-c-type-align
-] when

core/cpu/x86/32/32.factor

@@ -8,23 +8,20 @@ alien.compiler combinators command-line
 compiler compiler.units io vocabs.loader accessors ;
 IN: cpu.x86.32
 
-PREDICATE: x86-32-backend < x86-backend
-    x86-backend-cell 4 = ;
-
 ! We implement the FFI for Linux, OS X and Windows all at once.
 ! OS X requires that the stack be 16-byte aligned, and we do
 ! this on all platforms, sacrificing some stack space for
 ! code simplicity.
 
-M: x86-32-backend ds-reg ESI ;
+M: x86.32 ds-reg ESI ;
-M: x86-32-backend rs-reg EDI ;
+M: x86.32 rs-reg EDI ;
-M: x86-32-backend stack-reg ESP ;
+M: x86.32 stack-reg ESP ;
-M: x86-32-backend xt-reg ECX ;
+M: x86.32 xt-reg ECX ;
-M: x86-32-backend stack-save-reg EDX ;
+M: x86.32 stack-save-reg EDX ;
 
 M: temp-reg v>operand drop EBX ;
 
-M: x86-32-backend %alien-invoke ( symbol dll -- )
+M: x86.32 %alien-invoke ( symbol dll -- )
     (CALL) rel-dlsym ;
 
 ! On x86, parameters are never passed in registers.
@@ -61,20 +58,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
 
 ! On x86, we can always use an address as an operand
 ! directly.
-M: x86-32-backend address-operand ;
+M: x86.32 address-operand ;
 
-M: x86-32-backend fixnum>slot@ 1 SHR ;
+M: x86.32 fixnum>slot@ 1 SHR ;
 
-M: x86-32-backend prepare-division CDQ ;
+M: x86.32 prepare-division CDQ ;
 
-M: x86-32-backend load-indirect
+M: x86.32 load-indirect
     0 [] MOV rc-absolute-cell rel-literal ;
 
 M: object %load-param-reg 3drop ;
 
 M: object %save-param-reg 3drop ;
 
-M: x86-32-backend %prepare-unbox ( -- )
+M: x86.32 %prepare-unbox ( -- )
     #! Move top of data stack to EAX.
     EAX ESI [] MOV
     ESI 4 SUB ;
@@ -87,7 +84,7 @@ M: x86-32-backend %prepare-unbox ( -- )
         f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-32-backend %unbox ( n reg-class func -- )
+M: x86.32 %unbox ( n reg-class func -- )
     #! The value being unboxed must already be in EAX.
     #! If n is f, we're unboxing a return value about to be
     #! returned by the callback. Otherwise, we're unboxing
@@ -96,7 +93,7 @@ M: x86-32-backend %unbox ( n reg-class func -- )
     ! Store the return value on the C stack
     over [ store-return-reg ] [ 2drop ] if ;
 
-M: x86-32-backend %unbox-long-long ( n func -- )
+M: x86.32 %unbox-long-long ( n func -- )
     (%unbox)
     ! Store the return value on the C stack
     [
@@ -104,7 +101,7 @@ M: x86-32-backend %unbox-long-long ( n func -- )
         cell + stack@ EDX MOV
     ] when* ;
 
-M: x86-32-backend %unbox-struct-2
+M: x86.32 %unbox-struct-2
     #! Alien must be in EAX.
     4 [
         EAX PUSH
@@ -115,7 +112,7 @@ M: x86-32-backend %unbox-struct-2
         EAX EAX [] MOV
     ] with-aligned-stack ;
 
-M: x86-32-backend %unbox-large-struct ( n size -- )
+M: x86.32 %unbox-large-struct ( n size -- )
     #! Alien must be in EAX.
     ! Compute destination address
     ECX ESP roll [+] LEA
@@ -147,7 +144,7 @@ M: x86-32-backend %unbox-large-struct ( n size -- )
     over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
     push-return-reg ;
 
-M: x86-32-backend %box ( n reg-class func -- )
+M: x86.32 %box ( n reg-class func -- )
     over reg-size [
         >r (%box) r> f %alien-invoke
     ] with-aligned-stack ;
@@ -165,12 +162,12 @@ M: x86-32-backend %box ( n reg-class func -- )
     EDX PUSH
     EAX PUSH ;
 
-M: x86-32-backend %box-long-long ( n func -- )
+M: x86.32 %box-long-long ( n func -- )
     8 [
         >r (%box-long-long) r> f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-32-backend %box-large-struct ( n size -- )
+M: x86.32 %box-large-struct ( n size -- )
     ! Compute destination address
     [ swap struct-return@ ] keep
     ECX ESP roll [+] LEA
@@ -183,13 +180,13 @@ M: x86-32-backend %box-large-struct ( n size -- )
         "box_value_struct" f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-32-backend %prepare-box-struct ( size -- )
+M: x86.32 %prepare-box-struct ( size -- )
     ! Compute target address for value struct return
     EAX ESP rot f struct-return@ [+] LEA
     ! Store it as the first parameter
     ESP [] EAX MOV ;
 
-M: x86-32-backend %unbox-struct-1
+M: x86.32 %unbox-struct-1
     #! Alien must be in EAX.
     4 [
         EAX PUSH
@@ -198,7 +195,7 @@ M: x86-32-backend %unbox-struct-1
         EAX EAX [] MOV
     ] with-aligned-stack ;
 
-M: x86-32-backend %box-small-struct ( size -- )
+M: x86.32 %box-small-struct ( size -- )
     #! Box a <= 8-byte struct returned in EAX:DX. OS X only.
     12 [
         PUSH
@@ -207,21 +204,21 @@ M: x86-32-backend %box-small-struct ( size -- )
         "box_small_struct" f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-32-backend %prepare-alien-indirect ( -- )
+M: x86.32 %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
     cell temp@ EAX MOV ;
 
-M: x86-32-backend %alien-indirect ( -- )
+M: x86.32 %alien-indirect ( -- )
     cell temp@ CALL ;
 
-M: x86-32-backend %alien-callback ( quot -- )
+M: x86.32 %alien-callback ( quot -- )
     4 [
         EAX load-indirect
         EAX PUSH
         "c_to_factor" f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-32-backend %callback-value ( ctype -- )
+M: x86.32 %callback-value ( ctype -- )
     ! Align C stack
     ESP 12 SUB
     ! Save top of data stack
@@ -236,7 +233,7 @@ M: x86-32-backend %callback-value ( ctype -- )
     ! Unbox EAX
     unbox-return ;
 
-M: x86-32-backend %cleanup ( alien-node -- )
+M: x86.32 %cleanup ( alien-node -- )
     #! a) If we just called an stdcall function in Windows, it
     #! cleaned up the stack frame for us. But we don't want that
     #! so we 'undo' the cleanup since we do that in %epilogue.
@@ -254,19 +251,14 @@ M: x86-32-backend %cleanup ( alien-node -- )
         }
     } cond ;
 
-M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ;
+M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
 
-windows? [
+os windows? [
     cell "longlong" c-type set-c-type-align
     cell "ulonglong" c-type set-c-type-align
-] unless
-
-windows? [
     4 "double" c-type set-c-type-align
 ] unless
 
-T{ x86-backend f 4 } compiler-backend set-global
-
 : sse2? "Intrinsic" throw ;
 
 \ sse2? [

core/cpu/x86/64/64.factor

@@ -8,14 +8,11 @@ layouts alien alien.accessors alien.compiler alien.structs slots
 splitting assocs ;
 IN: cpu.x86.64
 
-PREDICATE: amd64-backend < x86-backend
+M: x86.64 ds-reg R14 ;
-    x86-backend-cell 8 = ;
+M: x86.64 rs-reg R15 ;
-
+M: x86.64 stack-reg RSP ;
-M: amd64-backend ds-reg R14 ;
+M: x86.64 xt-reg RCX ;
-M: amd64-backend rs-reg R15 ;
+M: x86.64 stack-save-reg RSI ;
-M: amd64-backend stack-reg RSP ;
-M: amd64-backend xt-reg RCX ;
-M: amd64-backend stack-save-reg RSI ;
 
 M: temp-reg v>operand drop RBX ;
 
@@ -34,18 +31,18 @@ M: float-regs vregs
 M: float-regs param-regs
     drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
-M: amd64-backend address-operand ( address -- operand )
+M: x86.64 address-operand ( address -- operand )
     #! On AMD64, we have to load 64-bit addresses into a
     #! scratch register first. The usage of R11 here is a hack.
     #! This word can only be called right before a subroutine
     #! call, where all vregs have been flushed anyway.
     temp-reg v>operand [ swap MOV ] keep ;
 
-M: amd64-backend fixnum>slot@ drop ;
+M: x86.64 fixnum>slot@ drop ;
 
-M: amd64-backend prepare-division CQO ;
+M: x86.64 prepare-division CQO ;
 
-M: amd64-backend load-indirect ( literal reg -- )
+M: x86.64 load-indirect ( literal reg -- )
     0 [] MOV rc-relative rel-literal ;
 
 M: stack-params %load-param-reg
@@ -56,27 +53,27 @@ M: stack-params %load-param-reg
 M: stack-params %save-param-reg
     >r stack-frame* + cell + swap r> %load-param-reg ;
 
-M: amd64-backend %prepare-unbox ( -- )
+M: x86.64 %prepare-unbox ( -- )
     ! First parameter is top of stack
     RDI R14 [] MOV
     R14 cell SUB ;
 
-M: amd64-backend %unbox ( n reg-class func -- )
+M: x86.64 %unbox ( n reg-class func -- )
     ! Call the unboxer
     f %alien-invoke
     ! Store the return value on the C stack
     over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
 
-M: amd64-backend %unbox-long-long ( n func -- )
+M: x86.64 %unbox-long-long ( n func -- )
     T{ int-regs } swap %unbox ;
 
-M: amd64-backend %unbox-struct-1 ( -- )
+M: x86.64 %unbox-struct-1 ( -- )
     #! Alien must be in RDI.
     "alien_offset" f %alien-invoke
     ! Load first cell
     RAX RAX [] MOV ;
 
-M: amd64-backend %unbox-struct-2 ( -- )
+M: x86.64 %unbox-struct-2 ( -- )
     #! Alien must be in RDI.
     "alien_offset" f %alien-invoke
     ! Load second cell
@@ -84,7 +81,7 @@ M: amd64-backend %unbox-struct-2 ( -- )
     ! Load first cell
     RAX RAX [] MOV ;
 
-M: amd64-backend %unbox-large-struct ( n size -- )
+M: x86.64 %unbox-large-struct ( n size -- )
     ! Source is in RDI
     ! Load destination address
     RSI RSP roll [+] LEA
@@ -97,7 +94,7 @@ M: amd64-backend %unbox-large-struct ( n size -- )
     0 over param-reg swap return-reg
     2dup eq? [ 2drop ] [ MOV ] if ;
 
-M: amd64-backend %box ( n reg-class func -- )
+M: x86.64 %box ( n reg-class func -- )
     rot [
         rot [ 0 swap param-reg ] keep %load-param-reg
     ] [
@@ -105,19 +102,19 @@ M: amd64-backend %box ( n reg-class func -- )
     ] if*
     f %alien-invoke ;
 
-M: amd64-backend %box-long-long ( n func -- )
+M: x86.64 %box-long-long ( n func -- )
     T{ int-regs } swap %box ;
 
-M: amd64-backend struct-small-enough? ( size -- ? ) 2 cells <= ;
+M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
 
-M: amd64-backend %box-small-struct ( size -- )
+M: x86.64 %box-small-struct ( size -- )
     #! Box a <= 16-byte struct returned in RAX:RDX.
     RDI RAX MOV
     RSI RDX MOV
     RDX swap MOV
     "box_small_struct" f %alien-invoke ;
 
-M: amd64-backend %box-large-struct ( n size -- )
+M: x86.64 %box-large-struct ( n size -- )
     ! Struct size is parameter 2
     RSI over MOV
     ! Compute destination address
@@ -125,27 +122,27 @@ M: amd64-backend %box-large-struct ( n size -- )
     ! Copy the struct from the C stack
     "box_value_struct" f %alien-invoke ;
 
-M: amd64-backend %prepare-box-struct ( size -- )
+M: x86.64 %prepare-box-struct ( size -- )
     ! Compute target address for value struct return
     RAX RSP rot f struct-return@ [+] LEA
     RSP 0 [+] RAX MOV ;
 
-M: amd64-backend %prepare-var-args RAX RAX XOR ;
+M: x86.64 %prepare-var-args RAX RAX XOR ;
 
-M: amd64-backend %alien-invoke ( symbol dll -- )
+M: x86.64 %alien-invoke ( symbol dll -- )
     0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
 
-M: amd64-backend %prepare-alien-indirect ( -- )
+M: x86.64 %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
     cell temp@ RAX MOV ;
 
-M: amd64-backend %alien-indirect ( -- )
+M: x86.64 %alien-indirect ( -- )
     cell temp@ CALL ;
 
-M: amd64-backend %alien-callback ( quot -- )
+M: x86.64 %alien-callback ( quot -- )
     RDI load-indirect "c_to_factor" f %alien-invoke ;
 
-M: amd64-backend %callback-value ( ctype -- )
+M: x86.64 %callback-value ( ctype -- )
     ! Save top of data stack
     %prepare-unbox
     ! Put former top of data stack in RDI
@@ -157,9 +154,9 @@ M: amd64-backend %callback-value ( ctype -- )
     ! Unbox former top of data stack to return registers
     unbox-return ;
 
-M: amd64-backend %cleanup ( alien-node -- ) drop ;
+M: x86.64 %cleanup ( alien-node -- ) drop ;
 
-M: amd64-backend %unwind ( n -- ) drop %epilogue-later 0 RET ;
+M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
 
 USE: cpu.x86.intrinsics
 
@@ -171,8 +168,6 @@ USE: cpu.x86.intrinsics
 \ alien-signed-4 small-reg-32 define-signed-getter
 \ set-alien-signed-4 small-reg-32 define-setter
 
-T{ x86-backend f 8 } compiler-backend set-global
-
 ! The ABI for passing structs by value is pretty messed up
 << "void*" c-type clone "__stack_value" define-primitive-type
 T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>

core/cpu/x86/allot/allot.factor

@@ -46,7 +46,7 @@ IN: cpu.x86.allot
     allot-reg swap tag-number OR
     allot-reg MOV ;
 
-M: x86-backend %box-float ( dst src -- )
+M: x86 %box-float ( dst src -- )
     #! Only called by pentium4 backend, uses SSE2 instruction
     #! dest is a loc or a vreg
     float 16 [
@@ -86,7 +86,7 @@ M: x86-backend %box-float ( dst src -- )
         "end" resolve-label
     ] with-scope ;
 
-M: x86-backend %box-alien ( dst src -- )
+M: x86 %box-alien ( dst src -- )
     [
         { "end" "f" } [ define-label ] each
         dup v>operand 0 CMP

core/cpu/x86/architecture/architecture.factor

@@ -6,13 +6,11 @@ memory namespaces sequences words generator generator.registers
 generator.fixup system layouts combinators compiler.constants ;
 IN: cpu.x86.architecture
 
-TUPLE: x86-backend cell ;
+HOOK: ds-reg cpu
-
+HOOK: rs-reg cpu
-HOOK: ds-reg compiler-backend
+HOOK: stack-reg cpu
-HOOK: rs-reg compiler-backend
+HOOK: xt-reg cpu
-HOOK: stack-reg compiler-backend
+HOOK: stack-save-reg cpu
-HOOK: xt-reg compiler-backend
-HOOK: stack-save-reg compiler-backend
 
 : stack@ stack-reg swap [+] ;
 
@@ -33,34 +31,34 @@ GENERIC: push-return-reg ( reg-class -- )
 GENERIC: load-return-reg ( stack@ reg-class -- )
 GENERIC: store-return-reg ( stack@ reg-class -- )
 
-HOOK: address-operand compiler-backend ( address -- operand )
+HOOK: address-operand cpu ( address -- operand )
 
-HOOK: fixnum>slot@ compiler-backend
+HOOK: fixnum>slot@ cpu
 
-HOOK: prepare-division compiler-backend
+HOOK: prepare-division cpu
 
 M: immediate load-literal v>operand swap v>operand MOV ;
 
-M: x86-backend stack-frame ( n -- i )
+M: x86 stack-frame ( n -- i )
     3 cells + 16 align cell - ;
 
-M: x86-backend %save-word-xt ( -- )
+M: x86 %save-word-xt ( -- )
     xt-reg 0 MOV rc-absolute-cell rel-this ;
 
 : factor-area-size 4 cells ;
 
-M: x86-backend %prologue ( n -- )
+M: x86 %prologue ( n -- )
     dup cell + PUSH
     xt-reg PUSH
     stack-reg swap 2 cells - SUB ;
 
-M: x86-backend %epilogue ( n -- )
+M: x86 %epilogue ( n -- )
     stack-reg swap ADD ;
 
 : %alien-global ( symbol dll register -- )
     [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
 
-M: x86-backend %prepare-alien-invoke
+M: x86 %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
@@ -70,11 +68,11 @@ M: x86-backend %prepare-alien-invoke
     temp-reg v>operand 2 cells [+] ds-reg MOV
     temp-reg v>operand 3 cells [+] rs-reg MOV ;
 
-M: x86-backend %call ( label -- ) CALL ;
+M: x86 %call ( label -- ) CALL ;
 
-M: x86-backend %jump-label ( label -- ) JMP ;
+M: x86 %jump-label ( label -- ) JMP ;
 
-M: x86-backend %jump-t ( label -- )
+M: x86 %jump-t ( label -- )
     "flag" operand f v>operand CMP JNE ;
 
 : code-alignment ( -- n )
@@ -83,7 +81,7 @@ M: x86-backend %jump-t ( label -- )
 : align-code ( n -- )
     0 <repetition> % ;
 
-M: x86-backend %dispatch ( -- )
+M: x86 %dispatch ( -- )
     [
         %epilogue-later
         ! Load jump table base. We use a temporary register
@@ -105,27 +103,27 @@ M: x86-backend %dispatch ( -- )
         { +clobber+ { "n" } }
     } with-template ;
 
-M: x86-backend %dispatch-label ( word -- )
+M: x86 %dispatch-label ( word -- )
     0 cell, rc-absolute-cell rel-word ;
 
-M: x86-backend %unbox-float ( dst src -- )
+M: x86 %unbox-float ( dst src -- )
     [ v>operand ] bi@ float-offset [+] MOVSD ;
 
-M: x86-backend %peek [ v>operand ] bi@ MOV ;
+M: x86 %peek [ v>operand ] bi@ MOV ;
 
-M: x86-backend %replace swap %peek ;
+M: x86 %replace swap %peek ;
 
 : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
-M: x86-backend %inc-d ( n -- ) ds-reg (%inc) ;
+M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
 
-M: x86-backend %inc-r ( n -- ) rs-reg (%inc) ;
+M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
 
-M: x86-backend fp-shadows-int? ( -- ? ) f ;
+M: x86 fp-shadows-int? ( -- ? ) f ;
 
-M: x86-backend value-structs? t ;
+M: x86 value-structs? t ;
 
-M: x86-backend small-enough? ( n -- ? )
+M: x86 small-enough? ( n -- ? )
     HEX: -80000000 HEX: 7fffffff between? ;
 
 : %untag ( reg -- ) tag-mask get bitnot AND ;
@@ -143,34 +141,34 @@ M: x86-backend small-enough? ( n -- ? )
         \ stack-frame get swap -
     ] ?if ;
 
-HOOK: %unbox-struct-1 compiler-backend ( -- )
+HOOK: %unbox-struct-1 cpu ( -- )
 
-HOOK: %unbox-struct-2 compiler-backend ( -- )
+HOOK: %unbox-struct-2 cpu ( -- )
 
-M: x86-backend %unbox-small-struct ( size -- )
+M: x86 %unbox-small-struct ( size -- )
     #! Alien must be in EAX.
     cell align cell /i {
         { 1 [ %unbox-struct-1 ] }
         { 2 [ %unbox-struct-2 ] }
     } case ;
 
-M: x86-backend struct-small-enough? ( size -- ? )
+M: x86 struct-small-enough? ( size -- ? )
     { 1 2 4 8 } member?
-    os { "linux" "netbsd" "solaris" } member? not and ;
+    os { linux netbsd solaris } member? not and ;
 
-M: x86-backend %return ( -- ) 0 %unwind ;
+M: x86 %return ( -- ) 0 %unwind ;
 
 ! Alien intrinsics
-M: x86-backend %unbox-byte-array ( dst src -- )
+M: x86 %unbox-byte-array ( dst src -- )
     [ v>operand ] bi@ byte-array-offset [+] LEA ;
 
-M: x86-backend %unbox-alien ( dst src -- )
+M: x86 %unbox-alien ( dst src -- )
     [ v>operand ] bi@ alien-offset [+] MOV ;
 
-M: x86-backend %unbox-f ( dst src -- )
+M: x86 %unbox-f ( dst src -- )
     drop v>operand 0 MOV ;
 
-M: x86-backend %unbox-any-c-ptr ( dst src -- )
+M: x86 %unbox-any-c-ptr ( dst src -- )
     { "is-byte-array" "end" "start" } [ define-label ] each
     ! Address is computed in ds-reg
     ds-reg PUSH

core/cpu/x86/assembler/assembler.factor

@@ -230,7 +230,7 @@ UNION: operand register indirect ;
 
 : opcode-or ( opcode mask -- opcode' )
     swap dup array?
-    [ 1 cut* first rot bitor add ] [ bitor ] if ;
+    [ 1 cut* first rot bitor suffix ] [ bitor ] if ;
 
 : 1-operand ( op reg rex.w opcode -- )
     #! The 'reg' is not really a register, but a value for the

core/cpu/x86/intrinsics/intrinsics.factor

@@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics
     { +output+ { "in" } }
 } define-intrinsic
 
-\ type [
-    "end" define-label
-    ! Make a copy
-    "x" operand "obj" operand MOV
-    ! Get the tag
-    "x" operand tag-mask get AND
-    ! Tag the tag
-    "x" operand %tag-fixnum
-    ! Compare with object tag number (3).
-    "x" operand object tag-number tag-fixnum CMP
-    "end" get JNE
-    ! If we have equality, load type from header
-    "x" operand "obj" operand -3 [+] MOV
-    "end" resolve-label
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
-\ class-hash [
-    "end" define-label
-    "tuple" define-label
-    "object" define-label
-    ! Make a copy
-    "x" operand "obj" operand MOV
-    ! Get the tag
-    "x" operand tag-mask get AND
-    ! Tag the tag
-    "x" operand %tag-fixnum
-    ! Compare with tuple tag number (2).
-    "x" operand tuple tag-number tag-fixnum CMP
-    "tuple" get JE
-    ! Compare with object tag number (3).
-    "x" operand object tag-number tag-fixnum CMP
-    "object" get JE
-    "end" get JMP
-    "object" get resolve-label
-    ! Load header type
-    "x" operand "obj" operand header-offset [+] MOV
-    "end" get JMP
-    "tuple" get resolve-label
-    ! Load class hash
-    "x" operand "obj" operand tuple-class-offset [+] MOV
-    "x" operand dup class-hash-offset [+] MOV
-    "end" resolve-label
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
 ! Slots
 : %slot-literal-known-tag
     "obj" operand
@@ -156,7 +104,7 @@ IN: cpu.x86.intrinsics
 
 ! Fixnums
 : fixnum-op ( op hash -- pair )
-    >r [ "x" operand "y" operand ] swap add r> 2array ;
+    >r [ "x" operand "y" operand ] swap suffix r> 2array ;
 
 : fixnum-value-op ( op -- pair )
     H{
@@ -251,7 +199,7 @@ IN: cpu.x86.intrinsics
 \ fixnum- \ SUB overflow-template
 
 : fixnum-jump ( op inputs -- pair )
-    >r [ "x" operand "y" operand CMP ] swap add r> 2array ;
+    >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
 
 : fixnum-value-jump ( op -- pair )
     { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;

core/cpu/x86/sse2/sse2.factor

@@ -8,7 +8,7 @@ math.floats.private layouts quotations ;
 IN: cpu.x86.sse2
 
 : define-float-op ( word op -- )
-    [ "x" operand "y" operand ] swap add H{
+    [ "x" operand "y" operand ] swap suffix H{
         { +input+ { { float "x" } { float "y" } } }
         { +output+ { "x" } }
     } define-intrinsic ;
@@ -23,7 +23,7 @@ IN: cpu.x86.sse2
 ] each
 
 : define-float-jump ( word op -- )
-    [ "x" operand "y" operand UCOMISD ] swap add
+    [ "x" operand "y" operand UCOMISD ] swap suffix
     { { float "x" } { float "y" } } define-if-intrinsic ;
 
 {

core/debugger/debugger-docs.factor

@@ -1,6 +1,7 @@
 USING: alien arrays generic generic.math help.markup help.syntax
 kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations system debugger.private ;
+help generic.standard continuations system debugger.private
+io.files.private ;
 IN: debugger
 
 ARTICLE: "errors-assert" "Assertions"
@@ -86,7 +87,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/definitions/definitions-tests.factor

@@ -4,7 +4,7 @@ compiler.units words ;
 
 TUPLE: combination-1 ;
 
-M: combination-1 perform-combination 2drop [ ] ;
+M: combination-1 perform-combination drop [ ] define ;
 
 M: combination-1 make-default-method 2drop [ "No method" throw ] ;
 

core/generator/fixup/fixup.factor

@@ -111,7 +111,7 @@ SYMBOL: literal-table
 : add-literal ( obj -- n ) literal-table get push-new* ;
 
 : string>symbol ( str -- alien )
-    [ wince? [ string>u16-alien ] [ string>char-alien ] if ]
+    [ os wince? [ string>u16-alien ] [ string>char-alien ] if ]
     over string? [ call ] [ map ] if ;
 
 : add-dlsym-literals ( symbol dll -- )

core/generic/generic-docs.factor

@@ -37,7 +37,6 @@ $nl
 { $subsection create-method }
 "Method definitions can be looked up:"
 { $subsection method }
-{ $subsection methods }
 "A generic word contains methods; the list of methods specializing on a class can also be obtained:"
 { $subsection implementors }
 "Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
@@ -63,15 +62,6 @@ ARTICLE: "method-combination" "Custom method combination"
 "Developing a custom method combination requires that a parsing word calling " { $link define-generic } " be defined; additionally, it is a good idea to implement the definition protocol words " { $link definer } " and " { $link synopsis* } " on the class of words having this method combination, to properly support developer tools."
 $nl
 "The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation."
-$nl
-"Method combination utilities:"
-{ $subsection single-combination }
-{ $subsection class-predicates }
-{ $subsection simplify-alist }
-{ $subsection math-upgrade }
-{ $subsection object-method }
-{ $subsection error-method }
-"More quotation construction utilities can be found in " { $link "quotations" } " and " { $link "combinators-quot" } "."
 { $see-also "generic-introspection" } ;
 
 ARTICLE: "generic" "Generic words and methods"
@@ -129,10 +119,6 @@ HELP: <method>
 { $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
 { $description "Creates a new method." } ;
 
-HELP: methods
-{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
-{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
-
 HELP: order
 { $values { "generic" generic } { "seq" "a sequence of classes" } }
 { $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ;
@@ -160,4 +146,4 @@ HELP: forget-methods
 { $values { "class" class } }
 { $description "Remove all method definitions which specialize on the class." } ;
 
-{ sort-classes methods order } related-words
+{ sort-classes order } related-words

core/generic/generic-tests.factor

@@ -21,19 +21,6 @@ M: word   class-of drop "word"   ;
 [ "Hello world" ] [ 4 foobar foobar ] unit-test
 [ "Goodbye cruel world" ] [ 4 foobar ] unit-test
 
-GENERIC: bool>str ( x -- y )
-M: general-t bool>str drop "true" ;
-M: f bool>str drop "false" ;
-
-: str>bool
-    H{
-        { "true" t }
-        { "false" f }
-    } at ;
-
-[ t ] [ t bool>str str>bool ] unit-test
-[ f ] [ f bool>str str>bool ] unit-test
-
 ! Testing unions
 UNION: funnies quotation float complex ;
 
@@ -51,16 +38,6 @@ M: very-funny gooey sq ;
 
 [ 0.25 ] [ 0.5 gooey ] unit-test
 
-DEFER: complement-test
-FORGET: complement-test
-GENERIC: complement-test ( x -- y )
-
-M: f         complement-test drop "f" ;
-M: general-t complement-test drop "general-t" ;
-
-[ "general-t" ] [ 5 complement-test ] unit-test
-[ "f" ] [ f complement-test ] unit-test
-
 GENERIC: empty-method-test ( x -- y )
 M: object empty-method-test ;
 TUPLE: for-arguments-sake ;
@@ -171,37 +148,6 @@ M: f tag-and-f 4 ;
 
 [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
 
-! define-class hashing issue
-TUPLE: debug-combination ;
-
-M: debug-combination make-default-method
-    2drop [ "Oops" throw ] ;
-
-M: debug-combination perform-combination
-    drop
-    order [ dup class-hashes ] { } map>assoc sort-keys
-    1quotation ;
-
-SYMBOL: redefinition-test-generic
-
-[
-    redefinition-test-generic
-    T{ debug-combination }
-    define-generic
-] with-compilation-unit
-
-TUPLE: redefinition-test-tuple ;
-
-"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
-
-[ t ] [
-    [
-        redefinition-test-generic ,
-        "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
-        redefinition-test-generic ,
-    ] { } make all-equal?
-] unit-test
-
 ! Issues with forget
 GENERIC: generic-forget-test-1
 

core/generic/generic.factor

@@ -6,16 +6,7 @@ classes.algebra quotations arrays vocabs effects ;
 IN: generic
 
 ! Method combination protocol
-GENERIC: perform-combination ( word combination -- quot )
+GENERIC: perform-combination ( word combination -- )
-
-M: object perform-combination
-    #! We delay the invalid method combination error for a
-    #! reason. If we call forget-vocab on a vocabulary which
-    #! defines a method combination, a generic using this
-    #! method combination, and a method on the generic, and the
-    #! method combination is forgotten first, then forgetting
-    #! the method will throw an error. We don't want that.
-    nip [ "Invalid method combination" throw ] curry [ ] like ;
 
 GENERIC: make-default-method ( generic combination -- method )
 
@@ -25,8 +16,9 @@ PREDICATE: generic < word
 M: generic definition drop f ;
 
 : make-generic ( word -- )
-    dup { "unannotated-def" } reset-props
+    [ { "unannotated-def" } reset-props ]
-    dup dup "combination" word-prop perform-combination define ;
+    [ dup "combination" word-prop perform-combination ]
+    bi ;
 
 : method ( class generic -- method/f )
     "methods" word-prop at ;
@@ -37,10 +29,17 @@ PREDICATE: method-spec < pair
 : order ( generic -- seq )
     "methods" word-prop keys sort-classes ;
 
-: methods ( word -- assoc )
+: next-method-class ( class generic -- class/f )
-    "methods" word-prop
+    order [ class< ] with subset reverse dup length 1 =
-    [ keys sort-classes ] keep
+    [ drop f ] [ second ] if ;
-    [ dupd at ] curry { } map>assoc ;
+
+: next-method ( class generic -- class/f )
+    [ next-method-class ] keep method ;
+
+GENERIC: next-method-quot ( class generic -- quot )
+
+: (call-next-method) ( class generic -- )
+    next-method-quot call ;
 
 TUPLE: check-method class generic ;
 
@@ -62,6 +61,9 @@ PREDICATE: method-body < word
 M: method-body stack-effect
     "method-generic" word-prop stack-effect ;
 
+M: method-body crossref?
+    drop t ;
+
 : method-word-props ( class generic -- assoc )
     [
         "method-generic" set
@@ -104,14 +106,6 @@ M: method-spec definer
 M: method-spec definition
     first2 method definition ;
 
-: forget-method ( class generic -- )
-    dup generic? [
-        [ delete-at* ] with-methods
-        [ forget-word ] [ drop ] if
-    ] [
-        2drop
-    ] if ;
-
 M: method-spec forget*
     first2 method forget* ;
 
@@ -120,9 +114,15 @@ M: method-body definer
 
 M: method-body forget*
     dup "forgotten" word-prop [ drop ] [
-        dup "method-class" word-prop
+        [
-        over "method-generic" word-prop forget-method
+            [   "method-class" word-prop ]
-        t "forgotten" set-word-prop
+            [ "method-generic" word-prop ] bi
+            dup generic? [
+                [ delete-at* ] with-methods
+                [ call-next-method ] [ drop ] if
+            ] [ 2drop ] if
+        ]
+        [ t "forgotten" set-word-prop ] bi
     ] if ;
 
 : implementors* ( classes -- words )
@@ -135,12 +135,13 @@ M: method-body forget*
     dup associate implementors* ;
 
 : forget-methods ( class -- )
-    [ implementors ] keep [ swap 2array ] curry map forget-all ;
+    [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
 
 M: class forget* ( class -- )
-    dup forget-methods
+    [ forget-methods ]
-    dup update-map-
+    [ update-map- ]
-    forget-word ;
+    [ call-next-method ]
+    tri ;
 
 M: assoc update-methods ( assoc -- )
     implementors* [ make-generic ] each ;
@@ -156,11 +157,15 @@ M: assoc update-methods ( assoc -- )
     ] if ;
 
 M: generic subwords
-    dup "methods" word-prop values
+    [
-    swap "default-method" word-prop add ;
+        [ "default-method" word-prop , ]
+        [ "methods" word-prop values % ]
+        [ "engines" word-prop % ]
+        tri
+    ] { } make ;
 
-M: generic forget-word
+M: generic forget*
-    dup subwords [ forget ] each (forget-word) ;
+    [ subwords forget-all ] [ call-next-method ] bi ;
 
 : xref-generics ( -- )
     all-words [ subwords [ xref ] each ] each ;

core/generic/math/math.factor

@@ -12,9 +12,9 @@ PREDICATE: math-class < class
         number bootstrap-word class<
     ] if ;
 
-: last/first ( seq -- pair ) dup peek swap first 2array ;
+: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
 
-: math-precedence ( class -- n )
+: math-precedence ( class -- pair )
     {
         { [ dup null class< ] [ drop { -1 -1 } ] }
         { [ dup math-class? ] [ class-types last/first ] }
@@ -71,13 +71,15 @@ M: math-combination make-default-method
 
 M: math-combination perform-combination
     drop
+    dup
     \ over [
         dup math-class? [
             \ dup [ >r 2dup r> math-method ] math-vtable
         ] [
             over object-method
         ] if nip
-    ] math-vtable nip ;
+    ] math-vtable nip
+    define ;
 
 PREDICATE: math-generic < generic ( word -- ? )
     "combination" word-prop math-combination? ;

core/generic/standard/engines/engines.factor

@@ -0,0 +1,49 @@
+USING: assocs kernel namespaces quotations generic math
+sequences combinators words classes.algebra ;
+IN: generic.standard.engines
+
+SYMBOL: default
+SYMBOL: assumed
+
+GENERIC: engine>quot ( engine -- quot )
+
+M: quotation engine>quot ;
+
+M: method-body engine>quot 1quotation ;
+
+: engines>quots ( assoc -- assoc' )
+    [ engine>quot ] assoc-map ;
+
+: engines>quots* ( assoc -- assoc' )
+    [ over assumed [ engine>quot ] with-variable ] assoc-map ;
+
+: if-small? ( assoc true false -- )
+    >r >r dup assoc-size 4 <= r> r> if ; inline
+
+: linear-dispatch-quot ( alist -- quot )
+    default get [ drop ] prepend swap
+    [ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
+    alist>quot ;
+
+: split-methods ( assoc class -- first second )
+    [ [ nip class< not ] curry assoc-subset ]
+    [ [ nip class<     ] curry assoc-subset ] 2bi ;
+
+: convert-methods ( assoc class word -- assoc' )
+    over >r >r split-methods dup assoc-empty? [
+        r> r> 3drop
+    ] [
+        r> execute r> pick set-at
+    ] if ; inline
+
+SYMBOL: (dispatch#)
+
+: (picker) ( n -- quot )
+    {
+        { 0 [ [ dup ] ] }
+        { 1 [ [ over ] ] }
+        { 2 [ [ pick ] ] }
+        [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
+    } case ;
+
+: picker ( -- quot ) \ (dispatch#) get (picker) ;

core/generic/standard/engines/predicate/predicate.factor

@@ -0,0 +1,32 @@
+USING: generic.standard.engines generic namespaces kernel
+sequences classes.algebra accessors words combinators
+assocs ;
+IN: generic.standard.engines.predicate
+
+TUPLE: predicate-dispatch-engine methods ;
+
+C: <predicate-dispatch-engine> predicate-dispatch-engine
+
+: class-predicates ( assoc -- assoc )
+    [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
+
+: keep-going? ( assoc -- ? )
+    assumed get swap second first class< ;
+
+: prune-redundant-predicates ( assoc -- default assoc' )
+    {
+        { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+        { [ dup length 1 = ] [ first second { } ] }
+        { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
+        { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
+    } cond ;
+
+: sort-methods ( assoc -- assoc' )
+    [ keys sort-classes ]
+    [ [ dupd at ] curry ] bi { } map>assoc ;
+
+M: predicate-dispatch-engine engine>quot
+    methods>> clone
+    default get object bootstrap-word pick set-at engines>quots
+    sort-methods prune-redundant-predicates
+    class-predicates alist>quot ;

core/generic/standard/engines/tag/tag.factor

@@ -0,0 +1,57 @@
+USING: classes.private generic.standard.engines namespaces
+arrays assocs sequences.private quotations kernel.private
+math slots.private math.private kernel accessors words
+layouts ;
+IN: generic.standard.engines.tag
+
+TUPLE: lo-tag-dispatch-engine methods ;
+
+C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
+
+: direct-dispatch-quot ( alist n -- quot )
+    default get <array>
+    [ <enum> swap update ] keep
+    [ dispatch ] curry >quotation ;
+
+: lo-tag-number ( class -- n )
+     dup \ hi-tag bootstrap-word eq? [
+        drop \ hi-tag tag-number
+    ] [
+        "type" word-prop
+    ] if ;
+
+M: lo-tag-dispatch-engine engine>quot
+    methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
+    [
+        picker % [ tag ] % [
+            linear-dispatch-quot
+        ] [
+            num-tags get direct-dispatch-quot
+        ] if-small? %
+    ] [ ] make ;
+
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+    \ hi-tag bootstrap-word
+    \ <hi-tag-dispatch-engine> convert-methods ;
+
+: num-hi-tags num-types get num-tags get - ;
+
+: hi-tag-number ( class -- n )
+    "type" word-prop num-tags get - ;
+
+: hi-tag-quot ( -- quot )
+    [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ;
+
+M: hi-tag-dispatch-engine engine>quot
+    methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
+    [
+        picker % hi-tag-quot % [
+            linear-dispatch-quot
+        ] [
+            num-hi-tags direct-dispatch-quot
+        ] if-small? %
+    ] [ ] make ;

core/generic/standard/engines/tuple/tuple.factor

@@ -0,0 +1,128 @@
+IN: generic.standard.engines.tuple
+USING: kernel classes.tuple.private hashtables assocs sorting
+accessors combinators sequences slots.private math.parser words
+effects namespaces generic generic.standard.engines
+classes.algebra math math.private quotations arrays ;
+
+TUPLE: echelon-dispatch-engine n methods ;
+
+C: <echelon-dispatch-engine> echelon-dispatch-engine
+
+TUPLE: trivial-tuple-dispatch-engine methods ;
+
+C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
+
+TUPLE: tuple-dispatch-engine echelons ;
+
+: push-echelon ( class method assoc -- )
+    >r swap dup "layout" word-prop layout-echelon r>
+    [ ?set-at ] change-at ;
+
+: echelon-sort ( assoc -- assoc' )
+    V{ } clone [
+        [
+            push-echelon
+        ] curry assoc-each
+    ] keep sort-keys ;
+
+: <tuple-dispatch-engine> ( methods -- engine )
+    echelon-sort
+    [
+        over zero? [
+            dup assoc-empty?
+            [ drop f ] [ values first ] if
+        ] [
+            dupd <echelon-dispatch-engine>
+        ] if
+    ] assoc-map [ nip ] assoc-subset
+    \ tuple-dispatch-engine construct-boa ;
+
+: convert-tuple-methods ( assoc -- assoc' )
+    tuple bootstrap-word
+    \ <tuple-dispatch-engine> convert-methods ;
+
+M: trivial-tuple-dispatch-engine engine>quot
+    methods>> engines>quots* linear-dispatch-quot ;
+
+: hash-methods ( methods -- buckets )
+    >alist V{ } clone [ hashcode 1array ] distribute-buckets
+    [ <trivial-tuple-dispatch-engine> ] map ;
+
+: class-hash-dispatch-quot ( methods -- quot )
+    #! 1 slot == word hashcode
+    [
+        [ dup 1 slot ] %
+        hash-methods [ engine>quot ] map hash-dispatch-quot %
+    ] [ ] make ;
+
+: tuple-dispatch-engine-word-name ( engine -- string )
+    [
+        generic get word-name %
+        "/tuple-dispatch-engine/" %
+        n>> #
+    ] "" make ;
+
+PREDICATE: tuple-dispatch-engine-word < word
+    "tuple-dispatch-engine" word-prop ;
+
+M: tuple-dispatch-engine-word stack-effect
+    "tuple-dispatch-generic" word-prop stack-effect ;
+
+M: tuple-dispatch-engine-word crossref?
+    drop t ;
+
+: remember-engine ( word -- )
+    generic get "engines" word-prop push ;
+
+: <tuple-dispatch-engine-word> ( engine -- word )
+    tuple-dispatch-engine-word-name f <word>
+    {
+        [ t "tuple-dispatch-engine" set-word-prop ]
+        [ generic get "tuple-dispatch-generic" set-word-prop ]
+        [ remember-engine ]
+        [ ]
+    } cleave ;
+
+: define-tuple-dispatch-engine-word ( engine quot -- word )
+    >r <tuple-dispatch-engine-word> dup r> define ;
+
+: tuple-dispatch-engine-body ( engine -- quot )
+    #! 1 slot == tuple-layout
+    #! 2 slot == 0 array-nth
+    #! 4 slot == layout-superclasses
+    [
+        picker %
+        [ 1 slot 4 slot ] %
+        [ n>> 2 + , [ slot ] % ]
+        [
+            methods>> [
+                <trivial-tuple-dispatch-engine> engine>quot
+            ] [
+                class-hash-dispatch-quot
+            ] if-small? %
+        ] bi
+    ] [ ] make ;
+
+M: echelon-dispatch-engine engine>quot
+    dup tuple-dispatch-engine-body
+    define-tuple-dispatch-engine-word
+    1quotation ;
+
+: >=-case-quot ( alist -- quot )
+    default get [ drop ] prepend swap
+    [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
+    alist>quot ;
+
+M: tuple-dispatch-engine engine>quot
+    #! 1 slot == tuple-layout
+    #! 5 slot == layout-echelon
+    [
+        picker %
+        [ 1 slot 5 slot ] %
+        echelons>>
+        [
+            tuple assumed set
+            [ engine>quot dup default set ] assoc-map
+        ] with-scope
+        >=-case-quot %
+    ] [ ] make ;

core/generic/standard/standard-tests.factor

@@ -0,0 +1,235 @@
+IN: generic.standard.tests
+USING: tools.test math math.functions math.constants
+generic.standard strings sequences arrays kernel accessors
+words float-arrays byte-arrays bit-arrays parser namespaces ;
+
+GENERIC: lo-tag-test
+
+M: integer lo-tag-test 3 + ;
+
+M: float lo-tag-test 4 - ;
+
+M: rational lo-tag-test 2 - ;
+
+M: complex lo-tag-test sq ;
+
+[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
+[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
+[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
+[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
+
+GENERIC: hi-tag-test
+
+M: string hi-tag-test ", in bed" append ;
+
+M: integer hi-tag-test 3 + ;
+
+M: array hi-tag-test [ hi-tag-test ] map ;
+
+M: sequence hi-tag-test reverse ;
+
+[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
+
+[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
+
+[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
+
+TUPLE: shape ;
+
+TUPLE: abstract-rectangle < shape width height ;
+
+TUPLE: rectangle < abstract-rectangle ;
+
+C: <rectangle> rectangle
+
+TUPLE: parallelogram < abstract-rectangle skew ;
+
+C: <parallelogram> parallelogram
+
+TUPLE: circle < shape radius ;
+
+C: <circle> circle
+
+GENERIC: area
+
+M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
+
+M: circle area radius>> sq pi * ;
+
+[ 12 ] [ 4 3 <rectangle> area ] unit-test
+[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
+[ t ] [ 2 <circle> area 4 pi * = ] unit-test
+
+GENERIC: perimiter
+
+: rectangle-perimiter + 2 * ;
+
+M: rectangle perimiter
+    [ width>> ] [ height>> ] bi
+    rectangle-perimiter ;
+
+: hypotenuse [ sq ] bi@ + sqrt ;
+
+M: parallelogram perimiter
+    [ width>> ]
+    [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
+    rectangle-perimiter ;
+
+M: circle perimiter 2 * pi * ;
+
+[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
+[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
+
+GENERIC: big-mix-test
+
+M: object big-mix-test drop "object" ;
+
+M: tuple big-mix-test drop "tuple" ;
+
+M: integer big-mix-test drop "integer" ;
+
+M: float big-mix-test drop "float" ;
+
+M: complex big-mix-test drop "complex" ;
+
+M: string big-mix-test drop "string" ;
+
+M: array big-mix-test drop "array" ;
+
+M: sequence big-mix-test drop "sequence" ;
+
+M: rectangle big-mix-test drop "rectangle" ;
+
+M: parallelogram big-mix-test drop "parallelogram" ;
+
+M: circle big-mix-test drop "circle" ;
+
+[ "integer" ] [ 3 big-mix-test ] unit-test
+[ "float" ] [ 5.0 big-mix-test ] unit-test
+[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
+[ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test
+[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
+[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
+[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
+[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
+[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
+[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
+[ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test
+[ "string" ] [ "hello" big-mix-test ] unit-test
+[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
+[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
+[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
+[ "tuple" ] [ H{ } big-mix-test ] unit-test
+[ "object" ] [ \ + big-mix-test ] unit-test
+
+GENERIC: small-lo-tag
+
+M: fixnum small-lo-tag drop "fixnum" ;
+
+M: string small-lo-tag drop "string" ;
+
+M: array small-lo-tag drop "array" ;
+
+M: float-array small-lo-tag drop "float-array" ;
+
+M: byte-array small-lo-tag drop "byte-array" ;
+
+[ "fixnum" ] [ 3 small-lo-tag ] unit-test
+
+[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test
+
+! Testing next-method
+TUPLE: person ;
+
+TUPLE: intern < person ;
+
+TUPLE: employee < person ;
+
+TUPLE: tape-monkey < employee ;
+
+TUPLE: manager < employee ;
+
+TUPLE: junior-manager < manager ;
+
+TUPLE: middle-manager < manager ;
+
+TUPLE: senior-manager < manager ;
+
+TUPLE: executive < senior-manager ;
+
+TUPLE: ceo < executive ;
+
+GENERIC: salary ( person -- n )
+
+M: intern salary
+    #! Intentional mistake.
+    call-next-method ;
+
+M: employee salary drop 24000 ;
+
+M: manager salary call-next-method 12000 + ;
+
+M: middle-manager salary call-next-method 5000 + ;
+
+M: senior-manager salary call-next-method 15000 + ;
+
+M: executive salary call-next-method 2 * ;
+
+M: ceo salary
+    #! Intentional error.
+    drop 5 call-next-method 3 * ;
+
+[ salary ] must-infer
+
+[ 24000 ] [ employee construct-boa salary ] unit-test
+
+[ 24000 ] [ tape-monkey construct-boa salary ] unit-test
+
+[ 36000 ] [ junior-manager construct-boa salary ] unit-test
+
+[ 41000 ] [ middle-manager construct-boa salary ] unit-test
+
+[ 51000 ] [ senior-manager construct-boa salary ] unit-test
+
+[ 102000 ] [ executive construct-boa salary ] unit-test
+
+[ ceo construct-boa salary ]
+[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with
+
+[ intern construct-boa salary ]
+[ T{ no-next-method f intern salary } = ] must-fail-with
+
+! Weird shit
+TUPLE: a ;
+TUPLE: b ;
+TUPLE: c ;
+
+UNION: x a b ;
+UNION: y a c ;
+
+UNION: z x y ;
+
+GENERIC: funky* ( obj -- )
+
+M: z funky* "z" , drop ;
+
+M: x funky* "x" , call-next-method ;
+
+M: y funky* "y" , call-next-method ;
+
+M: a funky* "a" , call-next-method ;
+
+M: b funky* "b" , call-next-method ;
+
+M: c funky* "c" , call-next-method ;
+
+: funky [ funky* ] { } make ;
+
+[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
+
+[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
+
+[ t ] [
+    T{ a } funky
+    { { "a" "x" "z" } { "a" "y" "z" } } member?
+] unit-test

core/generic/standard/standard.factor

@@ -3,26 +3,21 @@
 USING: arrays assocs kernel kernel.private slots.private math
 namespaces sequences vectors words quotations definitions
 hashtables layouts combinators sequences.private generic
-classes classes.algebra classes.private ;
+classes classes.algebra classes.private generic.standard.engines
+generic.standard.engines.tag generic.standard.engines.predicate
+generic.standard.engines.tuple accessors ;
 IN: generic.standard
 
-TUPLE: standard-combination # ;
+GENERIC: dispatch# ( word -- n )
 
-C: <standard-combination> standard-combination
+M: word dispatch# "combination" word-prop dispatch# ;
 
-SYMBOL: (dispatch#)
+: unpickers
-
-: (picker) ( n -- quot )
     {
-        { 0 [ [ dup ] ] }
+        [ nip ]
-        { 1 [ [ over ] ] }
+        [ >r nip r> swap ]
-        { 2 [ [ pick ] ] }
+        [ >r >r nip r> r> -rot ]
-        [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
+    } ; inline
-    } case ;
-
-: picker ( -- quot ) \ (dispatch#) get (picker) ;
-
-: unpickers { [ nip ] [ >r nip r> swap ] [ >r >r nip r> r> -rot ] } ; inline
 
 : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
 
@@ -34,163 +29,138 @@ ERROR: no-method object generic ;
 : empty-method ( word -- quot )
     [
         picker % [ delegate dup ] %
-        unpicker over add ,
+        unpicker over suffix ,
-        error-method \ drop add* , \ if ,
+        error-method \ drop prefix , \ if ,
     ] [ ] make ;
 
-: class-predicates ( assoc -- assoc )
-    [
-        >r >r picker r> "predicate" word-prop append r>
-    ] assoc-map ;
-
-: (simplify-alist) ( class i assoc -- default assoc )
-    2dup length 1- = [
-        nth second { } rot drop
-    ] [
-        3dup >r 1+ r> nth first class< [
-            >r 1+ r> (simplify-alist)
-        ] [
-            [ nth second ] 2keep swap 1+ tail rot drop
-        ] if
-    ] if ;
-
-: simplify-alist ( class assoc -- default assoc )
-    dup empty? [
-        2drop [ "Unreachable" throw ] { }
-    ] [
-        0 swap (simplify-alist)
-    ] if ;
-
 : default-method ( word -- pair )
     "default-method" word-prop
     object bootstrap-word swap 2array ;
 
-: method-alist>quot ( alist base-class -- quot )
+: push-method ( method specializer atomic assoc -- )
-    bootstrap-word swap simplify-alist
-    class-predicates alist>quot ;
-
-: small-generic ( methods -- def )
-    object method-alist>quot ;
-
-: hash-methods ( methods -- buckets )
-    V{ } clone [
-        tuple bootstrap-word over class< [
-            drop t
-        ] [
-            class-hashes
-        ] if
-    ] distribute-buckets ;
-
-: class-hash-dispatch-quot ( methods quot picker -- quot )
-    >r >r hash-methods r> map
-    hash-dispatch-quot r> [ class-hash ] rot 3append ; inline
-
-: big-generic ( methods -- quot )
-    [ small-generic ] picker class-hash-dispatch-quot ;
-
-: vtable-class ( n -- class )
-    bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
-
-: group-methods ( assoc -- vtable )
-    #! Input is a predicate -> method association.
-    #! n is vtable size (either num-types or num-tags).
-    num-tags get [
-        vtable-class
-        [ swap first classes-intersect? ] curry subset
-    ] with map ;
-
-: build-type-vtable ( alist-seq -- alist-seq )
-    dup length [
-        vtable-class
-        swap simplify-alist
-        class-predicates alist>quot
-    ] 2map ;
-
-: tag-generic ( methods -- quot )
     [
-        picker %
+        [ H{ } clone <predicate-dispatch-engine> ] unless*
-        \ tag ,
+        [ methods>> set-at ] keep
-        group-methods build-type-vtable ,
+    ] change-at ;
-        \ dispatch ,
-    ] [ ] make ;
 
-: flatten-method ( class body -- )
+: flatten-method ( class method assoc -- )
-    over members pick object bootstrap-word eq? not and [
+    >r >r dup flatten-class keys swap r> r> [
-        >r members r> [ flatten-method ] curry each
+        >r spin r> push-method
-    ] [
+    ] 3curry each ;
-        swap set
-    ] if ;
 
-: flatten-methods ( methods -- newmethods )
+: flatten-methods ( assoc -- assoc' )
-    [ [ flatten-method ] assoc-each ] V{ } make-assoc ;
+    H{ } clone [
+        [
+            flatten-method
+        ] curry assoc-each
+    ] keep ;
 
-: dispatched-types ( methods -- seq )
+: <big-dispatch-engine> ( assoc -- engine )
-    keys object bootstrap-word swap remove prune ;
-
-: single-combination ( methods -- quot )
-    dup length 4 <= [
-        small-generic
-    ] [
     flatten-methods
-        dup dispatched-types [ number class< ] all?
+    convert-tuple-methods
-        [ tag-generic ] [ big-generic ] if
+    convert-hi-tag-methods
-    ] if ;
+    <lo-tag-dispatch-engine> ;
 
-: standard-methods ( word -- alist )
+: find-default ( methods -- quot )
-    dup methods swap default-method add*
+    #! Side-effects methods.
-    [ 1quotation ] assoc-map ;
+    object bootstrap-word swap delete-at* [
+        drop generic get "default-method" word-prop 1quotation
+    ] unless ;
 
-M: standard-combination make-default-method
+GENERIC: mangle-method ( method generic -- quot )
-    standard-combination-# (dispatch#)
-    [ empty-method ] with-variable ;
 
-M: standard-combination perform-combination
+: single-combination ( word -- quot )
-    standard-combination-# (dispatch#) [
-        [ standard-methods ] keep "inline" word-prop
-        [ small-generic ] [ single-combination ] if
-    ] with-variable ;
-
-TUPLE: hook-combination var ;
-
-C: <hook-combination> hook-combination
-
-: with-hook ( combination quot -- quot' )
-    0 (dispatch#) [
-        swap slip
-        hook-combination-var [ get ] curry
-        prepend
-    ] with-variable ; inline
-
-M: hook-combination make-default-method
-    [ error-method ] with-hook ;
-
-M: hook-combination perform-combination
     [
-        standard-methods
+        object bootstrap-word assumed set {
-        [ [ drop ] prepend ] assoc-map
+            [ generic set ]
-        single-combination
+            [ "engines" word-prop forget-all ]
-    ] with-hook ;
+            [ V{ } clone "engines" set-word-prop ]
+            [
+                "methods" word-prop
+                [ generic get mangle-method ] assoc-map
+                [ find-default default set ]
+                [
+                    generic get "inline" word-prop [
+                        <predicate-dispatch-engine>
+                    ] [
+                        <big-dispatch-engine>
+                    ] if
+                ] bi
+                engine>quot
+            ]
+        } cleave
+    ] with-scope ;
 
-: define-simple-generic ( word -- )
+TUPLE: standard-combination # ;
-    T{ standard-combination f 0 } define-generic ;
+
+C: <standard-combination> standard-combination
 
 PREDICATE: standard-generic < generic
     "combination" word-prop standard-combination? ;
 
 PREDICATE: simple-generic < standard-generic
-    "combination" word-prop standard-combination-# zero? ;
+    "combination" word-prop #>> zero? ;
+
+: define-simple-generic ( word -- )
+    T{ standard-combination f 0 } define-generic ;
+
+: with-standard ( combination quot -- quot' )
+    >r #>> (dispatch#) r> with-variable ; inline
+
+M: standard-generic mangle-method
+    drop 1quotation ;
+
+M: standard-combination make-default-method
+    [ empty-method ] with-standard ;
+
+M: standard-combination perform-combination
+    [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
+
+M: standard-combination dispatch# #>> ;
+
+ERROR: inconsistent-next-method object class generic ;
+
+ERROR: no-next-method class generic ;
+
+M: standard-generic next-method-quot
+    [
+        [
+            [ [ instance? ] curry ]
+            [ dispatch# (picker) ] bi* prepend %
+        ]
+        [
+            2dup next-method
+            [ 2nip 1quotation ]
+            [ [ no-next-method ] 2curry ] if* ,
+        ]
+        [ [ inconsistent-next-method ] 2curry , ]
+        2tri
+        \ if ,
+    ] [ ] make ;
+
+TUPLE: hook-combination var ;
+
+C: <hook-combination> hook-combination
 
 PREDICATE: hook-generic < generic
     "combination" word-prop hook-combination? ;
 
-GENERIC: dispatch# ( word -- n )
+: with-hook ( combination quot -- quot' )
-
+    0 (dispatch#) [
-M: word dispatch# "combination" word-prop dispatch# ;
+        dip var>> [ get ] curry prepend
-
+    ] with-variable ; inline
-M: standard-combination dispatch# standard-combination-# ;
 
 M: hook-combination dispatch# drop 0 ;
 
+M: hook-generic mangle-method
+    drop 1quotation [ drop ] prepend ;
+
+M: hook-combination make-default-method
+    [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+    [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
+
 M: simple-generic definer drop \ GENERIC: f ;
 
 M: standard-generic definer drop \ GENERIC# f ;

core/inference/backend/backend.factor

@@ -3,14 +3,23 @@
 USING: inference.dataflow inference.state arrays generic io
 io.streams.string kernel math namespaces parser prettyprint
 sequences strings vectors words quotations effects classes
-continuations debugger assocs combinators compiler.errors ;
+continuations debugger assocs combinators compiler.errors
+generic.standard.engines.tuple ;
 IN: inference.backend
 
 : recursive-label ( word -- label/f )
     recursive-state get at ;
 
-: inline? ( word -- ? )
+GENERIC: inline? ( word -- ? )
-    dup "method-generic" word-prop swap or "inline" word-prop ;
+
+M: method-body inline?
+    "method-generic" word-prop inline? ;
+
+M: tuple-dispatch-engine-word inline?
+    "tuple-dispatch-generic" word-prop inline? ;
+
+M: word inline?
+    "inline" word-prop ;
 
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys
@@ -92,7 +101,7 @@ M: wrapper apply-object
     r> recursive-state set ;
 
 : infer-quot-recursive ( quot word label -- )
-    recursive-state get -rot 2array add* infer-quot ;
+    recursive-state get -rot 2array prefix infer-quot ;
 
 : time-bomb ( error -- )
     [ throw ] curry recursive-state get infer-quot ;
@@ -109,7 +118,7 @@ TUPLE: recursive-quotation-error quot ;
         dup value-literal callable? [
             dup value-literal
             over value-recursion
-            rot f 2array add* infer-quot
+            rot f 2array prefix infer-quot
         ] [
             drop bad-call
         ] if
@@ -430,7 +439,7 @@ M: #call-label collect-recursion*
     [ [ swap collect-recursion* ] curry each-node ] { } make ;
 
 : join-values ( node -- )
-    collect-recursion [ node-in-d ] map meta-d get add
+    collect-recursion [ node-in-d ] map meta-d get suffix
     unify-lengths unify-stacks
     meta-d [ length tail* ] change ;
 

core/inference/class/class-tests.factor

@@ -21,7 +21,7 @@ GENERIC: mynot ( x -- y )
 
 M: f mynot drop t ;
 
-M: general-t mynot drop f ;
+M: object mynot drop f ;
 
 GENERIC: detect-f ( x -- y )
 
@@ -120,7 +120,7 @@ M: object xyz ;
     [
         [ no-cond ] 1
         [ 1array dup quotation? [ >quotation ] unless ] times
-    ] \ type inlined?
+    ] \ quotation? inlined?
 ] unit-test
 
 [ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
@@ -233,6 +233,20 @@ M: fixnum annotate-entry-test-1 drop ;
     \ >float inlined?
 ] unit-test
 
+GENERIC: detect-float ( a -- b )
+
+M: float detect-float ;
+
+[ t ] [
+    [ { real float } declare + detect-float ]
+    \ detect-float inlined?
+] unit-test
+
+[ t ] [
+    [ { float real } declare + detect-float ]
+    \ detect-float inlined?
+] unit-test
+
 [ t ] [
     [ 3 + = ] \ equal? inlined?
 ] unit-test
@@ -297,3 +311,15 @@ cell-bits 32 = [
 [ t ] [
     [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
 ] unit-test
+
+[ t ] [
+    [
+        dup integer? [
+            dup fixnum? [
+                1 +
+            ] [
+                2 +
+            ] if
+        ] when
+    ] \ + inlined?
+] unit-test

core/inference/class/class.factor

@@ -175,10 +175,19 @@ M: pair constraint-satisfied?
     [ intersect-value-interval ] 2each ;
 
 : predicate-constraints ( class #call -- )
+    [
+        ! If word outputs true, input is an instance of class
         [
             0 `input class,
-        general-t 0 `output class,
+            \ f class-not 0 `output class,
-    ] set-constraints ;
+        ] set-constraints
+    ] [
+        ! If word outputs false, input is not an instance of class
+        [
+            class-not 0 `input class,
+            \ f 0 `output class,
+        ] set-constraints
+    ] 2bi ;
 
 : compute-constraints ( #call -- )
     dup node-param "constraints" word-prop [
@@ -209,7 +218,7 @@ M: #push infer-classes-before
 
 M: #if child-constraints
     [
-        general-t 0 `input class,
+        \ f class-not 0 `input class,
         f 0 `input literal,
     ] make-constraints ;
 
@@ -265,7 +274,7 @@ DEFER: (infer-classes)
     (merge-intervals) r> set-intervals ;
 
 : annotate-merge ( nodes #merge/#entry -- )
-    2dup merge-classes merge-intervals ;
+    [ merge-classes ] [ merge-intervals ] 2bi ;
 
 : merge-children ( node -- )
     dup node-successor dup #merge? [
@@ -281,28 +290,31 @@ DEFER: (infer-classes)
 M: #label infer-classes-before ( #label -- )
     #! First, infer types under the hypothesis which hold on
     #! entry to the recursive label.
-    dup 1array swap annotate-entry ;
+    [ 1array ] keep annotate-entry ;
 
 M: #label infer-classes-around ( #label -- )
     #! Now merge the types at every recursion point with the
     #! entry types.
-    dup annotate-node
+    {
-    dup infer-classes-before
+        [ annotate-node ]
-    dup infer-children
+        [ infer-classes-before ]
-    dup collect-recursion over add
+        [ infer-children ]
-    pick annotate-entry
+        [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
-    node-child (infer-classes) ;
+        [ node-child (infer-classes) ]
+    } cleave ;
 
 M: object infer-classes-around
-    dup infer-classes-before
+    {
-    dup annotate-node
+        [ infer-classes-before ]
-    dup infer-children
+        [ annotate-node ]
-    merge-children ;
+        [ infer-children ]
+        [ merge-children ]
+    } cleave ;
 
 : (infer-classes) ( node -- )
     [
-        dup infer-classes-around
+        [ infer-classes-around ]
-        node-successor (infer-classes)
+        [ node-successor (infer-classes) ] bi
     ] when* ;
 
 : infer-classes-with ( node classes literals intervals -- )

core/inference/dataflow/dataflow.factor

@@ -9,15 +9,13 @@ IN: inference.dataflow
 : <computed> \ <computed> counter ;
 
 ! Literal value
-TUPLE: value literal uid recursion ;
+TUPLE: value < identity-tuple literal uid recursion ;
 
 : <value> ( obj -- value )
     <computed> recursive-state get value construct-boa ;
 
 M: value hashcode* nip value-uid ;
 
-M: value equal? 2drop f ;
-
 ! Result of curry
 TUPLE: curried obj quot ;
 
@@ -30,13 +28,12 @@ C: <composed> composed
 
 UNION: special curried composed ;
 
-TUPLE: node param
+TUPLE: node < identity-tuple
+param
 in-d out-d in-r out-r
 classes literals intervals
 history successor children ;
 
-M: node equal? 2drop f ;
-
 M: node hashcode* drop node hashcode* ;
 
 GENERIC: flatten-curry ( value -- )
@@ -205,7 +202,7 @@ UNION: #branch #if #dispatch ;
         2dup 2slip rot [
             2drop t
         ] [
-            >r dup node-children swap node-successor add r>
+            >r dup node-children swap node-successor suffix r>
             [ node-exists? ] curry contains?
         ] if
     ] [

core/inference/known-words/known-words.factor

@@ -383,15 +383,9 @@ set-primitive-effect
 \ millis { } { integer } <effect> set-primitive-effect
 \ millis make-flushable
 
-\ type { object } { fixnum } <effect> set-primitive-effect
-\ type make-foldable
-
 \ tag { object } { fixnum } <effect> set-primitive-effect
 \ tag make-foldable
 
-\ class-hash { object } { fixnum } <effect> set-primitive-effect
-\ class-hash make-foldable
-
 \ cwd { } { string } <effect> set-primitive-effect
 
 \ cd { string } { } <effect> set-primitive-effect

core/inference/transforms/transforms-tests.factor

@@ -1,6 +1,7 @@
 IN: inference.transforms.tests
 USING: sequences inference.transforms tools.test math kernel
-quotations inference accessors combinators words arrays ;
+quotations inference accessors combinators words arrays
+classes ;
 
 : compose-n-quot <repetition> >quotation ;
 : compose-n compose-n-quot call ;
@@ -56,3 +57,5 @@ C: <color> color
 [ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
 
 [ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test
+
+[ fixnum instance? ] must-infer

core/inference/transforms/transforms.factor

@@ -3,7 +3,7 @@
 USING: arrays kernel words sequences generic math namespaces
 quotations assocs combinators math.bitfields inference.backend
 inference.dataflow inference.state classes.tuple.private effects
-inspector hashtables ;
+inspector hashtables classes generic ;
 IN: inference.transforms
 
 : pop-literals ( n -- rstate seq )
@@ -43,6 +43,8 @@ IN: inference.transforms
 
 \ 2cleave [ 2cleave>quot ] 1 define-transform
 
+\ 3cleave [ 3cleave>quot ] 1 define-transform
+
 \ spread [ spread>quot ] 1 define-transform
 
 ! Bitfields
@@ -56,7 +58,7 @@ M: pair (bitfield-quot) ( spec -- quot )
     [ shift bitor ] append 2curry ;
 
 : bitfield-quot ( spec -- quot )
-    [ (bitfield-quot) ] map [ 0 ] add* concat ;
+    [ (bitfield-quot) ] map [ 0 ] prefix concat ;
 
 \ bitfield [ bitfield-quot ] 1 define-transform
 
@@ -96,3 +98,11 @@ M: duplicated-slots-error summary
         \ construct-empty 1 1 <effect> make-call-node
     ] if
 ] "infer" set-word-prop
+
+\ instance? [
+    [ +inlined+ depends-on ] [ "predicate" word-prop ] bi
+] 1 define-transform
+
+\ (call-next-method) [
+    [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+] 2 define-transform

core/io/backend/backend-tests.factor

@@ -1,4 +1,4 @@
 IN: io.backend.tests
 USING: tools.test io.backend kernel ;
 
-[ ] [ "a" normalize-pathname drop ] unit-test
+[ ] [ "a" normalize-path drop ] unit-test

core/io/backend/backend.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: init kernel system namespaces io io.encodings
-io.encodings.utf8 init assocs ;
+io.encodings.utf8 init assocs splitting ;
 IN: io.backend
 
 SYMBOL: io-backend
@@ -18,9 +18,9 @@ HOOK: io-multiplex io-backend ( ms -- )
 
 HOOK: normalize-directory io-backend ( str -- newstr )
 
-HOOK: normalize-pathname io-backend ( str -- newstr )
+HOOK: normalize-path io-backend ( str -- newstr )
 
-M: object normalize-directory normalize-pathname ;
+M: object normalize-directory normalize-path ;
 
 : set-io-backend ( io-backend -- )
     io-backend set-global init-io init-stdio

core/io/encodings/encodings.factor

@@ -59,7 +59,7 @@ M: tuple <decoder> f decoder construct-boa ;
     over decoder-cr [
         over cr-
         "\n" ?head [
-            over stream-read1 [ add ] when*
+            over stream-read1 [ suffix ] when*
         ] when
     ] when nip ;
 

core/io/files/files-docs.factor

@@ -28,11 +28,14 @@ ARTICLE: "pathnames" "Pathname manipulation"
 { $subsection <pathname> } ;
 
 ARTICLE: "directories" "Directories"
-"Current and home directories:"
+"Current directory:"
+{ $subsection with-directory }
+{ $subsection current-directory }
+"Home directory:"
+{ $subsection home }
+"Current system directory:"
 { $subsection cwd }
 { $subsection cd }
-{ $subsection with-directory }
-{ $subsection home }
 "Directory listing:"
 { $subsection directory }
 { $subsection directory* }
@@ -197,19 +200,20 @@ HELP: file-contents
 HELP: cwd
 { $values { "path" "a pathname string" } }
 { $description "Outputs the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
+{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $warning "Modifying the current directory through system calls is unsafe.  Use the " { $link with-directory } " word instead." } ;
 
 HELP: cd
 { $values { "path" "a pathname string" } }
 { $description "Changes the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
+{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $warning "Modifying the current directory through system calls is unsafe.  Use the " { $link with-directory } " word instead." } ;
 
-{ cd cwd with-directory } related-words
+{ cd cwd current-directory with-directory } related-words
 
 HELP: with-directory
 { $values { "path" "a pathname string" } { "quot" quotation } }
-{ $description "Changes the current working directory for the duration of a quotation's execution." }
+{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution.  Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ;
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
 
 HELP: append-path
 { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
@@ -252,7 +256,7 @@ HELP: normalize-directory
 { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
 { $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
 
-HELP: normalize-pathname
+HELP: normalize-path
 { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
 { $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
 

core/io/files/files-tests.factor

@@ -220,8 +220,6 @@ io.encodings.utf8 ;
 
 [ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
 [ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
-[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
-[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
 [ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
 [ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
 [ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
@@ -239,9 +237,6 @@ io.encodings.utf8 ;
 [ "lib" ] [ "" "lib" append-path ] unit-test
 [ "lib" ] [ "" "./lib" append-path ] unit-test
 
-[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
-[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
-
 [ "foo/bar/." parent-directory ] must-fail
 [ "foo/bar/./" parent-directory ] must-fail
 [ "foo/bar/baz/.." parent-directory ] must-fail
@@ -263,5 +258,4 @@ io.encodings.utf8 ;
 [ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
 
 [ t ] [ "resource:core" absolute-path? ] unit-test
-[ t ] [ "/foo" absolute-path? ] unit-test
 [ f ] [ "" absolute-path? ] unit-test

core/io/files/files.factor

@@ -3,7 +3,7 @@
 USING: io.backend io.files.private io hashtables kernel math
 memory namespaces sequences strings assocs arrays definitions
 system combinators splitting sbufs continuations io.encodings
-io.encodings.binary init ;
+io.encodings.binary init accessors ;
 IN: io.files
 
 HOOK: (file-reader) io-backend ( path -- stream )
@@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream )
 HOOK: (file-appender) io-backend ( path -- stream )
 
 : <file-reader> ( path encoding -- stream )
-    swap normalize-pathname (file-reader) swap <decoder> ;
+    swap normalize-path (file-reader) swap <decoder> ;
 
 : <file-writer> ( path encoding -- stream )
-    swap normalize-pathname (file-writer) swap <encoder> ;
+    swap normalize-path (file-writer) swap <encoder> ;
 
 : <file-appender> ( path encoding -- stream )
-    swap normalize-pathname (file-appender) swap <encoder> ;
+    swap normalize-path (file-appender) swap <encoder> ;
 
 : file-lines ( path encoding -- seq )
     <file-reader> lines ;
@@ -43,9 +43,9 @@ HOOK: (file-appender) io-backend ( path -- stream )
     >r <file-appender> r> with-stream ; inline
 
 ! Pathnames
-: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
+: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
 
-: path-separator ( -- string ) windows? "\\" "/" ? ;
+: path-separator ( -- string ) os windows? "\\" "/" ? ;
 
 : right-trim-separators ( str -- newstr )
     [ path-separator? ] right-trim ;
@@ -102,6 +102,7 @@ PRIVATE>
 
 : windows-absolute-path? ( path -- path ? )
     {
+        { [ dup "\\\\?\\" head? ] [ t ] }
         { [ dup length 2 < ] [ f ] }
         { [ dup second CHAR: : = ] [ t ] }
         { [ t ] [ f ] }
@@ -111,8 +112,8 @@ PRIVATE>
     {
         { [ dup empty? ] [ f ] }
         { [ dup "resource:" head? ] [ t ] }
+        { [ os windows? ] [ windows-absolute-path? ] }
         { [ dup first path-separator? ] [ t ] }
-        { [ windows? ] [ windows-absolute-path? ] }
         { [ t ] [ f ] }
     } cond nip ;
 
@@ -126,6 +127,9 @@ PRIVATE>
             2 tail left-trim-separators
             >r parent-directory r> append-path
         ] }
+        { [ over absolute-path? over first path-separator? and ] [
+            >r 2 head r> append
+        ] }
         { [ t ] [
             >r right-trim-separators "/" r>
             left-trim-separators 3append
@@ -145,8 +149,17 @@ PRIVATE>
 TUPLE: file-info type size permissions modified ;
 
 HOOK: file-info io-backend ( path -- info )
+
+! Symlinks
 HOOK: link-info io-backend ( path -- info )
 
+HOOK: make-link io-backend ( path1 path2 -- )
+
+HOOK: read-link io-backend ( path -- info )
+
+: copy-link ( path1 path2 -- )
+    >r read-link r> make-link ;
+
 SYMBOL: +regular-file+
 SYMBOL: +directory+
 SYMBOL: +character-device+
@@ -158,34 +171,52 @@ SYMBOL: +unknown+
 
 ! File metadata
 : exists? ( path -- ? )
-    normalize-pathname (exists?) ;
+    normalize-path (exists?) ;
 
 : directory? ( path -- ? )
     file-info file-info-type +directory+ = ;
 
-! Current working directory
+<PRIVATE
+
 HOOK: cd io-backend ( path -- )
 
 HOOK: cwd io-backend ( -- path )
 
-SYMBOL: current-directory
-
 M: object cwd ( -- path ) "." ;
 
+PRIVATE>
+
+SYMBOL: current-directory
+
 [ cwd current-directory set-global ] "io.files" add-init-hook
 
+: resource-path ( path -- newpath )
+    "resource-path" get [ image parent-directory ] unless*
+    prepend-path ;
+
+: (normalize-path) ( path -- path' )
+    "resource:" ?head [
+        left-trim-separators resource-path
+        (normalize-path)
+    ] [
+        current-directory get prepend-path
+    ] if ;
+
+M: object normalize-path ( path -- path' )
+    (normalize-path) ;
+
 : with-directory ( path quot -- )
-    >r normalize-pathname r>
+    >r (normalize-path) r>
     current-directory swap with-variable ; inline
 
 : set-current-directory ( path -- )
-    normalize-pathname current-directory set ;
+    normalize-path current-directory set ;
 
 ! Creating directories
 HOOK: make-directory io-backend ( path -- )
 
 : make-directories ( path -- )
-    normalize-pathname right-trim-separators {
+    normalize-path right-trim-separators {
         { [ dup "." = ] [ ] }
         { [ dup root-directory? ] [ ] }
         { [ dup empty? ] [ ] }
@@ -218,14 +249,14 @@ HOOK: delete-file io-backend ( path -- )
 
 HOOK: delete-directory io-backend ( path -- )
 
-: (delete-tree) ( path dir? -- )
-    [
-        dup directory* [ (delete-tree) ] assoc-each
-        delete-directory
-    ] [ delete-file ] if ;
-
 : delete-tree ( path -- )
-    dup directory? (delete-tree) ;
+    dup link-info type>> +directory+ = [
+        dup directory over [
+            [ first delete-tree ] each
+        ] with-directory delete-directory
+    ] [
+        delete-file
+    ] if ;
 
 : to-directory over file-name append-path ;
 
@@ -258,13 +289,17 @@ M: object copy-file
 DEFER: copy-tree-into
 
 : copy-tree ( from to -- )
-    over directory? [
+    normalize-path
-        >r dup directory swap r> [
+    over link-info type>>
-            >r swap first append-path r> copy-tree-into
+    {
-        ] 2curry each
+        { +symbolic-link+ [ copy-link ] }
-    ] [
+        { +directory+ [
-        copy-file
+            >r dup directory r> rot [
-    ] if ;
+                [ >r first r> copy-tree-into ] curry each
+            ] with-directory
+        ] }
+        [ drop copy-file ]
+    } case ;
 
 : copy-tree-into ( from to -- )
     to-directory copy-tree ;
@@ -273,9 +308,6 @@ DEFER: copy-tree-into
     [ copy-tree-into ] curry each ;
 
 ! Special paths
-: resource-path ( path -- newpath )
-    "resource-path" get [ image parent-directory ] unless*
-    prepend-path ;
 
 : temp-directory ( -- path )
     "temp" resource-path dup make-directories ;
@@ -283,14 +315,6 @@ DEFER: copy-tree-into
 : temp-file ( name -- path )
     temp-directory prepend-path ;
 
-M: object normalize-pathname ( path -- path' )
-    "resource:" ?head [
-        left-trim-separators resource-path
-        normalize-pathname
-    ] [
-        current-directory get prepend-path
-    ] if ;
-
 ! Pathname presentations
 TUPLE: pathname string ;
 
@@ -301,7 +325,7 @@ M: pathname <=> [ pathname-string ] compare ;
 ! Home directory
 : home ( -- dir )
     {
-        { [ winnt? ] [ "USERPROFILE" os-env ] }
+        { [ os winnt? ] [ "USERPROFILE" os-env ] }
-        { [ wince? ] [ "" resource-path ] }
+        { [ os wince? ] [ "" resource-path ] }
-        { [ unix? ] [ "HOME" os-env ] }
+        { [ os unix? ] [ "HOME" os-env ] }
     } cond ;

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."
@@ -201,8 +250,9 @@ $nl
 { $subsection eq? }
 "Value comparison:"
 { $subsection = }
-"Generic words for custom value comparison methods:"
+"Custom value comparison methods:"
 { $subsection equal? }
+{ $subsection identity-tuple }
 "Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
 { $subsection <=> }
 { $subsection compare }
@@ -328,10 +378,13 @@ HELP: equal?
     }
     $nl
     "If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word."
-}
+} ;
+
+HELP: identity-tuple
+{ $class-description "A class defining an " { $link equal? } " method which always returns f." }
 { $examples
-    "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
+    "To define a tuple class such that two instances are only equal if they are both the same instance, inherit from the " { $link identity-tuple } " class. This class defines a method on " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
-    { $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" }
+    { $code "TUPLE: foo < identity-tuple ;" }
     "By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:"
     { $unchecked-example "T{ foo } dup = ." "t" }
     { $unchecked-example "T{ foo } dup clone = ." "f" }
@@ -364,12 +417,6 @@ HELP: clone
 { $values { "obj" object } { "cloned" "a new object" } }
 { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
 
-HELP: type ( object -- n )
-{ $values { "object" object } { "n" "a type number" } }
-{ $description "Outputs an object's type number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
-
-{ type tag type>class } related-words
-
 HELP: ? ( ? true false -- true/false )
 { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
 { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
@@ -496,7 +543,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 +552,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 +610,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 -- ... )" } } }
@@ -585,6 +669,11 @@ HELP: bi@
         "[ p ] bi@"
         ">r p r> p"
     }
+    "The following two lines are also equivalent:"
+    { $code
+        "[ p ] bi@"
+        "[ p ] [ p ] bi*"
+    }
 } ;
 
 HELP: 2bi@
@@ -596,6 +685,11 @@ HELP: 2bi@
         "[ p ] 2bi@"
         ">r >r p r> r> p"
     }
+    "The following two lines are also equivalent:"
+    { $code
+        "[ p ] 2bi@"
+        "[ p ] [ p ] 2bi*"
+    }
 } ;
 
 HELP: tri@
@@ -607,6 +701,11 @@ HELP: tri@
         "[ p ] tri@"
         ">r >r p r> p r> p"
     }
+    "The following two lines are also equivalent:"
+    { $code
+        "[ p ] tri@"
+        "[ p ] [ p ] [ p ] tri*"
+    }
 } ;
 
 HELP: if ( cond true false -- )
@@ -705,19 +804,6 @@ HELP: null
     "The canonical empty class with no instances."
 } ;
 
-HELP: general-t
-{ $class-description
-    "The class of all objects not equal to " { $link f } "."
-}
-{ $examples
-    "Here is an implementation of " { $link if } " using generic words:"
-    { $code
-        "GENERIC# my-if 2 ( ? true false -- )"
-        "M: f my-if 2nip call ;"
-        "M: general-t my-if drop nip call ;"
-    }
-} ;
-
 HELP: most
 { $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
 { $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;

core/kernel/kernel.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel.private ;
+USING: kernel.private slots.private classes.tuple.private ;
 IN: kernel
 
 ! Stack stuff
@@ -99,14 +99,14 @@ DEFER: if
 
 ! Appliers
 : bi@ ( x y quot -- )
-    tuck 2slip call ; inline
+    dup bi* ; inline
 
 : tri@ ( x y z quot -- )
-    tuck >r bi@ r> call ; inline
+    dup dup tri* ; inline
 
 ! Double appliers
 : 2bi@ ( w x y z quot -- )
-    dup -roll 3slip call ; inline
+    dup 2bi* ; inline
 
 : while ( pred body tail -- )
     >r >r dup slip r> r> roll
@@ -114,12 +114,6 @@ DEFER: if
     [ 2nip call ] if ; inline
 
 ! Object protocol
-GENERIC: delegate ( obj -- delegate )
-
-M: object delegate drop f ;
-
-GENERIC: set-delegate ( delegate tuple -- )
-
 GENERIC: hashcode* ( depth obj -- code )
 
 M: object hashcode* 2drop 0 ;
@@ -130,6 +124,10 @@ GENERIC: equal? ( obj1 obj2 -- ? )
 
 M: object equal? 2drop f ;
 
+TUPLE: identity-tuple ;
+
+M: identity-tuple equal? 2drop f ;
+
 : = ( obj1 obj2 -- ? )
     2dup eq? [ 2drop t ] [ equal? ] if ; inline
 
@@ -142,18 +140,11 @@ M: object clone ;
 M: callstack clone (clone) ;
 
 ! Tuple construction
-GENERIC# get-slots 1 ( tuple slots -- ... )
+: construct-empty ( class -- tuple )
+    tuple-layout <tuple> ;
 
-GENERIC# set-slots 1 ( ... tuple slots -- )
+: construct-boa ( ... class -- tuple )
-
+    tuple-layout <tuple-boa> ;
-GENERIC: construct-empty ( class -- tuple )
-
-GENERIC: construct ( ... slots class -- tuple ) inline
-
-GENERIC: construct-boa ( ... class -- tuple )
-
-: construct-delegate ( delegate class -- tuple )
-    >r { set-delegate } r> construct ; inline
 
 ! Quotation building
 : 2curry ( obj1 obj2 quot -- curry )
@@ -194,8 +185,27 @@ GENERIC: construct-boa ( ... class -- tuple )
 
 <PRIVATE
 
+: hi-tag ( obj -- n ) 0 slot ; inline
+
 : declare ( spec -- ) drop ;
 
 : do-primitive ( number -- ) "Improper primitive call" throw ;
 
 PRIVATE>
+
+! Deprecated
+GENERIC: delegate ( obj -- delegate )
+
+M: object delegate drop f ;
+
+GENERIC: set-delegate ( delegate tuple -- )
+
+GENERIC# get-slots 1 ( tuple slots -- ... )
+
+GENERIC# set-slots 1 ( ... tuple slots -- )
+
+: construct ( ... slots class -- tuple )
+    construct-empty [ swap set-slots ] keep ; inline
+
+: construct-delegate ( delegate class -- tuple )
+    >r { set-delegate } r> construct ; inline

core/layouts/layouts-docs.factor

@@ -14,7 +14,7 @@ HELP: tag-mask
 { $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
 
 HELP: num-types
-{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link type } " primitive." } ;
+{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
 
 HELP: tag-number
 { $values { "class" class } { "n" "an integer or " { $link f } } }
@@ -76,7 +76,7 @@ HELP: bootstrap-cell-bits
 
 ARTICLE: "layouts-types" "Type numbers"
 "Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
-{ $subsection type }
+{ $subsection hi-tag }
 "Built-in type numbers can be converted to classes, and vice versa:"
 { $subsection type>class }
 { $subsection type-number }

core/math/intervals/intervals-tests.factor

@@ -188,7 +188,7 @@ IN: math.intervals.tests
         { max interval-max }
     }
     "math.ratios.private" vocab [
-        { / interval/ } add
+        { / interval/ } suffix
     ] when
     random ;
 

core/mirrors/mirrors-docs.factor

@@ -7,9 +7,6 @@ $nl
 "A mirror provides such a view of a tuple:"
 { $subsection mirror }
 { $subsection <mirror> }
-"An enum provides such a view of a sequence:"
-{ $subsection enum }
-{ $subsection <enum> }
 "Utility word used by developer tools which inspect objects:"
 { $subsection make-mirror }
 { $see-also "slots" } ;
@@ -44,11 +41,6 @@ HELP: >mirror<
 { $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
 { $description "Pushes the object being viewed in the mirror together with its slots." } ;
 
-HELP: enum
-{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
-$nl
-"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
-
 HELP: make-mirror
 { $values { "obj" object } { "assoc" assoc } }
 { $description "Creates an assoc which reflects the internal structure of the object." } ;

core/mirrors/mirrors.factor

@@ -48,27 +48,6 @@ M: mirror assoc-size mirror-slots length ;
 
 INSTANCE: mirror assoc
 
-TUPLE: enum seq ;
-
-C: <enum> enum
-
-M: enum at*
-    enum-seq 2dup bounds-check?
-    [ nth t ] [ 2drop f f ] if ;
-
-M: enum set-at enum-seq set-nth ;
-
-M: enum delete-at enum-seq delete-nth ;
-
-M: enum >alist ( enum -- alist )
-    enum-seq dup length swap 2array flip ;
-
-M: enum assoc-size enum-seq length ;
-
-M: enum clear-assoc enum-seq delete-all ;
-
-INSTANCE: enum assoc
-
 : sort-assoc ( assoc -- alist )
     >alist
     [ dup first unparse-short swap ] { } map>assoc

core/optimizer/control/control.factor

@@ -154,7 +154,7 @@ SYMBOL: potential-loops
     ] [
         node-class {
             { [ dup null class< ] [ drop f f ] }
-            { [ dup general-t class< ] [ drop t t ] }
+            { [ dup \ f class-not class< ] [ drop t t ] }
             { [ dup \ f class< ] [ drop f t ] }
             { [ t ] [ drop f f ] }
         } cond

core/optimizer/inlining/inlining.factor

@@ -70,12 +70,25 @@ DEFER: (flat-length)
     ] if ;
 
 ! Partial dispatch of math-generic words
+: normalize-math-class ( class -- class' )
+    {
+        fixnum bignum integer
+        ratio rational
+        float real
+        complex number
+        object
+    } [ class< ] with find nip ;
+
 : math-both-known? ( word left right -- ? )
     math-class-max swap specific-method ;
 
 : inline-math-method ( #call word -- node )
-    over node-input-classes first2 3dup math-both-known?
+    over node-input-classes
-    [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
+    [ first normalize-math-class ]
+    [ second normalize-math-class ] bi
+    3dup math-both-known?
+    [ math-method f splice-quot ]
+    [ 2drop 2drop t ] if ;
 
 : inline-method ( #call -- node )
     dup node-param {

core/optimizer/known-words/known-words.factor

@@ -60,7 +60,7 @@ sequences.private combinators ;
     [ value-literal sequence? ] [ drop f ] if ;
 
 : member-quot ( seq -- newquot )
-    [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
+    [ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
 
 : expand-member ( #call -- )
     dup node-in-d peek value-literal member-quot f splice-quot ;
@@ -75,7 +75,7 @@ sequences.private combinators ;
     dup node-in-d second dup value? [
         swap [
             value-literal 0 `input literal,
-            general-t 0 `output class,
+            \ f class-not 0 `output class,
         ] set-constraints
     ] [
         2drop
@@ -87,29 +87,6 @@ sequences.private combinators ;
     { { @ @ } [ 2drop t ] }
 } define-identities
 
-! type applied to an object of a known type can be folded
-: known-type? ( node -- ? )
-    node-class-first class-types length 1 number= ;
-
-: fold-known-type ( node -- node )
-    dup node-class-first class-types inline-literals ;
-
-\ type [
-    { [ dup known-type? ] [ fold-known-type ] }
-] define-optimizers
-
-! if the result of type is n, then the object has type n
-{ tag type } [
-    [
-        num-types get swap [
-            [
-                [ type>class object or 0 `input class, ] keep
-                0 `output literal,
-            ] set-constraints
-        ] curry each
-    ] "constraints" set-word-prop
-] each
-
 ! Specializers
 { 1+ 1- sq neg recip sgn } [
     { number } "specializer" set-word-prop

core/optimizer/math/math.factor

@@ -269,7 +269,7 @@ generic.standard system ;
 : comparison-constraints ( node true false -- )
     >r >r dup node set intervals dup [
         2dup
-        r> general-t (comparison-constraints)
+        r> \ f class-not (comparison-constraints)
         r> \ f (comparison-constraints)
     ] [
         r> r> 2drop 2drop

core/optimizer/specializers/specializers.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic hashtables kernel kernel.private math
 namespaces sequences vectors words strings layouts combinators
-sequences.private classes generic.standard assocs ;
+sequences.private classes generic.standard
+generic.standard.engines assocs ;
 IN: optimizer.specializers
 
 : (make-specializer) ( class picker -- quot )
@@ -32,7 +33,7 @@ IN: optimizer.specializers
 
 : method-declaration ( method -- quot )
     dup "method-generic" word-prop dispatch# object <array>
-    swap "method-class" word-prop add* ;
+    swap "method-class" word-prop prefix ;
 
 : specialize-method ( quot method -- quot' )
     method-declaration [ declare ] curry prepend ;

core/parser/parser.factor

@@ -294,7 +294,7 @@ M: no-word-error summary
     scan {
         { ";" [ tuple f ] }
         { "<" [ scan-word ";" parse-tokens ] }
-        [ >r tuple ";" parse-tokens r> add* ]
+        [ >r tuple ";" parse-tokens r> prefix ]
     } case ;
 
 ERROR: staging-violation word ;
@@ -365,7 +365,17 @@ ERROR: bad-number ;
 
 : (:) CREATE-WORD parse-definition ;
 
-: (M:) CREATE-METHOD parse-definition ;
+SYMBOL: current-class
+SYMBOL: current-generic
+
+: (M:)
+    CREATE-METHOD
+    [
+        [ "method-class" word-prop current-class set ]
+        [ "method-generic" word-prop current-generic set ]
+        [ ] tri
+        parse-definition
+    ] with-scope ;
 
 : scan-object ( -- object )
     scan-word dup parsing?
@@ -467,18 +477,22 @@ SYMBOL: interactive-vocabs
         nl
     ] when 2drop ;
 
-: filter-moved ( assoc -- newassoc )
+: filter-moved ( assoc1 assoc2 -- seq )
-    [
+    diff [
         drop where dup [ first ] when
         file get source-file-path =
-    ] assoc-subset ;
+    ] assoc-subset keys ;
 
-: removed-definitions ( -- definitions )
+: removed-definitions ( -- assoc1 assoc2 )
     new-definitions old-definitions
-    [ get first2 union ] bi@ diff ;
+    [ get first2 union ] bi@ ;
+
+: removed-classes ( -- assoc1 assoc2 )
+    new-definitions old-definitions
+    [ get second ] bi@ ;
 
 : smudged-usage ( -- usages referenced removed )
-    removed-definitions filter-moved keys [
+    removed-definitions filter-moved [
         outside-usages
         [
             empty? [ drop f ] [
@@ -495,8 +509,10 @@ SYMBOL: interactive-vocabs
 : fix-class-words ( -- )
     #! If a class word had a compound definition which was
     #! removed, it must go back to being a symbol.
-    new-definitions get first2 diff
+    new-definitions get first2
-    [ nip dup reset-generic define-symbol ] assoc-each ;
+    filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each
+    removed-classes
+    filter-moved [ class? ] subset [ reset-class ] each ;
 
 : forget-smudged ( -- )
     smudged-usage forget-all
@@ -505,9 +521,10 @@ SYMBOL: interactive-vocabs
 
 : finish-parsing ( lines quot -- )
     file get
-    [ record-form ] keep
+    [ record-form ]
-    [ record-definitions ] keep
+    [ record-definitions ]
-    record-checksum ;
+    [ record-checksum ]
+    tri ;
 
 : parse-stream ( stream name -- quot )
     [

core/prettyprint/prettyprint-tests.factor

@@ -57,8 +57,6 @@ unit-test
 
 [ ] [ \ integer see ] unit-test
 
-[ ] [ \ general-t see ] unit-test
-
 [ ] [ \ generic see ] unit-test
 
 [ ] [ \ duplex-stream see ] unit-test
@@ -192,7 +190,7 @@ unit-test
         "IN: prettyprint.tests"
         ": another-soft-break-layout ( node -- quot )"
         "    parse-error-file"
-        "    [ <reversed> \"hello world foo\" add ] [ ] make ;"
+        "    [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
     } ;
 
 [ t ] [

core/prettyprint/prettyprint.factor

@@ -7,7 +7,7 @@ vectors words prettyprint.backend prettyprint.sections
 prettyprint.config sorting splitting math.parser vocabs
 definitions effects classes.tuple io.files classes continuations
 hashtables classes.mixin classes.union classes.predicate
-combinators quotations ;
+classes.singleton combinators quotations ;
 
 : make-pprint ( obj quot -- block in use )
     [
@@ -254,6 +254,9 @@ M: predicate-class see-class*
     "predicate-definition" word-prop pprint-elements
     pprint-; block> block> ;
 
+M: singleton-class see-class* ( class -- )
+    \ SINGLETON: pprint-word pprint-word ;
+
 M: tuple-class see-class*
     <colon \ TUPLE: pprint-word
     dup pprint-word

core/quotations/quotations-tests.factor

@@ -10,8 +10,8 @@ IN: quotations.tests
 ] unit-test
 
 [ [ 1 2 3 4 ] ] [ [ 1 2 ] [ 3 4 ] append ] unit-test
-[ [ 1 2 3 ] ] [ [ 1 2 ] 3 add ] unit-test
+[ [ 1 2 3 ] ] [ [ 1 2 ] 3 suffix ] unit-test
-[ [ 3 1 2 ] ] [ [ 1 2 ] 3 add* ] unit-test
+[ [ 3 1 2 ] ] [ [ 1 2 ] 3 prefix ] unit-test
 
 [ [ "hi" ] ] [ "hi" 1quotation ] unit-test
 

core/sequences/sequences-docs.factor

@@ -61,8 +61,8 @@ ARTICLE: "sequences-access" "Accessing sequence elements"
 
 ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
 "Adding elements:"
-{ $subsection add }
+{ $subsection prefix }
-{ $subsection add* }
+{ $subsection suffix }
 "Removing elements:"
 { $subsection remove }
 { $subsection seq-diff } ;
@@ -641,22 +641,22 @@ HELP: push-new
 }
 { $side-effects "seq" } ;
 
-{ push push-new add add* } related-words
+{ push push-new prefix suffix } related-words
 
-HELP: add
+HELP: suffix
 { $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
 { $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the end of " { $snippet "seq" } "." }
 { $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
 { $examples
-    { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" }
+    { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 suffix ." "{ 1 2 3 4 }" }
 } ;
 
-HELP: add*
+HELP: prefix
 { $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
 { $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." }
 { $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." } 
 { $examples
-{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" }
+{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 prefix ." "{ 0 1 2 3 }" }
 } ;
 
 HELP: seq-diff
@@ -940,7 +940,7 @@ HELP: unclip
 { $values { "seq" sequence } { "rest" sequence } { "first" object } }
 { $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first." }
 { $examples
-    { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip add ." "{ 2 3 1 }" }
+    { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip suffix ." "{ 2 3 1 }" }
 } ;
 
 HELP: unclip-slice

core/sequences/sequences.factor

@@ -416,6 +416,9 @@ PRIVATE>
         swap >r [ push ] curry compose r> while
     ] keep { } like ; inline
 
+: follow ( obj quot -- seq )
+    >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
+
 : index ( obj seq -- n )
     [ = ] with find drop ;
 
@@ -478,18 +481,18 @@ M: sequence <=>
 
 : push-new ( elt seq -- ) [ delete ] 2keep push ;
 
-: add ( seq elt -- newseq )
+: prefix ( seq elt -- newseq )
-    over >r over length 1+ r> [
-        [ >r over length r> set-nth-unsafe ] keep
-        [ 0 swap copy ] keep
-    ] new-like ;
-
-: add* ( seq elt -- newseq )
     over >r over length 1+ r> [
         [ 0 swap set-nth-unsafe ] keep
         [ 1 swap copy ] keep
     ] new-like ;
 
+: suffix ( seq elt -- newseq )
+    over >r over length 1+ r> [
+        [ >r over length r> set-nth-unsafe ] keep
+        [ 0 swap copy ] keep
+    ] new-like ;
+
 : seq-diff ( seq1 seq2 -- newseq )
     swap [ member? not ] curry subset ;
 

core/slots/slots.factor

@@ -14,7 +14,7 @@ C: <slot-spec> slot-spec
     >r create-method r> define ;
 
 : define-slot-word ( class slot word quot -- )
-    rot >fixnum add* define-typecheck ;
+    rot >fixnum prefix define-typecheck ;
 
 : reader-quot ( decl -- quot )
     [
@@ -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 ;

core/splitting/splitting.factor

@@ -76,5 +76,5 @@ INSTANCE: groups sequence
             1 head-slice* [
                 "\r" ?tail drop "\r" split
             ] map
-        ] keep peek "\r" split add concat
+        ] keep peek "\r" split suffix concat
     ] if ;

core/syntax/syntax-docs.factor

@@ -243,7 +243,7 @@ HELP: flushable
 HELP: t
 { $syntax "t" }
 { $values { "t" "the canonical truth value" } }
-{ $description "The canonical instance of " { $link general-t } ". It is just a symbol." } ;
+{ $class-description "The canonical truth value, which is an instance of itself." } ;
 
 HELP: f
 { $syntax "f" }

core/syntax/syntax.factor

@@ -5,8 +5,8 @@ byte-vectors definitions generic hashtables kernel math
 namespaces parser sequences strings sbufs vectors words
 quotations io assocs splitting classes.tuple generic.standard
 generic.math classes io.files vocabs float-arrays float-vectors
-classes.union classes.mixin classes.predicate compiler.units
+classes.union classes.mixin classes.predicate classes.singleton
-combinators debugger ;
+compiler.units combinators debugger ;
 IN: bootstrap.syntax
 
 ! These words are defined as a top-level form, instead of with
@@ -55,7 +55,7 @@ IN: bootstrap.syntax
     "BIN:" [ 2 parse-base ] define-syntax
 
     "f" [ f parsed ] define-syntax
-    "t" "syntax" lookup define-symbol
+    "t" "syntax" lookup define-singleton-class
 
     "CHAR:" [
         scan {
@@ -154,6 +154,11 @@ IN: bootstrap.syntax
         parse-definition define-predicate-class
     ] define-syntax
 
+    "SINGLETON:" [
+        scan create-class-in
+        dup save-location define-singleton-class
+    ] define-syntax
+
     "TUPLE:" [
         parse-tuple-definition define-tuple-class
     ] define-syntax
@@ -185,4 +190,10 @@ IN: bootstrap.syntax
         [ \ >> parse-until >quotation ] with-compilation-unit
         call
     ] define-syntax
+
+    "call-next-method" [
+        current-class get literalize parsed
+        current-generic get literalize parsed
+        \ (call-next-method) parsed
+    ] define-syntax
 ] with-compilation-unit

core/system/system-docs.factor

@@ -1,20 +1,12 @@
 USING: generic help.markup help.syntax kernel math memory
-namespaces sequences kernel.private strings ;
+namespaces sequences kernel.private strings classes.singleton ;
 IN: system
 
-ARTICLE: "os" "System interface"
+ABOUT: "system"
-"Operating system detection:"
+
-{ $subsection os }
+ARTICLE: "system" "System interface"
-{ $subsection unix? }
+{ $subsection "cpu" }
-{ $subsection macosx? }
+{ $subsection "os" }
-{ $subsection solaris? }
-{ $subsection windows? }
-{ $subsection winnt? }
-{ $subsection win32? }
-{ $subsection win64? }
-{ $subsection wince? }
-"Processor detection:"
-{ $subsection cpu }
 "Reading environment variables:"
 { $subsection os-env }
 { $subsection os-envs }
@@ -27,63 +19,51 @@ ARTICLE: "os" "System interface"
 { $subsection exit }
 { $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ;
 
-ABOUT: "os"
+ARTICLE: "cpu" "Processor Detection"
+"Processor detection:"
+{ $subsection cpu }
+"Supported processors:"
+{ $subsection x86.32 }
+{ $subsection x86.64 }
+{ $subsection ppc }
+{ $subsection arm }
+"Processor families:"
+{ $subsection x86 } ;
+
+ARTICLE: "os" "Operating System Detection"
+"Operating system detection:"
+{ $subsection os }
+"Supported operating systems:"
+{ $subsection freebsd }
+{ $subsection linux }
+{ $subsection macosx }
+{ $subsection openbsd }
+{ $subsection netbsd }
+{ $subsection solaris }
+{ $subsection wince }
+{ $subsection winnt }
+"Operating system families:"
+{ $subsection bsd }
+{ $subsection unix }
+{ $subsection windows } ;
+
 
 HELP: cpu
-{ $values { "cpu" string } }
+{ $values { "class" singleton-class } }
 { $description
-    "Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:"
+    "Outputs a singleton class with the name of the current CPU architecture."
-    { $code "x86.32" "x86.64" "ppc" "arm" }
 } ;
 
 HELP: os
-{ $values { "os" string } }
+{ $values { "class" singleton-class } }
 { $description
-    "Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:"
+    "Outputs a singleton class with the name of the current operating system family."
-    { $code
-        "freebsd"
-        "linux"
-        "macosx"
-        "openbsd"
-        "netbsd"
-        "solaris"
-        "wince"
-        "winnt"
-    }
 } ;
 
 HELP: embedded?
 { $values { "?" "a boolean" } }
 { $description "Tests if this Factor instance is embedded in another application." } ;
 
-HELP: windows?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows." } ;
-
-HELP: winnt?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows XP or Vista." } ;
-
-HELP: wince?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows CE." } ;
-
-HELP: macosx?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Mac OS X." } ;
-
-HELP: linux?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Linux." } ;
-
-HELP: solaris?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Solaris." } ;
-
-HELP: bsd?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on FreeBSD/OpenBSD/NetBSD." } ;
-
 HELP: exit ( n -- )
 { $values { "n" "an integer exit code" } }
 { $description "Exits the Factor process." } ;
@@ -120,14 +100,6 @@ HELP: set-os-envs
 
 { os-env os-envs set-os-envs } related-words
 
-HELP: win32?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on 32-bit Windows." } ;
-
-HELP: win64?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on 64-bit Windows." } ;
-
 HELP: image
 { $values { "path" "a pathname string" } }
 { $description "Outputs the pathname of the currently running Factor image." } ;
@@ -135,7 +107,3 @@ HELP: image
 HELP: vm
 { $values { "path" "a pathname string" } }
 { $description "Outputs the pathname of the currently running Factor VM." } ;
-
-HELP: unix?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ;

core/system/system-tests.factor

@@ -1,11 +1,11 @@
 USING: math tools.test system prettyprint namespaces kernel ;
 IN: system.tests
 
-wince? [
+os wince? [
     [ ] [ os-envs . ] unit-test
 ] unless
 
-unix? [
+os unix? [
     [ ] [ os-envs "envs" set ] unit-test
     [ ] [ { { "A" "B" } } set-os-envs ] unit-test
     [ "B" ] [ "A" os-env ] unit-test