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

core/alien/alien-docs.factor

@@ -65,8 +65,7 @@ HELP: dlclose ( dll -- )
 
 HELP: load-library
 { $values { "name" "a string" } { "dll" "a DLL handle" } }
-{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
+{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
-{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
 
 HELP: add-library
 { $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
@@ -211,8 +210,9 @@ $nl
 ARTICLE: "alien-callback" "Calling Factor from C"
 "Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
 { $subsection alien-callback }
-"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
+"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
-{ $subsection "alien-callback-gc" } ;
+{ $subsection "alien-callback-gc" }
+{ $see-also "byte-arrays-gc" } ;
 
 ARTICLE: "dll.private" "DLL handles"
 "DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "."
@@ -291,7 +291,7 @@ $nl
 "The C library interface is entirely self-contained; there is no C code which one must write in order to wrap a library."
 $nl
 "C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
-{ $warning "Since C does not retain runtime type information or do any kind of runtime type checking, any C library interface is not pointer safe. Improper use of C functions can crash the runtime or corrupt memory in unpredictible ways." }
+{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
 { $subsection "loading-libs" }
 { $subsection "alien-invoke" }
 { $subsection "alien-callback" }

core/alien/alien-tests.factor

@@ -1,7 +1,7 @@
 IN: alien.tests
-USING: alien alien.accessors byte-arrays arrays kernel
+USING: alien alien.accessors alien.syntax byte-arrays arrays
-kernel.private namespaces tools.test sequences libc math system
+kernel kernel.private namespaces tools.test sequences libc math
-prettyprint layouts ;
+system prettyprint layouts ;
 
 [ t ] [ -1 <alien> alien-address 0 > ] unit-test
 
@@ -68,3 +68,7 @@ cell 8 = [
 [ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
 
 [ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
+
+[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
+
+[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test

core/alien/alien.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel math namespaces sequences system
-kernel.private tuples bit-arrays byte-arrays float-arrays ;
+kernel.private tuples bit-arrays byte-arrays float-arrays 
+arrays ;
 IN: alien
 
 ! Some predicate classes used by the compiler for optimization
@@ -57,7 +58,7 @@ TUPLE: library path abi dll ;
     over dup [ dlopen ] when \ library construct-boa ;
 
 : load-library ( name -- dll )
-    library library-dll ;
+    library dup [ library-dll ] when ;
 
 : add-library ( name path abi -- )
     <library> swap libraries get set-at ;

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

@@ -158,6 +158,19 @@ HELP: define-out
 { $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
 { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
 
+ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
+"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
+$nl
+"In particular, a byte array can only be passed as a parameter if the the C function does not use the parameter after one of the following occurs:"
+{ $list
+    "the C function returns"
+    "the C function calls Factor code via a callback"
+}
+"Returning from C to Factor, as well as invoking Factor code via a callback, may trigger garbage collection, and if the function had stored a pointer to the byte array somewhere, this pointer may cease to be valid."
+$nl
+"If this condition is not satisfied, " { $link "malloc" } " must be used instead."
+{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
+
 ARTICLE: "c-out-params" "Output parameters in C"
 "A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
 $nl
@@ -229,13 +242,11 @@ $nl
 { $subsection <c-object> }
 { $subsection <c-array> }
 { $warning
-"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the function does not store a pointer to the byte array in some global structure, or retain it in any way after returning."
+"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
-$nl
-"Long-lived data for use by C libraries can be allocated manually, just as when programming in C. See " { $link "malloc" } "." }
 { $see-also "c-arrays" } ;
 
 ARTICLE: "malloc" "Manual memory management"
-"Sometimes data passed to C functions must be allocated at a fixed address, and so garbage collector managed byte arrays cannot be used. See the warning at the bottom of " { $link "c-byte-arrays" } " for a description of when this is the case."
+"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
 $nl
 "Allocating a C datum with a fixed address:"
 { $subsection malloc-object }
@@ -245,8 +256,6 @@ $nl
 { $subsection malloc }
 { $subsection calloc }
 { $subsection realloc }
-"The return value of the above three words must always be checked for a memory allocation failure:"
-{ $subsection check-ptr }
 "You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
 { $subsection free }
 "You can unsafely copy a range of bytes from one memory location to another:"
@@ -271,20 +280,25 @@ ARTICLE: "c-strings" "C strings"
 { $subsection string>u16-alien }
 { $subsection malloc-char-string }
 { $subsection malloc-u16-string }
-"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } "."
+"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
 $nl
 "Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
 { $subsection alien>char-string }
-{ $subsection alien>u16-string } ;
+{ $subsection alien>u16-string }
+"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
 
 ARTICLE: "c-data" "Passing data between Factor and C"
-"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
+"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
+$nl
+"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
 { $subsection "c-types-specs" }
 { $subsection "c-byte-arrays" }
 { $subsection "malloc" }
 { $subsection "c-strings" }
 { $subsection "c-arrays" }
 { $subsection "c-out-params" }
+"Important guidelines for passing data in byte arrays:"
+{ $subsection "byte-arrays-gc" }
 "C-style enumerated types are supported:"
 { $subsection POSTPONE: C-ENUM: }
 "C types can be aliased for convenience and consitency with native library documentation:"

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

@@ -262,8 +262,8 @@ M: long-long-type box-return ( type -- )
         r> add*
     ] when ;
 
-: malloc-file-contents ( path -- alien )
+: malloc-file-contents ( path -- alien len )
-    binary file-contents malloc-byte-array ;
+    binary file-contents dup malloc-byte-array swap length ;
 
 [
     [ alien-cell ]

core/alien/compiler/compiler-tests.factor

@@ -330,11 +330,11 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
 
 ! Hack; if we're on ARM, we probably don't have much RAM, so
 ! skip this test.
-cpu "arm" = [
+! cpu "arm" = [
-    [ "testing" ] [
+!     [ "testing" ] [
-        "testing" callback-5a callback_test_1
+!         "testing" callback-5a callback_test_1
-    ] unit-test
+!     ] unit-test
-] unless
+! ] unless
 
 : callback-6
     "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;

core/alien/syntax/syntax.factor

@@ -32,7 +32,7 @@ PRIVATE>
     >r >r swapd roll indirect-quot r> r>
     -rot define-declared ;
 
-: DLL" skip-blank parse-string dlopen parsed ; parsing
+: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
 
 : ALIEN: scan string>number <alien> parsed ; parsing
 

core/bootstrap/primitives.factor

@@ -30,6 +30,7 @@ crossref off
 "syntax" vocab vocab-words bootstrap-syntax set
 H{ } clone dictionary set
 H{ } clone changed-words set
+H{ } clone root-cache set
 
 ! Trivial recompile hook. We don't want to touch the code heap
 ! during stage1 bootstrap, it would just waste time.
@@ -87,11 +88,7 @@ call
     "words.private"
     "vectors"
     "vectors.private"
-} [
+} [ create-vocab drop ] each
-    dup find-vocab-root swap create-vocab
-    [ set-vocab-root ] keep
-    f swap set-vocab-source-loaded?
-] each
 
 H{ } clone source-files set
 H{ } clone class<map set

core/bootstrap/stage1.factor

@@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ;
                 "listener" vocab
                 [ restarts. vocab-main execute ]
                 [ die ] if*
+                1 exit
             ] recover
         ] [
             "Cannot find " write write "." print

core/bootstrap/stage2.factor

@@ -25,7 +25,7 @@ SYMBOL: bootstrap-time
     "exclude" "include"
     [ get-global " " split [ empty? not ] subset ] 2apply
     seq-diff
-    [ "bootstrap." swap append require ] each ;
+    [ "bootstrap." prepend require ] each ;
 
 : compile-remaining ( -- )
     "Compiling remaining words..." print flush

core/bootstrap/syntax.factor

@@ -3,9 +3,7 @@
 USING: words sequences vocabs kernel ;
 IN: bootstrap.syntax
 
-"syntax" create-vocab
+"syntax" create-vocab drop
-"resource:core" over set-vocab-root
-f swap set-vocab-source-loaded?
 
 {
     "!"

core/classes/classes-tests.factor

@@ -1,6 +1,6 @@
 USING: alien arrays definitions generic assocs hashtables io
 kernel math namespaces parser prettyprint sequences strings
-tools.test vectors words quotations classes io.streams.string
+tools.test vectors words quotations classes
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units ;
 IN: classes.tests
@@ -28,6 +28,8 @@ TUPLE: second-one ;
 UNION: both first-one union-class ;
 
 [ t ] [ both tuple classes-intersect? ] unit-test
+[ null ] [ vector virtual-sequence class-and ] unit-test
+[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
 
 [ t ] [ \ fixnum \ integer class< ] unit-test
 [ t ] [ \ fixnum \ fixnum class< ] unit-test
@@ -61,10 +63,6 @@ UNION: c a b ;
 UNION: bah fixnum alien ;
 [ bah ] [ \ bah? "predicating" word-prop ] unit-test
 
-! Test generic see and parsing
-[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
-[ [ \ bah see ] with-string-writer ] unit-test
-
 ! Test redefinition of classes
 UNION: union-1 fixnum float ;
 
@@ -178,6 +176,8 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ;
 
 [ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
 
+USE: io.streams.string
+
 2 [
     [ "mixin-forget-test" forget-source ] with-compilation-unit
     
@@ -222,3 +222,7 @@ MIXIN: flat-mx-2     INSTANCE: flat-mx-2 flat-mx-1
 TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
 
 [ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
+
+! Test generic see and parsing
+[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
+[ [ \ bah see ] with-string-writer ] unit-test

core/classes/union/union.factor

@@ -13,7 +13,7 @@ PREDICATE: class union-class
         drop [ drop f ]
     ] [
         unclip first "predicate" word-prop swap
-        [ >r "predicate" word-prop [ dup ] swap append r> ]
+        [ >r "predicate" word-prop [ dup ] prepend r> ]
         assoc-map alist>quot
     ] if ;
 

core/combinators/combinators.factor

@@ -80,7 +80,7 @@ M: hashtable hashcode*
 
 : hash-case-quot ( default assoc -- quot )
     hash-case-table hash-dispatch-quot
-    [ dup hashcode >fixnum ] swap append ;
+    [ dup hashcode >fixnum ] prepend ;
 
 : contiguous-range? ( keys -- from to ? )
     dup [ fixnum? ] all? [

core/command-line/command-line.factor

@@ -7,12 +7,12 @@ splitting io.files ;
 
 : run-bootstrap-init ( -- )
     "user-init" get [
-        home ".factor-boot-rc" path+ ?run-file
+        home ".factor-boot-rc" append-path ?run-file
     ] when ;
 
 : run-user-init ( -- )
     "user-init" get [
-        home ".factor-rc" path+ ?run-file
+        home ".factor-rc" append-path ?run-file
     ] when ;
 
 : cli-var-param ( name value -- ) swap set-global ;

core/compiler/tests/intrinsics.factor

@@ -385,7 +385,7 @@ cell 8 = [
 [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
 
-: xword-def word-def [ { fixnum } declare ] swap append ;
+: xword-def word-def [ { fixnum } declare ] prepend ;
 
 [ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
 [ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test

core/debugger/debugger.factor

@@ -214,7 +214,7 @@ M: check-closed summary
     drop "Attempt to perform I/O on closed stream" ;
 
 M: check-method summary
-    drop "Invalid parameters for define-method" ;
+    drop "Invalid parameters for create-method" ;
 
 M: check-tuple summary
     drop "Invalid class for define-constructor" ;

core/definitions/definitions-tests.factor

@@ -1,10 +1,10 @@
 IN: definitions.tests
 USING: tools.test generic kernel definitions sequences
-compiler.units ;
+compiler.units words ;
 
 TUPLE: combination-1 ;
 
-M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
+M: combination-1 perform-combination 2drop [ ] ;
 
 M: combination-1 make-default-method 2drop [ "No method" throw ] ;
 
@@ -13,7 +13,7 @@ SYMBOL: generic-1
 [
     generic-1 T{ combination-1 } define-generic
 
-    [ ] object \ generic-1 define-method
+    object \ generic-1 create-method [ ] define
 ] with-compilation-unit
 
 [ ] [

core/generic/generic-docs.factor

@@ -34,7 +34,7 @@ $nl
 { $subsection define-generic }
 { $subsection define-simple-generic }
 "Methods can be added to existing generic words:"
-{ $subsection define-method }
+{ $subsection create-method }
 "Method definitions can be looked up:"
 { $subsection method }
 { $subsection methods }
@@ -123,7 +123,7 @@ HELP: method
 { $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
 { $description "Looks up a method definition." } ;
 
-{ method define-method POSTPONE: M: } related-words
+{ method create-method POSTPONE: M: } related-words
 
 HELP: <method>
 { $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
@@ -140,16 +140,17 @@ HELP: order
 HELP: check-method
 { $values { "class" class } { "generic" generic } }
 { $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
-{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
+{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
 
 HELP: with-methods
 { $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
 { $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
 $low-level-note ;
 
-HELP: define-method
+HELP: create-method
-{ $values { "quot" quotation } { "class" class } { "generic" generic } }
+{ $values { "class" class } { "generic" generic } { "method" method-body } }
-{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
+{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
+{ $notes "To define a method, pass the output value to " { $link define } "." } ;
 
 HELP: implementors
 { $values { "class" class } { "seq" "a sequence of generic words" } }

core/generic/generic-tests.factor

@@ -238,3 +238,31 @@ M: sequence generic-forget-test-2 = ;
     \ = usage [ word? ] subset
     [ word-name "generic-forget-test-2/sequence" = ] contains?
 ] unit-test
+
+GENERIC: generic-forget-test-3
+
+M: f generic-forget-test-3 ;
+
+[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
+
+[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
+
+[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
+
+[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
+
+[ f ] [ f generic-forget-test-3 ] unit-test
+
+: a-word ;
+
+GENERIC: a-generic
+
+M: integer a-generic a-word ;
+
+[ ] [ \ integer \ a-generic method "m" set ] unit-test
+
+[ t ] [ "m" get \ a-word usage memq? ] unit-test
+
+[ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test
+
+[ f ] [ "m" get \ a-word usage memq? ] unit-test

core/generic/generic.factor

@@ -17,10 +17,6 @@ M: object perform-combination
     #! the method will throw an error. We don't want that.
     nip [ "Invalid method combination" throw ] curry [ ] like ;
 
-GENERIC: method-prologue ( class combination -- quot )
-
-M: object method-prologue 2drop [ ] ;
-
 GENERIC: make-default-method ( generic combination -- method )
 
 PREDICATE: word generic "combination" word-prop >boolean ;
@@ -50,55 +46,49 @@ TUPLE: check-method class generic ;
 : check-method ( class generic -- class generic )
     over class? over generic? and [
         \ check-method construct-boa throw
-    ] unless ;
+    ] unless ; inline
 
-: with-methods ( word quot -- )
+: with-methods ( generic quot -- )
     swap [ "methods" word-prop swap call ] keep make-generic ;
     inline
 
 : method-word-name ( class word -- string )
     word-name "/" rot word-name 3append ;
 
-: make-method-def ( quot class generic -- quot )
+PREDICATE: word method-body
-    "combination" word-prop method-prologue swap append ;
+    "method-generic" word-prop >boolean ;
-
-PREDICATE: word method-body "method-def" word-prop >boolean ;
 
 M: method-body stack-effect
     "method-generic" word-prop stack-effect ;
 
-: method-word-props ( quot class generic -- assoc )
+: method-word-props ( class generic -- assoc )
     [
         "method-generic" set
         "method-class" set
-        "method-def" set
     ] H{ } make-assoc ;
 
-: <method> ( quot class generic -- method )
+: <method> ( class generic -- method )
     check-method
-    [ make-method-def ] 3keep
     [ method-word-props ] 2keep
     method-word-name f <word>
-    tuck set-word-props
+    [ set-word-props ] keep ;
-    dup rot define ;
 
-: redefine-method ( quot class generic -- )
+: reveal-method ( method class generic -- )
-    [ method swap "method-def" set-word-prop ] 3keep
+    [ set-at ] with-methods ;
-    [ make-method-def ] 2keep
-    method swap define ;
 
-: define-method ( quot class generic -- )
+: create-method ( class generic -- method )
-    >r bootstrap-word r>
+    2dup method dup [
-    2dup method [
+        2nip
-        redefine-method
     ] [
-        [ <method> ] 2keep
+        drop [ <method> dup ] 2keep reveal-method
-        [ set-at ] with-methods
     ] if ;
 
+: <default-method> ( generic combination -- method )
+    object bootstrap-word pick <method>
+    [ -rot make-default-method define ] keep ;
+
 : define-default-method ( generic combination -- )
-    dupd make-default-method object bootstrap-word pick <method>
+    dupd <default-method> "default-method" set-word-prop ;
-    "default-method" set-word-prop ;
 
 ! Definition protocol
 M: method-spec where
@@ -108,30 +98,31 @@ M: method-spec set-where
     first2 method set-where ;
 
 M: method-spec definer
-    drop \ M: \ ; ;
+    first2 method definer ;
 
 M: method-spec definition
-    first2 method dup
+    first2 method definition ;
-    [ "method-def" word-prop ] when ;
 
 : forget-method ( class generic -- )
-    check-method
+    dup generic? [
         [ delete-at* ] with-methods
-    [ forget-word ] [ drop ] if ;
+        [ forget-word ] [ drop ] if
+    ] [
+        2drop
+    ] if ;
 
 M: method-spec forget*
-    first2 forget-method ;
+    first2 method forget* ;
 
 M: method-body definer
     drop \ M: \ ; ;
 
-M: method-body definition
-    "method-def" word-prop ;
-
 M: method-body forget*
+    dup "forgotten" word-prop [ drop ] [
         dup "method-class" word-prop
-    swap "method-generic" word-prop
+        over "method-generic" word-prop forget-method
-    forget-method ;
+        t "forgotten" set-word-prop
+    ] if ;
 
 : implementors* ( classes -- words )
     all-words [
@@ -163,16 +154,12 @@ M: assoc update-methods ( assoc -- )
         make-generic
     ] if ;
 
-GENERIC: subwords ( word -- seq )
-
-M: word subwords drop f ;
-
 M: generic subwords
     dup "methods" word-prop values
     swap "default-method" word-prop add ;
 
 M: generic forget-word
-    dup subwords [ forget-word ] each (forget-word) ;
+    dup subwords [ forget ] each (forget-word) ;
 
 : xref-generics ( -- )
     all-words [ subwords [ xref ] each ] each ;

core/generic/math/math.factor

@@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
 
 : applicable-method ( generic class -- quot )
     over method
-    [ word-def ]
+    [ 1quotation ]
     [ default-math-method ] ?if ;
 
 : object-method ( generic -- quot )
@@ -53,7 +53,7 @@ TUPLE: no-math-method left right generic ;
     2dup and [
         2dup math-upgrade >r
         math-class-max over order min-class applicable-method
-        r> swap append
+        r> prepend
     ] [
         2drop object-method
     ] if ;

core/generic/standard/standard.factor

@@ -8,10 +8,6 @@ IN: generic.standard
 
 TUPLE: standard-combination # ;
 
-M: standard-combination method-prologue
-    standard-combination-# object
-    <array> swap add* [ declare ] curry ;
-
 C: <standard-combination> standard-combination
 
 SYMBOL: (dispatch#)
@@ -165,7 +161,7 @@ C: <hook-combination> hook-combination
     0 (dispatch#) [
         swap slip
         hook-combination-var [ get ] curry
-        swap append
+        prepend
     ] with-variable ; inline
 
 M: hook-combination make-default-method
@@ -174,7 +170,7 @@ M: hook-combination make-default-method
 M: hook-combination perform-combination
     [
         standard-methods
-        [ [ drop ] swap append ] assoc-map
+        [ [ drop ] prepend ] assoc-map
         single-combination
     ] with-hook ;
 

core/inference/class/class-tests.factor

@@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic
 sequences words inference.class quotations alien
 alien.c-types strings sbufs sequences.private
 slots.private combinators definitions compiler.units
-system layouts ;
+system layouts vectors ;
 
 ! Make sure these compile even though this is invalid code
 [ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@@ -294,4 +294,6 @@ cell-bits 32 = [
     \ >= inlined?
 ] unit-test
 
-
+[ t ] [
+    [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
+] unit-test

core/io/encodings/binary/binary.factor

@@ -1,3 +1,8 @@
 ! Copyright (C) 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: io.encodings.binary SYMBOL: binary
+USING: io.encodings kernel ;
+IN: io.encodings.binary
+
+TUPLE: binary ;
+M: binary <encoder> drop ;
+M: binary <decoder> drop ;

core/io/encodings/encodings-docs.factor

@@ -44,25 +44,21 @@ $nl { $vocab-link "io.encodings.utf16" } ;
 
 ARTICLE: "encodings-protocol" "Encoding protocol"
 "An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again."
-{ $subsection decode-step }
+{ $subsection decode-char }
-{ $subsection init-decoder }
+{ $subsection encode-char }
-{ $subsection stream-write-encoded } ;
+"The following methods are optional:"
+{ $subsection <encoder> }
+{ $subsection <decoder> } ;
 
-HELP: decode-step ( buf char encoding -- )
+HELP: decode-char ( stream encoding -- char/f )
-{ $values { "buf" "A string buffer which characters can be pushed to" }
+{ $values { "stream" "an underlying input stream" }
-    { "char" "An octet which is read from a stream" }
     { "encoding" "An encoding descriptor tuple" } }
-{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ;
+{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
 
-HELP: stream-write-encoded ( string stream encoding -- )
+HELP: encode-char ( char stream encoding -- )
-{ $values { "string" "a string" }
+{ $values { "char" "a character" }
-    { "stream" "an output stream" }
+    { "stream" "an underlying output stream" }
     { "encoding" "an encoding descriptor" } }
-{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ;
+{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ;
 
-HELP: init-decoder ( stream encoding -- encoding )
+{ encode-char decode-char } related-words
-{ $values { "stream" "an input stream" }
-    { "encoding" "an encoding descriptor" } }
-{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ;
-
-{ init-decoder decode-step stream-write-encoded } related-words

core/io/encodings/encodings.factor

@@ -2,62 +2,43 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sbufs vectors namespaces
 growable strings io classes continuations combinators
-io.styles io.streams.plain io.encodings.binary splitting
+io.styles io.streams.plain splitting
-io.streams.duplex byte-arrays ;
+io.streams.duplex byte-arrays sequences.private ;
 IN: io.encodings
 
 ! The encoding descriptor protocol
 
-GENERIC: decode-step ( buf char encoding -- )
+GENERIC: decode-char ( stream encoding -- char/f )
-M: object decode-step drop swap push ;
 
-GENERIC: init-decoder ( stream encoding -- encoding )
+GENERIC: encode-char ( char stream encoding -- )
-M: tuple-class init-decoder construct-empty init-decoder ;
-M: object init-decoder nip ;
 
-GENERIC: stream-write-encoded ( string stream encoding -- byte-array )
+GENERIC: <decoder> ( stream decoding -- newstream )
-M: object stream-write-encoded drop stream-write ;
 
-! Decoding
+: replacement-char HEX: fffd ;
+
+TUPLE: decoder stream code cr ;
 
 TUPLE: decode-error ;
 
 : decode-error ( -- * ) \ decode-error construct-empty throw ;
 
-SYMBOL: begin
+GENERIC: <encoder> ( stream encoding -- newstream )
 
-: push-decoded ( buf ch -- buf ch state )
+TUPLE: encoder stream code ;
-    over push 0 begin ;
 
-: push-replacement ( buf -- buf ch state )
+TUPLE: encode-error ;
-    ! This is the replacement character
-    HEX: fffd push-decoded ;
 
-: space ( resizable -- room-left )
+: encode-error ( -- * ) \ encode-error construct-empty throw ;
-    dup underlying swap [ length ] 2apply - ;
 
-: full? ( resizable -- ? ) space zero? ;
+! Decoding
 
-: end-read-loop ( buf ch state stream quot -- string/f )
+<PRIVATE
-    2drop 2drop >string f like ;
 
-: decode-read-loop ( buf stream encoding -- string/f )
+M: tuple-class <decoder> construct-empty <decoder> ;
-    pick full? [ 2drop >string ] [
+M: tuple <decoder> f decoder construct-boa ;
-        over stream-read1 [
-            -rot tuck >r >r >r dupd r> decode-step r> r>
-            decode-read-loop
-        ] [ 2drop >string f like ] if*
-    ] if ;
 
-: decode-read ( length stream encoding -- string )
+: >decoder< ( decoder -- stream encoding )
-    rot <sbuf> -rot decode-read-loop ;
+    { decoder-stream decoder-code } get-slots ;
-
-TUPLE: decoder code cr ;
-: <decoder> ( stream encoding -- newstream )
-    dup binary eq? [ drop ] [
-        dupd init-decoder { set-delegate set-decoder-code }
-        decoder construct
-    ] if ;
 
 : cr+ t swap set-decoder-cr ; inline
 
@@ -82,72 +63,78 @@ TUPLE: decoder code cr ;
     over decoder-cr [
         over cr-
         "\n" ?head [
-            swap stream-read1 [ add ] when*
+            over stream-read1 [ add ] when*
-        ] [ nip ] if
+        ] when
-    ] [ nip ] if ;
+    ] when nip ;
+
+: read-loop ( n stream -- string )
+    SBUF" " clone [
+        [
+            >r nip stream-read1 dup
+            [ r> push f ] [ r> 2drop t ] if
+        ] 2curry find-integer drop
+    ] keep "" like f like ;
 
 M: decoder stream-read
-    tuck { delegate decoder-code } get-slots decode-read fix-read ;
+    tuck read-loop fix-read ;
 
 M: decoder stream-read-partial stream-read ;
 
-: decoder-read-until ( stream delim -- ch )
+: (read-until) ( buf quot -- string/f sep/f )
-    ! Copied from { c-reader stream-read-until }!!!
+    ! quot: -- char stop?
-    over stream-read1 dup [
+    dup call
-        dup pick memq? [ 2nip ] [ , decoder-read-until ] if
+    [ >r drop "" like r> ]
-    ] [
+    [ pick push (read-until) ] if ; inline
-        2nip
-    ] if ;
 
 M: decoder stream-read-until
-    ! Copied from { c-reader stream-read-until }!!!
+    SBUF" " clone -rot >decoder<
-    [ swap decoder-read-until ] "" make
+    [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
-    swap over empty? over not and [ 2drop f f ] when ;
+    (read-until) ;
 
 : fix-read1 ( stream char -- char )
     over decoder-cr [
         over cr-
         dup CHAR: \n = [
-            drop stream-read1
+            drop dup stream-read1
-        ] [ nip ] if
+        ] when
-    ] [ nip ] if ;
+    ] when nip ;
 
 M: decoder stream-read1
-    1 swap stream-read f like [ first ] [ f ] if* ;
+    dup >decoder< decode-char fix-read1 ;
 
 M: decoder stream-readln ( stream -- str )
     "\r\n" over stream-read-until handle-readln ;
 
+M: decoder dispose decoder-stream dispose ;
+
 ! Encoding
+M: tuple-class <encoder> construct-empty <encoder> ;
+M: tuple <encoder> encoder construct-boa ;
 
-TUPLE: encode-error ;
+: >encoder< ( encoder -- stream encoding )
-
+    { encoder-stream encoder-code } get-slots ;
-: encode-error ( -- * ) \ encode-error construct-empty throw ;
-
-TUPLE: encoder code ;
-: <encoder> ( stream encoding -- newstream )
-    dup binary eq? [ drop ] [
-        construct-empty { set-delegate set-encoder-code }
-        encoder construct
-    ] if ;
 
 M: encoder stream-write1
-    >r 1string r> stream-write ;
+    >encoder< encode-char ;
 
 M: encoder stream-write
-    { delegate encoder-code } get-slots stream-write-encoded ;
+    >encoder< [ encode-char ] 2curry each ;
 
-M: encoder dispose delegate dispose ;
+M: encoder dispose encoder-stream dispose ;
+
+M: encoder stream-flush encoder-stream stream-flush ;
 
 INSTANCE: encoder plain-writer
 
 ! Rebinding duplex streams which have not read anything yet
 
 : reencode ( stream encoding -- newstream )
-    over encoder? [ >r delegate r> ] when <encoder> ;
+    over encoder? [ >r encoder-stream r> ] when <encoder> ;
 
 : redecode ( stream encoding -- newstream )
-    over decoder? [ >r delegate r> ] when <decoder> ;
+    over decoder? [ >r decoder-stream r> ] when <decoder> ;
+
+PRIVATE>
 
 : <encoder-duplex> ( stream-in stream-out encoding -- duplex )
     tuck reencode >r redecode r> <duplex-stream> ;

core/io/encodings/utf8/utf8.factor

@@ -6,82 +6,68 @@ IN: io.encodings.utf8
 
 ! Decoding UTF-8
 
-TUPLE: utf8 ch state ;
+TUPLE: utf8 ;
 
-SYMBOL: double
+<PRIVATE 
-SYMBOL: triple
-SYMBOL: triple2
-SYMBOL: quad
-SYMBOL: quad2
-SYMBOL: quad3
 
 : starts-2? ( char -- ? )
-    -6 shift BIN: 10 number= ;
+    dup [ -6 shift BIN: 10 number= ] when ;
 
-: append-nums ( buf bottom top state-out -- buf num state )
+: append-nums ( stream byte -- stream char )
-    >r over starts-2?
+    over stream-read1 dup starts-2?
-    [ 6 shift swap BIN: 111111 bitand bitor r> ]
+    [ swap 6 shift swap BIN: 111111 bitand bitor ]
-    [ r> 3drop push-replacement ] if ;
+    [ 2drop replacement-char ] if ;
 
-: begin-utf8 ( buf byte -- buf ch state )
+: double ( stream byte -- stream char )
+    BIN: 11111 bitand append-nums ;
+
+: triple ( stream byte -- stream char )
+    BIN: 1111 bitand append-nums append-nums ;
+
+: quad ( stream byte -- stream char )
+    BIN: 111 bitand append-nums append-nums append-nums ;
+
+: begin-utf8 ( stream byte -- stream char )
     {
-        { [ dup -7 shift zero? ] [ push-decoded ] }
+        { [ dup -7 shift zero? ] [ ] }
-        { [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] }
+        { [ dup -5 shift BIN: 110 number= ] [ double ] }
-        { [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] }
+        { [ dup -4 shift BIN: 1110 number= ] [ triple ] }
-        { [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] }
+        { [ dup -3 shift BIN: 11110 number= ] [ quad ] }
-        { [ t ] [ drop push-replacement ] }
+        { [ t ] [ drop replacement-char ] }
     } cond ;
 
-: end-multibyte ( buf byte ch -- buf ch state )
+: decode-utf8 ( stream -- char/f )
-    f append-nums [ push-decoded ] unless* ;
+    dup stream-read1 dup [ begin-utf8 ] when nip ;
 
-: decode-utf8-step ( buf byte ch state -- buf ch state )
+M: utf8 decode-char
-    {
+    drop decode-utf8 ;
-        { begin [ drop begin-utf8 ] }
-        { double [ end-multibyte ] }
-        { triple [ triple2 append-nums ] }
-        { triple2 [ end-multibyte ] }
-        { quad [ quad2 append-nums ] }
-        { quad2 [ quad3 append-nums ] }
-        { quad3 [ end-multibyte ] }
-    } case ;
-
-: unpack-state ( encoding -- ch state )
-    { utf8-ch utf8-state } get-slots ;
-
-: pack-state ( ch state encoding -- )
-    { set-utf8-ch set-utf8-state } set-slots ;
-
-M: utf8 decode-step ( buf char encoding -- )
-    [ unpack-state decode-utf8-step ] keep pack-state drop ;
-
-M: utf8 init-decoder nip begin over set-utf8-state ;
 
 ! Encoding UTF-8
 
-: encoded ( char -- )
+: encoded ( stream char -- )
-    BIN: 111111 bitand BIN: 10000000 bitor write1 ;
+    BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ;
 
-: char>utf8 ( char -- )
+: char>utf8 ( stream char -- )
     {
-        { [ dup -7 shift zero? ] [ write1 ] }
+        { [ dup -7 shift zero? ] [ swap stream-write1 ] }
         { [ dup -11 shift zero? ] [
-            dup -6 shift BIN: 11000000 bitor write1
+            2dup -6 shift BIN: 11000000 bitor swap stream-write1
             encoded
         ] }
         { [ dup -16 shift zero? ] [
-            dup -12 shift BIN: 11100000 bitor write1
+            2dup -12 shift BIN: 11100000 bitor swap stream-write1
-            dup -6 shift encoded
+            2dup -6 shift encoded
             encoded
         ] }
         { [ t ] [
-            dup -18 shift BIN: 11110000 bitor write1
+            2dup -18 shift BIN: 11110000 bitor swap stream-write1
-            dup -12 shift encoded
+            2dup -12 shift encoded
-            dup -6 shift encoded
+            2dup -6 shift encoded
             encoded
         ] }
     } cond ;
 
-M: utf8 stream-write-encoded
+M: utf8 encode-char
-    ! For efficiency, this should be modified to avoid variable reads
+    drop swap char>utf8 ;
-    drop [ [ char>utf8 ] each ] with-stream* ;
+
+PRIVATE>

core/io/files/files-docs.factor

@@ -19,7 +19,7 @@ ARTICLE: "pathnames" "Pathname manipulation"
 { $subsection parent-directory }
 { $subsection file-name }
 { $subsection last-path-separator }
-{ $subsection path+ }
+{ $subsection append-path }
 "Pathnames relative to Factor's install directory:"
 { $subsection resource-path }
 { $subsection ?resource-path }
@@ -224,7 +224,7 @@ HELP: stat ( path -- directory? permissions length modified )
 
 { stat exists? directory? } related-words
 
-HELP: path+
+HELP: append-path
 { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
 { $description "Concatenates two pathnames." } ;
 

core/io/files/files.factor

@@ -32,10 +32,13 @@ HOOK: rename-file io-backend ( from to -- )
 : left-trim-separators ( str -- newstr )
     [ path-separator? ] left-trim ;
 
-: path+ ( str1 str2 -- str )
+: append-path ( str1 str2 -- str )
     >r right-trim-separators "/" r>
     left-trim-separators 3append ;
 
+: prepend-path ( str1 str2 -- str )
+    swap append-path ; inline
+
 : last-path-separator ( path -- n ? )
     [ length 1- ] keep [ path-separator? ] find-last* ;
 
@@ -86,16 +89,10 @@ SYMBOL: +unknown+
 : stat ( path -- directory? permissions length modified )
     normalize-pathname (stat) ;
 
-! : file-length ( path -- n ) stat drop 2nip ;
-
 : file-modified ( path -- n ) stat >r 3drop r> ;
 
-! : file-permissions ( path -- perm ) stat 2drop nip ;
-
 : exists? ( path -- ? ) file-modified >boolean ;
 
-! : directory? ( path -- ? ) stat 3drop ;
-
 : directory? ( path -- ? ) file-info file-info-type +directory+ = ;
 
 ! Current working directory
@@ -125,7 +122,7 @@ HOOK: make-directory io-backend ( path -- )
 : fixup-directory ( path seq -- newseq )
     [
         dup string?
-        [ tuck path+ directory? 2array ] [ nip ] if
+        [ tuck append-path directory? 2array ] [ nip ] if
     ] with map
     [ first special-directory? not ] subset ;
 
@@ -133,7 +130,7 @@ HOOK: make-directory io-backend ( path -- )
     normalize-directory dup (directory) fixup-directory ;
 
 : directory* ( path -- seq )
-    dup directory [ first2 >r path+ r> 2array ] with map ;
+    dup directory [ first2 >r append-path r> 2array ] with map ;
 
 ! Touching files
 HOOK: touch-file io-backend ( path -- )
@@ -152,7 +149,7 @@ HOOK: delete-directory io-backend ( path -- )
 : delete-tree ( path -- )
     dup directory? (delete-tree) ;
 
-: to-directory over file-name path+ ;
+: to-directory over file-name append-path ;
 
 ! Moving and renaming files
 HOOK: move-file io-backend ( from to -- )
@@ -185,7 +182,7 @@ DEFER: copy-tree-into
 : copy-tree ( from to -- )
     over directory? [
         >r dup directory swap r> [
-            >r swap first path+ r> copy-tree-into
+            >r swap first append-path r> copy-tree-into
         ] 2curry each
     ] [
         copy-file
@@ -200,7 +197,7 @@ DEFER: copy-tree-into
 ! Special paths
 : resource-path ( path -- newpath )
     \ resource-path get [ image parent-directory ] unless*
-    swap path+ ;
+    prepend-path ;
 
 : ?resource-path ( path -- newpath )
     "resource:" ?head [ resource-path ] when ;
@@ -222,10 +219,7 @@ M: pathname <=> [ pathname-string ] compare ;
     >r <file-reader> r> with-stream ; inline
 
 : file-contents ( path encoding -- str )
-    dupd [ file-info file-info-size read ] with-file-reader ;
+    <file-reader> contents ;
-
-! : file-contents ( path encoding -- str )
-!     dupd [ file-length read ] with-file-reader ;
 
 : with-file-writer ( path encoding quot -- )
     >r <file-writer> r> with-stream ; inline
@@ -245,7 +239,7 @@ M: pathname <=> [ pathname-string ] compare ;
       [ dup make-directory ]
     when ;
 
-: temp-file ( name -- path ) temp-directory swap path+ ;
+: temp-file ( name -- path ) temp-directory prepend-path ;
 
 ! Home directory
 : home ( -- dir )

core/io/io.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables generic kernel math namespaces sequences strings
+USING: hashtables generic kernel math namespaces sequences
-    continuations assocs io.styles sbufs ;
+continuations assocs io.styles ;
 IN: io
 
 GENERIC: stream-readln ( stream -- str )
@@ -88,4 +88,6 @@ SYMBOL: stderr
     [ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
 
 : contents ( stream -- str )
-    2048 <sbuf> [ stream-copy ] keep >string ;
+    [
+        [ 65536 read dup ] [ ] [ drop ] unfold concat f like
+    ] with-stream  ;

core/io/streams/byte-array/byte-array.factor

@@ -1,5 +1,5 @@
 USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
-sequences io namespaces ;
+sequences io namespaces io.encodings.private ;
 IN: io.streams.byte-array
 
 : <byte-writer> ( encoding -- stream )
@@ -7,7 +7,7 @@ IN: io.streams.byte-array
 
 : with-byte-writer ( encoding quot -- byte-array )
     >r <byte-writer> r> [ stdio get ] compose with-stream*
-    >byte-array ; inline
+    dup encoder? [ encoder-stream ] when >byte-array ; inline
 
 : <byte-reader> ( byte-array encoding -- stream )
     >r >byte-vector dup reverse-here r> <decoder> ;

core/io/streams/c/c-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax io io.files threads
-strings byte-arrays io.streams.lines io.streams.plain ;
+strings byte-arrays io.streams.plain ;
 IN: io.streams.c
 
 ARTICLE: "io.streams.c" "ANSI C streams"

core/io/streams/string/string.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: io.streams.string
 USING: io kernel math namespaces sequences sbufs strings
 generic splitting growable continuations io.streams.plain
-io.encodings ;
+io.encodings io.encodings.private ;
+IN: io.streams.string
 
 M: growable dispose drop ;
 
@@ -49,8 +49,11 @@ M: growable stream-read
 M: growable stream-read-partial
     stream-read ;
 
+TUPLE: null ;
+M: null decode-char drop stream-read1 ;
+
 : <string-reader> ( str -- stream )
-    >sbuf dup reverse-here f <decoder> ;
+    >sbuf dup reverse-here null <decoder> ;
 
 : with-string-reader ( str quot -- )
     >r <string-reader> r> with-stream ; inline

core/optimizer/specializers/specializers.factor

@@ -24,20 +24,40 @@ IN: optimizer.specializers
         \ dispatch ,
     ] [ ] make ;
 
-: specializer-methods ( quot word -- default alist )
+: specializer-cases ( quot word -- default alist )
     dup [ array? ] all? [ 1array ] unless [
         [ make-specializer ] keep
         [ declare ] curry pick append
     ] { } map>assoc ;
 
-: specialized-def ( word -- quot )
+: method-declaration ( method -- quot )
-    dup word-def swap "specializer" word-prop [
+    dup "method-generic" word-prop dispatch# object <array>
+    swap "method-class" word-prop add* ;
+
+: specialize-method ( quot method -- quot' )
+    method-declaration [ declare ] curry prepend ;
+
+: specialize-quot ( quot specializer -- quot' )
     dup { number } = [
         drop tag-specializer
     ] [
-            specializer-methods alist>quot
+        specializer-cases alist>quot
-        ] if
+    ] if ;
-    ] when* ;
+
+: standard-method? ( method -- ? )
+    dup method-body? [
+        "method-generic" word-prop standard-generic?
+    ] [ drop f ] if ;
+
+: specialized-def ( word -- quot )
+    dup word-def swap {
+        { [ dup standard-method? ] [ specialize-method ] }
+        {
+            [ dup "specializer" word-prop ]
+            [ "specializer" word-prop specialize-quot ]
+        }
+        { [ t ] [ drop ] }
+    } cond ;
 
 : specialized-length ( specializer -- n )
     dup [ array? ] all? [ first ] when length ;

core/parser/parser-tests.factor

@@ -1,7 +1,7 @@
 USING: arrays math parser tools.test kernel generic words
 io.streams.string namespaces classes effects source-files
 assocs sequences strings io.files definitions continuations
-sorting tuples compiler.units debugger ;
+sorting tuples compiler.units debugger vocabs.loader ;
 IN: parser.tests
 
 [
@@ -396,6 +396,15 @@ IN: parser.tests
     "foo?" "parser.tests" lookup word eq?
 ] unit-test
 
+[ ] [
+    [
+        "redefining-a-class-5" forget-source
+        "redefining-a-class-6" forget-source
+        "redefining-a-class-7" forget-source
+    ] with-compilation-unit
+] unit-test
+
+2 [
     [ ] [
         "IN: parser.tests TUPLE: foo ; GENERIC: foo"
         <string-reader> "redefining-a-class-5" parse-stream drop
@@ -420,12 +429,15 @@ IN: parser.tests
     <string-reader> "redefining-a-class-7" parse-stream drop
     ] unit-test
 
+    [ f ] [ f "foo" "parser.tests" lookup execute ] unit-test
+
     [ ] [
         "IN: parser.tests TUPLE: foo ;"
         <string-reader> "redefining-a-class-7" parse-stream drop
     ] unit-test
 
     [ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test
+] times
 
 [ "resource:core/parser/test/assert-depth.factor" run-file ]
 [ relative-overflow-stack { 1 2 3 } sequence= ]
@@ -447,3 +459,5 @@ must-fail-with
         <string-reader> "d-f-s-test" parse-stream drop
     ] unit-test
 ] times
+
+[ ] [ "parser" reload ] unit-test

core/parser/parser.factor

@@ -215,9 +215,6 @@ SYMBOL: in
 : set-in ( name -- )
     check-vocab-string dup in set create-vocab (use+) ;
 
-: create-in ( string -- word )
-    in get create dup set-word dup save-location ;
-
 TUPLE: unexpected want got ;
 
 : unexpected ( want got -- * )
@@ -238,8 +235,15 @@ PREDICATE: unexpected unexpected-eof
 : parse-tokens ( end -- seq )
     100 <vector> swap (parse-tokens) >array ;
 
+: create-in ( string -- word )
+    in get create dup set-word dup save-location ;
+
 : CREATE ( -- word ) scan create-in ;
 
+: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
+
+: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
+
 : create-class-in ( word -- word )
     in get create
     dup save-class-location
@@ -284,6 +288,12 @@ M: no-word summary
         ] ?if
     ] when ;
 
+: create-method-in ( class generic -- method )
+    create-method f set-word dup save-location ;
+
+: CREATE-METHOD ( -- method )
+    scan-word bootstrap-word scan-word create-method-in ;
+
 TUPLE: staging-violation word ;
 
 : staging-violation ( word -- * )
@@ -355,7 +365,9 @@ TUPLE: bad-number ;
 : parse-definition ( -- quot )
     \ ; parse-until >quotation ;
 
-: (:) CREATE dup reset-generic parse-definition ;
+: (:) CREATE-WORD parse-definition ;
+
+: (M:) CREATE-METHOD parse-definition ;
 
 GENERIC: expected>string ( obj -- str )
 
@@ -466,7 +478,15 @@ SYMBOL: interactive-vocabs
 : smudged-usage ( -- usages referenced removed )
     removed-definitions filter-moved keys [
         outside-usages
-        [ empty? swap pathname? or not ] assoc-subset
+        [
+            empty? [ drop f ] [
+                {
+                    { [ dup pathname? ] [ f ] }
+                    { [ dup method-body? ] [ f ] }
+                    { [ t ] [ t ] }
+                } cond nip
+            ] if
+        ] assoc-subset
         dup values concat prune swap keys
     ] keep ;
 

core/prettyprint/prettyprint-tests.factor

@@ -317,3 +317,15 @@ unit-test
 [ ] [ 1 \ + curry unparse drop ] unit-test
 
 [ ] [ 1 \ + compose unparse drop ] unit-test
+
+GENERIC: generic-see-test-with-f ( obj -- obj )
+
+M: f generic-see-test-with-f ;
+
+[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
+    [ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer
+] unit-test
+
+[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
+    [ \ f \ generic-see-test-with-f method see ] with-string-writer
+] unit-test

core/prettyprint/prettyprint.factor

@@ -172,13 +172,13 @@ M: hook-generic synopsis*
     stack-effect. ;
 
 M: method-spec synopsis*
-    dup definer. [ pprint-word ] each ;
+    first2 method synopsis* ;
 
 M: method-body synopsis*
     dup dup
     definer.
-    "method-class" word-prop pprint*
+    "method-class" word-prop pprint-word
-    "method-generic" word-prop pprint* ;
+    "method-generic" word-prop pprint-word ;
 
 M: mixin-instance synopsis*
     dup definer.

core/sequences/sequences.factor

@@ -299,6 +299,8 @@ M: immutable-sequence clone-like like ;
 
 : append ( seq1 seq2 -- newseq ) over (append) ;
 
+: prepend ( seq1 seq2 -- newseq ) swap append ; inline
+
 : 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ;
 
 : change-nth ( i seq quot -- )

core/slots/slots.factor

@@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ;
 C: <slot-spec> slot-spec
 
 : define-typecheck ( class generic quot -- )
-    over define-simple-generic -rot define-method ;
+    over define-simple-generic
+    >r create-method r> define ;
 
 : define-slot-word ( class slot word quot -- )
     rot >fixnum add* define-typecheck ;

core/syntax/syntax.factor

@@ -97,7 +97,7 @@ IN: bootstrap.syntax
     "parsing" [ word t "parsing" set-word-prop ] define-syntax
 
     "SYMBOL:" [
-        CREATE dup reset-generic define-symbol
+        CREATE-WORD define-symbol
     ] define-syntax
 
     "DEFER:" [
@@ -111,31 +111,26 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "GENERIC:" [
-        CREATE dup reset-word
+        CREATE-GENERIC define-simple-generic
-        define-simple-generic
     ] define-syntax
 
     "GENERIC#" [
-        CREATE dup reset-word
+        CREATE-GENERIC
         scan-word <standard-combination> define-generic
     ] define-syntax
 
     "MATH:" [
-        CREATE dup reset-word
+        CREATE-GENERIC
         T{ math-combination } define-generic
     ] define-syntax
 
     "HOOK:" [
-        CREATE dup reset-word scan-word
+        CREATE-GENERIC scan-word
         <hook-combination> define-generic
     ] define-syntax
 
     "M:" [
-        f set-word
+        (M:) define
-        location >r
-        scan-word bootstrap-word scan-word
-        [ parse-definition -rot define-method ] 2keep
-        2array r> remember-definition
     ] define-syntax
 
     "UNION:" [
@@ -163,11 +158,16 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "C:" [
-        CREATE dup reset-generic
+        CREATE-WORD
         scan-word dup check-tuple
         [ construct-boa ] curry define-inline
     ] define-syntax
 
+    "ERROR:" [
+        CREATE-CLASS dup ";" parse-tokens define-tuple-class
+        dup [ construct-boa throw ] curry define
+    ] define-syntax
+
     "FORGET:" [
         scan-word
         dup parsing? [ V{ } clone swap execute first ] when

core/threads/threads-tests.factor

@@ -14,3 +14,5 @@ yield
 [ 3 ] [
     [ 3 swap resume-with ] "Test suspend" suspend
 ] unit-test
+
+[ f ] [ f get-global ] unit-test

core/threads/threads.factor

@@ -32,8 +32,6 @@ mailbox variables sleep-entry ;
 
 : threads 41 getenv ;
 
-threads global [ H{ } assoc-like ] change-at
-
 : thread ( id -- thread ) threads at ;
 
 : thread-registered? ( thread -- ? )

core/tuples/tuples-docs.factor

@@ -12,6 +12,22 @@ ARTICLE: "tuple-constructors" "Constructors and slots"
 $nl
 "A shortcut for defining BOA constructors:"
 { $subsection POSTPONE: C: }
+"Examples of constructors:"
+{ $code
+    "TUPLE: color red green blue alpha ;"
+    ""
+    "C: <rgba> rgba"
+    ": <rgba> color construct-boa ; ! identical to above"
+    ""
+    ": <rgb>"
+    "    { set-color-red set-color-green set-color-blue }"
+    "    color construct ;"
+    ": <rgb> f <rgba> ; ! identical to above"
+    ""
+    ": <color> construct-empty ;"
+    ": <color> { } color construct ; ! identical to above"
+    ": <color> f f f f <rgba> ; ! identical to above"
+}
 "After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
 
 ARTICLE: "tuple-delegation" "Delegation"
@@ -48,8 +64,8 @@ ARTICLE: "tuples" "Tuples"
 "Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
 { $subsection POSTPONE: TUPLE: }
 "An example:"
-{ $code "TUPLE: person name address phone ;" }
+{ $code "TUPLE: person name address phone ;" "C: <person> person" }
-"This defines a class word named " { $snippet "person" } ", along with a predicate " { $snippet "person?" } ", and the following reader/writer words:"
+"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
 { $table
     { "Reader" "Writer" }
     { { $snippet "person-name" }    { $snippet "set-person-name" }    }

core/vocabs/loader/loader-docs.factor

@@ -43,8 +43,6 @@ HELP: find-vocab-root
 { $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
 { $description "Searches for a vocabulary in the vocabulary roots." } ;
 
-{ vocab-root find-vocab-root } related-words
-
 HELP: no-vocab
 { $values { "name" "a vocabulary name" } } 
 { $description "Throws a " { $link no-vocab } "." }

core/vocabs/loader/loader-tests.factor

@@ -13,15 +13,15 @@ debugger compiler.units tools.vocabs ;
 ] unit-test
 
 [ T{ vocab-link f "vocabs.loader.test" } ]
-[ "vocabs.loader.test" f >vocab-link ] unit-test
+[ "vocabs.loader.test" >vocab-link ] unit-test
 
 [ t ]
-[ "kernel" f >vocab-link "kernel" vocab = ] unit-test
+[ "kernel" >vocab-link "kernel" vocab = ] unit-test
 
 [ t ] [
     "kernel" vocab-files
     "kernel" vocab vocab-files
-    "kernel" f <vocab-link> vocab-files
+    "kernel" <vocab-link> vocab-files
     3array all-equal?
 ] unit-test
 
@@ -36,7 +36,7 @@ IN: vocabs.loader.tests
 [ { 3 3 3 } ] [
     "vocabs.loader.test.2" run
     "vocabs.loader.test.2" vocab run
-    "vocabs.loader.test.2" f <vocab-link> run
+    "vocabs.loader.test.2" <vocab-link> run
     3array
 ] unit-test
 
@@ -78,6 +78,8 @@ IN: vocabs.loader.tests
     ] with-compilation-unit
 ] unit-test
 
+[ f ] [ "vocabs.loader.test.b" vocab-files empty? ] unit-test
+
 [ ] [
     [
         "vocabs.loader.test.b" vocab-files
@@ -113,11 +115,18 @@ IN: vocabs.loader.tests
 [ 3 ] [ "count-me" get-global ] unit-test
 
 [ { "resource:core/kernel/kernel.factor" 1 } ]
-[ "kernel" f <vocab-link> where ] unit-test
+[ "kernel" <vocab-link> where ] unit-test
 
 [ { "resource:core/kernel/kernel.factor" 1 } ]
 [ "kernel" vocab where ] unit-test
 
+[ ] [
+    [
+        "vocabs.loader.test.c" forget-vocab
+        "vocabs.loader.test.d" forget-vocab
+    ] with-compilation-unit
+] unit-test
+
 [ t ] [
     [ "vocabs.loader.test.d" require ] [ :1 ] recover
     "vocabs.loader.test.d" vocab-source-loaded?
@@ -127,7 +136,7 @@ IN: vocabs.loader.tests
     [
         { "2" "a" "b" "d" "e" "f" }
         [
-            "vocabs.loader.test." swap append forget-vocab
+            "vocabs.loader.test." prepend forget-vocab
         ] each
     ] with-compilation-unit ;
 

core/vocabs/loader/loader.factor

@@ -23,30 +23,30 @@ V{
     [ >r dup peek r> append add ] when*
     "/" join ;
 
-: vocab-path+ ( vocab path -- newpath )
-    swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
-
-: vocab-source-path ( vocab -- path/f )
-    dup ".factor" vocab-dir+ vocab-path+ ;
-
-: vocab-docs-path ( vocab -- path/f )
-    dup "-docs.factor" vocab-dir+ vocab-path+ ;
-
 : vocab-dir? ( root name -- ? )
     over [
-        ".factor" vocab-dir+ path+ resource-exists?
+        ".factor" vocab-dir+ append-path resource-exists?
     ] [
         2drop f
     ] if ;
 
+SYMBOL: root-cache
+
+H{ } clone root-cache set-global
+
 : find-vocab-root ( vocab -- path/f )
-    vocab-roots get swap [ vocab-dir? ] curry find nip ;
+    vocab-name root-cache get [
+        vocab-roots get swap [ vocab-dir? ] curry find nip
+    ] cache ;
 
-M: string vocab-root
+: vocab-append-path ( vocab path -- newpath )
-    dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
+    swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ;
 
-M: vocab-link vocab-root
+: vocab-source-path ( vocab -- path/f )
-    vocab-link-root ;
+    dup ".factor" vocab-dir+ vocab-append-path ;
+
+: vocab-docs-path ( vocab -- path/f )
+    dup "-docs.factor" vocab-dir+ vocab-append-path ;
 
 SYMBOL: load-help?
 
@@ -56,7 +56,7 @@ SYMBOL: load-help?
 
 : load-source ( vocab -- )
     [ source-wasn't-loaded ] keep
-    [ vocab-source-path bootstrap-file ] keep
+    [ vocab-source-path [ bootstrap-file ] when* ] keep
     source-was-loaded ;
 
 : docs-were-loaded t swap set-vocab-docs-loaded? ;
@@ -66,24 +66,13 @@ SYMBOL: load-help?
 : load-docs ( vocab -- )
     load-help? get [
         [ docs-weren't-loaded ] keep
-        [ vocab-docs-path ?run-file ] keep
+        [ vocab-docs-path [ ?run-file ] when* ] keep
         docs-were-loaded
     ] [ drop ] if ;
 
-: create-vocab-with-root ( vocab-link -- vocab )
-    dup vocab-name create-vocab
-    swap vocab-root over set-vocab-root ;
-
 : reload ( name -- )
     [
-        f >vocab-link
+        dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if
-        dup vocab-root [
-            dup vocab-source-path resource-exists? [
-                create-vocab-with-root
-                dup load-source
-                load-docs
-            ] [ no-vocab ] if
-        ] [ no-vocab ] if
     ] with-compiler-errors ;
 
 : require ( vocab -- )
@@ -100,33 +89,33 @@ SYMBOL: load-help?
 
 SYMBOL: blacklist
 
-GENERIC: (load-vocab) ( name -- vocab )
-
 : add-to-blacklist ( error vocab -- )
     vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
 
+GENERIC: (load-vocab) ( name -- )
+
 M: vocab (load-vocab)
     [
-        dup vocab-root [
         dup vocab-source-loaded? [ dup load-source ] unless
         dup vocab-docs-loaded? [ dup load-docs ] unless
-        ] when
+        drop
     ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
 
-M: string (load-vocab)
-    [ ".private" ?tail drop reload ] keep vocab ;
-
 M: vocab-link (load-vocab)
-    vocab-name (load-vocab) ;
+    vocab-name create-vocab (load-vocab) ;
 
+M: string (load-vocab)
+    create-vocab (load-vocab) ;
+
+[
     [
         dup vocab-name blacklist get at* [
             rethrow
         ] [
             drop
-        [ dup vocab swap or (load-vocab) ] with-compiler-errors
+            [ (load-vocab) ] with-compiler-errors
         ] if
-
+    ] with-compiler-errors
 ] load-vocab-hook set-global
 
 : vocab-where ( vocab -- loc )

core/vocabs/vocabs-docs.factor

@@ -16,7 +16,6 @@ $nl
 { $subsection vocab }
 "Accessors for various vocabulary attributes:"
 { $subsection vocab-name }
-{ $subsection vocab-root }
 { $subsection vocab-main }
 { $subsection vocab-help }
 "Looking up existing vocabularies and creating new vocabularies:"
@@ -50,10 +49,6 @@ HELP: vocab-name
 { $values { "vocab" "a vocabulary specifier" } { "name" string } }
 { $description "Outputs the name of a vocabulary." } ;
 
-HELP: vocab-root
-{ $values { "vocab" "a vocabulary specifier" } { "root" "a pathname string or " { $link f } } }
-{ $description "Outputs the vocabulary root where the source code for a vocabulary is located, or " { $link f } " if the vocabulary is not defined in source files." } ;
-
 HELP: vocab-words
 { $values { "vocab" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } }
 { $description "Outputs the words defined in a vocabulary." } ;
@@ -101,11 +96,11 @@ HELP: child-vocabs
 } ;
 
 HELP: vocab-link
-{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name, and " { $link vocab-root } " is a pathname string identifying the vocabulary root where the sources to this vocabulary are located, or " { $link f } " if the root is not known."
+{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name."
 $nl
 "Vocabulary links are created by calling " { $link >vocab-link } "."
 } ;
 
 HELP: >vocab-link
-{ $values { "name" string } { "root" "a pathname string or " { $link f } } { "vocab" "a vocabulary specifier" } }
+{ $values { "name" string } { "vocab" "a vocabulary specifier" } }
 { $description "If the vocabulary is loaded, outputs the corresponding " { $link vocab } " instance, otherwise creates a new " { $link vocab-link } "." } ;

core/vocabs/vocabs.factor

@@ -15,8 +15,8 @@ source-loaded? docs-loaded? ;
 M: vocab equal? 2drop f ;
 
 : <vocab> ( name -- vocab )
-    H{ } clone t
+    H{ } clone
-    { set-vocab-name set-vocab-words set-vocab-source-loaded? }
+    { set-vocab-name set-vocab-words }
     \ vocab construct ;
 
 GENERIC: vocab ( vocab-spec -- vocab )
@@ -60,9 +60,16 @@ M: f vocab-help ;
 : create-vocab ( name -- vocab )
     dictionary get [ <vocab> ] cache ;
 
-SYMBOL: load-vocab-hook
+TUPLE: no-vocab name ;
 
-: load-vocab ( name -- vocab ) load-vocab-hook get call ;
+: no-vocab ( name -- * )
+    vocab-name \ no-vocab construct-boa throw ;
+
+SYMBOL: load-vocab-hook ! ( name -- )
+
+: load-vocab ( name -- vocab )
+    dup load-vocab-hook get call
+    dup vocab [ ] [ no-vocab ] ?if ;
 
 : vocabs ( -- seq )
     dictionary get keys natural-sort ;
@@ -85,10 +92,10 @@ SYMBOL: load-vocab-hook
 : child-vocabs ( vocab -- seq )
     vocab-name vocabs [ child-vocab? ] with subset ;
 
-TUPLE: vocab-link name root ;
+TUPLE: vocab-link name ;
 
-: <vocab-link> ( name root -- vocab-link )
+: <vocab-link> ( name -- vocab-link )
-    [ dup vocab-root ] unless* vocab-link construct-boa ;
+    vocab-link construct-boa ;
 
 M: vocab-link equal?
     over vocab-link?
@@ -99,24 +106,16 @@ M: vocab-link hashcode*
 
 M: vocab-link vocab-name vocab-link-name ;
 
-GENERIC# >vocab-link 1 ( name root -- vocab )
-
-M: vocab >vocab-link drop ;
-
-M: vocab-link >vocab-link drop ;
-
-M: string >vocab-link
-    over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
-
 UNION: vocab-spec vocab vocab-link ;
 
+GENERIC: >vocab-link ( name -- vocab )
+
+M: vocab-spec >vocab-link ;
+
+M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
+
 : forget-vocab ( vocab -- )
     dup words forget-all
     vocab-name dictionary get delete-at ;
 
 M: vocab-spec forget* forget-vocab ;
-
-TUPLE: no-vocab name ;
-
-: no-vocab ( name -- * )
-    vocab-name \ no-vocab construct-boa throw ;

core/words/words.factor

@@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
 : crossref? ( word -- ? )
     {
         { [ dup "forgotten" word-prop ] [ f ] }
-        { [ dup "method-def" word-prop ] [ t ] }
+        { [ dup "method-generic" word-prop ] [ t ] }
         { [ dup word-vocabulary ] [ t ] }
         { [ t ] [ f ] }
     } cond nip ;
@@ -169,7 +169,12 @@ SYMBOL: changed-words
         "declared-effect" "constructor-quot" "delimiter"
     } reset-props ;
 
+GENERIC: subwords ( word -- seq )
+
+M: word subwords drop f ;
+
 : reset-generic ( word -- )
+    dup subwords [ forget ] each
     dup reset-word
     { "methods" "combination" "default-method" } reset-props ;
 

extra/asn1/asn1.factor

@@ -135,18 +135,18 @@ SYMBOL: end
 GENERIC: >ber ( obj -- byte-array )
 M: fixnum >ber ( n -- byte-array )
     >128-ber dup length 2 swap 2array
-    "cc" pack-native swap append ;
+    "cc" pack-native prepend ;
 
 : >ber-enumerated ( n -- byte-array )
     >128-ber >byte-array dup length 10 swap 2array
-    "CC" pack-native swap append ;
+    "CC" pack-native prepend ;
 
 : >ber-length-encoding ( n -- byte-array )
     dup 127 <= [
         1array "C" pack-be
     ] [
         1array "I" pack-be 0 swap remove dup length
-        HEX: 80 + 1array "C" pack-be swap append
+        HEX: 80 + 1array "C" pack-be prepend
     ] if ;
 
 ! =========================================================
@@ -158,7 +158,7 @@ M: bignum >ber ( n -- byte-array )
     dup 126 > [
         "range error in bignum" throw
     ] [
-        2 swap 2array "CC" pack-native swap append
+        2 swap 2array "CC" pack-native prepend
     ] if ;
 
 ! =========================================================

extra/assocs/lib/lib.factor

@@ -41,7 +41,7 @@ IN: assocs.lib
     >r 2array flip r> assoc-like ;
 
 : generate-key ( assoc -- str )
-    >r random-256 >hex r>
+    >r 256 random-bits >hex r>
     2dup key? [ nip generate-key ] [ drop ] if ;
 
 : set-at-unique ( value assoc -- key )

extra/automata/automata.factor

@@ -46,7 +46,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
 
 : pattern>state ( {_a_b_c_} -- state ) rule> at ;
 
-: cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ;
+: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
 
 : wrap-line ( a-line-z -- za-line-za )
 dup peek 1array swap dup first 1array append append ;

extra/bitfields/bitfields.factor

@@ -88,7 +88,7 @@ M: check< summary drop "Number exceeds upper bound" ;
     >r keys r> define-slots ;
 
 : define-setters ( classname slots -- )
-    >r "with-" swap append r>
+    >r "with-" prepend r>
     dup values [setters]
     >r keys r> define-slots ;
 

extra/bootstrap/help/help.factor

@@ -9,11 +9,10 @@ IN: bootstrap.help
 
     t load-help? set-global
 
-    [ vocab ] load-vocab-hook [
+    [ drop ] load-vocab-hook [
         vocabs
-        [ vocab-root ] subset
+        [ vocab-docs-loaded? not ] subset
-        [ vocab-source-loaded? ] subset
+        [ load-docs ] each
-        [ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
     ] with-variable ;
 
 load-help

extra/bootstrap/image/download/download.factor

@@ -18,7 +18,7 @@ bootstrap.image sequences io ;
 : download-image ( arch -- )
     boot-image-name dup need-new-image? [
         "Downloading " write dup write "..." print
-        url swap append download
+        url prepend download
     ] [
         "Boot image up to date" print
         drop

extra/bootstrap/random/random.factor

@@ -0,0 +1,8 @@
+USING: vocabs.loader sequences system ;
+
+"random.mersenne-twister" require
+
+{
+    { [ windows? ] [ "random.windows" require ] }
+    { [ unix? ] [ "random.unix" require ] }
+} cond

extra/bootstrap/tools/tools.factor

@@ -13,5 +13,6 @@ USING: vocabs.loader sequences ;
     "tools.threads"
     "tools.vocabs"
     "tools.vocabs.browser"
+    "tools.vocabs.monitor"
     "editors"
 } [ require ] each

extra/bootstrap/ui/tools/tools.factor

@@ -1,7 +1,7 @@
 USING: kernel vocabs vocabs.loader sequences system ;
 
 { "ui" "help" "tools" }
-[ "bootstrap." swap append vocab ] all? [
+[ "bootstrap." prepend vocab ] all? [
     "ui.tools" require
 
     "ui.cocoa" vocab [

extra/bootstrap/ui/ui.factor

@@ -8,7 +8,7 @@ vocabs vocabs.loader ;
             { [ windows? ] [ "windows" ] }
             { [ unix? ] [ "x11" ] }
         } cond
-    ] unless* "ui." swap append require
+    ] unless* "ui." prepend require
 
     "ui.freetype" require
 ] when

extra/builder/benchmark/benchmark.factor

@@ -4,10 +4,12 @@ USING: kernel continuations arrays assocs sequences sorting math
 
 IN: builder.benchmark
 
-: passing-benchmarks ( table -- table )
+! : passing-benchmarks ( table -- table )
-  [ second first2 number? swap number? and ] subset ;
+!   [ second first2 number? swap number? and ] subset ;
 
-: simplify-table ( table -- table ) [ first2 second 2array ] map ;
+: passing-benchmarks ( table -- table ) [ second number? ] subset ;
+
+! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
 
 : benchmark-difference ( old-table benchmark-result -- result-diff )
   first2 >r
@@ -17,7 +19,7 @@ IN: builder.benchmark
   2array ;
 
 : compare-tables ( old new -- table )
-  [ passing-benchmarks simplify-table ] 2apply
+  [ passing-benchmarks ] 2apply
   [ benchmark-difference ] with map ;
 
 : benchmark-deltas ( -- table )

extra/builder/builder.factor

@@ -58,8 +58,8 @@ IN: builder
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : copy-image ( -- )
-  builds "factor" path+ my-boot-image-name path+ ".." copy-file-into
+  builds "factor" append-path my-boot-image-name append-path ".." copy-file-into
-  builds "factor" path+ my-boot-image-name path+ "."  copy-file-into ;
+  builds "factor" append-path my-boot-image-name append-path "."  copy-file-into ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/builder/release/release.factor

@@ -8,7 +8,7 @@ IN: builder.release
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : releases ( -- path )
-  builds "releases" path+
+  builds "releases" append-path
   dup exists? not
     [ dup make-directory ]
   when ;

extra/bunny/outlined/outlined.factor

@@ -1,5 +1,5 @@
 USING: arrays bunny.model bunny.cel-shaded
-combinators.lib continuations kernel math multiline
+combinators.cleave continuations kernel math multiline
 opengl opengl.shaders opengl.framebuffers opengl.gl
 opengl.capabilities sequences ui.gadgets combinators.cleave ;
 IN: bunny.outlined

extra/cairo-demo/cairo-demo.factor

@@ -22,11 +22,11 @@ IN: cairo-demo
 
 TUPLE: cairo-gadget image-array cairo-t ;
 
-! M: cairo-gadget draw-gadget* ( gadget -- )
+M: cairo-gadget draw-gadget* ( gadget -- )
-!    0 0 glRasterPos2i
+    0 0 glRasterPos2i
-!    1.0 -1.0 glPixelZoom
+    1.0 -1.0 glPixelZoom
-!    >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
+    >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
-!    cairo-gadget-image-array glDrawPixels ;
+    cairo-gadget-image-array glDrawPixels ;
 
 : create-surface ( gadget -- cairo_surface_t )
     make-image-array
@@ -60,8 +60,8 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ;
 M: cairo-gadget graft* ( gadget -- )
   dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
 
-! M: cairo-gadget ungraft* ( gadget -- )
+M: cairo-gadget ungraft* ( gadget -- )
-!    cairo-gadget-cairo-t cairo_destroy ;
+   cairo-gadget-cairo-t cairo_destroy ;
 
 : <cairo-gadget> ( -- gadget )
   cairo-gadget construct-gadget ;

extra/calendar/backend/backend.factor

@@ -2,4 +2,4 @@ USING: kernel ;
 IN: calendar.backend
 
 SYMBOL: calendar-backend
-HOOK: gmt-offset calendar-backend
+HOOK: gmt-offset calendar-backend ( -- hours minutes seconds )

extra/calendar/calendar-tests.factor

@@ -2,14 +2,14 @@ USING: arrays calendar kernel math sequences tools.test
 continuations system ;
 IN: calendar.tests
 
-[ f ] [ 2004 12 32 0   0  0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 32 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004  2 30 0   0  0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004  2 30 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2003  2 29 0   0  0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2003  2 29 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 -2  9 0   0  0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 -2  9 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12  0 0   0  0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12  0 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12  1 24  0  0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12  1 24  0  0 instant <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12  1 23 60  0 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12  1 23 60  0 instant <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12  1 23 59 60 0 <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12  1 23 59 60 instant <timestamp> valid-timestamp? ] unit-test
 [ t ] [ now valid-timestamp? ] unit-test
 
 [ f ] [ 1900 leap-year? ] unit-test
@@ -18,126 +18,126 @@ IN: calendar.tests
 [ f ] [ 2001 leap-year? ] unit-test
 [ f ] [ 2006 leap-year? ] unit-test
 
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 1 seconds time+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 1 seconds time+
-        2006 10 10 0 0 1 0 <timestamp> = ] unit-test
+        2006 10 10 0 0 1 instant <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 100 seconds time+
-        2006 10 10 0 1 40 0 <timestamp> = ] unit-test
+        2006 10 10 0 1 40 instant <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 seconds time+
-        2006 10 9 23 58 20 0 <timestamp> = ] unit-test
+        2006 10 9 23 58 20 instant <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 86400 seconds time+
-        2006 10 11 0 0 0 0 <timestamp> = ] unit-test
+        2006 10 11 0 0 0 instant <timestamp> = ] unit-test
 
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10 minutes time+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10 minutes time+
-        2006 10 10 0 10 0 0 <timestamp> = ] unit-test
+        2006 10 10 0 10 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10.5 minutes time+
-        2006 10 10 0 10 30 0 <timestamp> = ] unit-test
+        2006 10 10 0 10 30 instant <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 3/4 minutes time+
-        2006 10 10 0 0 45 0 <timestamp> = ] unit-test
+        2006 10 10 0 0 45 instant <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -3/4 minutes time+
-        2006 10 9 23 59 15 0 <timestamp> = ] unit-test
+        2006 10 9 23 59 15 instant <timestamp> = ] unit-test
 
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 7200 minutes time+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 7200 minutes time+
-        2006 10 15 0 0 0 0 <timestamp> = ] unit-test
+        2006 10 15 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -10 minutes time+
-        2006 10 9 23 50 0 0 <timestamp> = ] unit-test
+        2006 10 9 23 50 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 minutes time+
-        2006 10 9 22 20 0 0 <timestamp> = ] unit-test
+        2006 10 9 22 20 0 instant <timestamp> = ] unit-test
 
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 hours time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 hours time+
-        2006 1 1 1 0 0 0 <timestamp> = ] unit-test
+        2006 1 1 1 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 hours time+
-        2006 1 2 0 0 0 0 <timestamp> = ] unit-test
+        2006 1 2 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 hours time+
-        2005 12 31 0 0 0 0 <timestamp> = ] unit-test
+        2005 12 31 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 hours time+
-        2006 1 1 12 0 0 0 <timestamp> = ] unit-test
+        2006 1 1 12 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 72 hours time+
-        2006 1 4 0 0 0 0 <timestamp> = ] unit-test
+        2006 1 4 0 0 0 instant <timestamp> = ] unit-test
 
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 days time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 days time+
-        2006 1 2 0 0 0 0 <timestamp> = ] unit-test
+        2006 1 2 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 days time+
-        2005 12 31 0 0 0 0 <timestamp> = ] unit-test
+        2005 12 31 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 365 days time+
-        2007 1 1 0 0 0 0 <timestamp> = ] unit-test
+        2007 1 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -365 days time+
-        2005 1 1 0 0 0 0 <timestamp> = ] unit-test
+        2005 1 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 365 days time+
-        2004 12 31 0 0 0 0 <timestamp> = ] unit-test
+        2004 12 31 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 366 days time+
-        2005 1 1 0 0 0 0 <timestamp> = ] unit-test
+        2005 1 1 0 0 0 instant <timestamp> = ] unit-test
 
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 11 months time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 11 months time+
-        2006 12 1 0 0 0 0 <timestamp> = ] unit-test
+        2006 12 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 months time+
-        2007 1 1 0 0 0 0 <timestamp> = ] unit-test
+        2007 1 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 months time+
-        2008 1 1 0 0 0 0 <timestamp> = ] unit-test
+        2008 1 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 13 months time+
-        2007 2 1 0 0 0 0 <timestamp> = ] unit-test
+        2007 2 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 months time+
-        2006 2 1 0 0 0 0 <timestamp> = ] unit-test
+        2006 2 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 months time+
-        2006 1 1 0 0 0 0 <timestamp> = ] unit-test
+        2006 1 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 months time+
-        2005 12 1 0 0 0 0 <timestamp> = ] unit-test
+        2005 12 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -2 months time+
-        2005 11 1 0 0 0 0 <timestamp> = ] unit-test
+        2005 11 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -13 months time+
-        2004 12 1 0 0 0 0 <timestamp> = ] unit-test
+        2004 12 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 months time+
-        2004 1 1 0 0 0 0 <timestamp> = ] unit-test
+        2004 1 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
+[ t ] [ 2004 2 29 0 0 0 instant <timestamp> 12 months time+
-        2005 3 1 0 0 0 0 <timestamp> = ] unit-test
+        2005 3 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
+[ t ] [ 2004 2 29 0 0 0 instant <timestamp> -12 months time+
-        2003 3 1 0 0 0 0 <timestamp> = ] unit-test
+        2003 3 1 0 0 0 instant <timestamp> = ] unit-test
 
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 years time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 years time+
-        2006 1 1 0 0 0 0 <timestamp> = ] unit-test
+        2006 1 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 years time+
-        2007 1 1 0 0 0 0 <timestamp> = ] unit-test
+        2007 1 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 years time+
-        2005 1 1 0 0 0 0 <timestamp> = ] unit-test
+        2005 1 1 0 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -100 years time+
-        1906 1 1 0 0 0 0 <timestamp> = ] unit-test
+        1906 1 1 0 0 0 instant <timestamp> = ] unit-test
-! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
+! [ t ] [ 2004 2 29 0 0 0 instant <timestamp> -1 years time+
-!         2003 2 28 0 0 0 0 <timestamp> = ] unit-test
+!         2003 2 28 0 0 0 instant <timestamp> = ] unit-test
 
-[ 5 ] [ 2006 7 14 0 0 0 0 <timestamp> day-of-week ] unit-test
+[ 5 ] [ 2006 7 14 0 0 0 instant <timestamp> day-of-week ] unit-test
 
-[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 <timestamp> ] 3keep 0 0 0 0 <timestamp> = ] unit-test
+[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 instant <timestamp> ] 3keep 0 0 0 instant <timestamp> = ] unit-test
 
-[ 1 ] [ 2006 1 1 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 1 ] [ 2006 1 1 0 0 0 instant <timestamp> day-of-year ] unit-test
-[ 60 ] [ 2004 2 29 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 60 ] [ 2004 2 29 0 0 0 instant <timestamp> day-of-year ] unit-test
-[ 61 ] [ 2004 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 61 ] [ 2004 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
-[ 366 ] [ 2004 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 366 ] [ 2004 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
-[ 365 ] [ 2003 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 365 ] [ 2003 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
-[ 60 ] [ 2003 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
+[ 60 ] [ 2003 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
 
-[ t ] [ 2004 12 31 0 0 0 0 <timestamp> dup = ] unit-test
+[ t ] [ 2004 12 31 0 0 0 instant <timestamp> dup = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 10 seconds 5 years time+ time+
-        2009 1 1 0 0 10 0 <timestamp> = ] unit-test
+        2009 1 1 0 0 10 instant <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> -10 seconds -5 years time+ time+
-        1998 12 31 23 59 50 0 <timestamp> = ] unit-test
+        1998 12 31 23 59 50 instant <timestamp> = ] unit-test
 
-[ t ] [ 2004 1 1 23 0 0 12 <timestamp> 0 convert-timezone
+[ t ] [ 2004 1 1 23 0 0 12 hours <timestamp> >gmt
-        2004 1 1 11 0 0 0 <timestamp> = ] unit-test
+        2004 1 1 11 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
+[ t ] [ 2004 1 1 5 0 0 -11 hours <timestamp> >gmt
-        2004 1 1 16 0 0 0 <timestamp> = ] unit-test
+        2004 1 1 16 0 0 instant <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
+[ t ] [ 2004 1 1 23 0 0 9+1/2 hours <timestamp> >gmt
-        2004 1 1 13 30 0 0 <timestamp> = ] unit-test
+        2004 1 1 13 30 0 instant <timestamp> = ] unit-test
 
-[ 0 ] [ 2004 1 1 13 30 0 0 <timestamp>
+[ 0 ] [ 2004 1 1 13 30 0 instant <timestamp>
-        2004 1 1 12 30 0 -1 <timestamp> <=> ] unit-test
+        2004 1 1 12 30 0 -1 hours <timestamp> <=> ] unit-test
 
-[ 1 ] [ 2004 1 1 13 30 0 0 <timestamp>
+[ 1 ] [ 2004 1 1 13 30 0 instant <timestamp>
-        2004 1 1 12 30 0 0 <timestamp> <=> ] unit-test
+        2004 1 1 12 30 0 instant <timestamp> <=> ] unit-test
 
-[ -1 ] [ 2004 1 1 12 30 0 0 <timestamp>
+[ -1 ] [ 2004 1 1 12 30 0 instant <timestamp>
-        2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
+        2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
 
-[ 1 ] [ 2005 1 1 12 30 0 0 <timestamp>
+[ 1 ] [ 2005 1 1 12 30 0 instant <timestamp>
-        2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
+        2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
 
 [ t ] [ now timestamp>millis millis - 1000 < ] unit-test
 [ t ] [ 0 millis>timestamp unix-1970 = ] unit-test

extra/calendar/calendar.factor

@@ -3,20 +3,23 @@
 
 USING: arrays kernel math math.functions namespaces sequences
 strings tuples system vocabs.loader calendar.backend threads
-new-slots accessors combinators ;
+new-slots accessors combinators locals ;
 IN: calendar
 
 TUPLE: timestamp year month day hour minute second gmt-offset ;
 
 C: <timestamp> timestamp
 
-: <date> ( year month day -- timestamp )
-    0 0 0 gmt-offset <timestamp> ;
-
 TUPLE: duration year month day hour minute second ;
 
 C: <duration> duration
 
+: gmt-offset-duration ( -- duration )
+    0 0 0 gmt-offset <duration> ;
+
+: <date> ( year month day -- timestamp )
+    0 0 0 gmt-offset-duration <timestamp> ;
+
 : month-names
     {
         "Not a month" "January" "February" "March" "April" "May" "June"
@@ -226,16 +229,18 @@ M: duration <=> [ dt>years ] compare ;
 : dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
 : dt>milliseconds ( dt -- x ) dt>seconds 1000 * ;
 
-: convert-timezone ( timestamp n -- timestamp )
+GENERIC: time- ( time1 time2 -- time )
+
+: convert-timezone ( timestamp duration -- timestamp )
     over gmt-offset>> over = [ drop ] [
-        [ over gmt-offset>> - hours time+ ] keep >>gmt-offset
+        [ over gmt-offset>> time- time+ ] keep >>gmt-offset
     ] if ;
 
 : >local-time ( timestamp -- timestamp )
-    gmt-offset convert-timezone ;
+    gmt-offset-duration convert-timezone ;
 
 : >gmt ( timestamp -- timestamp )
-    0 convert-timezone ;
+    instant convert-timezone ;
 
 M: timestamp <=> ( ts1 ts2 -- n )
     [ >gmt tuple-slots ] compare ;
@@ -245,8 +250,6 @@ M: timestamp <=> ( ts1 ts2 -- n )
     [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
     [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
 
-GENERIC: time- ( time1 time2 -- time )
-
 M: timestamp time-
     #! Exact calendar-time difference
     (time-) seconds ;
@@ -263,14 +266,14 @@ M: timestamp time-
 M: duration time-
     before time+ ;
 
-: <zero> 0 0 0 0 0 0 0 <timestamp> ;
+: <zero> 0 0 0 0 0 0 instant <timestamp> ;
 
 : valid-timestamp? ( timestamp -- ? )
-    clone 0 >>gmt-offset
+    clone instant >>gmt-offset
     dup <zero> time- <zero> time+ = ;
 
 : unix-1970 ( -- timestamp )
-    1970 1 1 0 0 0 0 <timestamp> ; foldable
+    1970 1 1 0 0 0 instant <timestamp> ; foldable
 
 : millis>timestamp ( n -- timestamp )
     >r unix-1970 r> milliseconds time+ ;

extra/calendar/format/format-tests.factor

@@ -1,5 +1,6 @@
+USING: calendar.format calendar kernel tools.test
+io.streams.string ;
 IN: calendar.format.tests
-USING: calendar.format tools.test io.streams.string ;
 
 [ 0 ] [
     "Z" [ read-rfc3339-gmt-offset ] with-string-reader
@@ -20,3 +21,6 @@ USING: calendar.format tools.test io.streams.string ;
 [ 1+1/2 ] [
     "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
 ] unit-test
+
+[ ] [ now timestamp>rfc3339 drop ] unit-test
+[ ] [ now timestamp>rfc822 drop ] unit-test

extra/calendar/format/format.factor

@@ -1,6 +1,7 @@
-IN: calendar.format
 USING: math math.parser kernel sequences io calendar
-accessors arrays io.streams.string combinators accessors ;
+accessors arrays io.streams.string combinators accessors
+combinators.cleave ;
+IN: calendar.format
 
 GENERIC: day. ( obj -- )
 
@@ -54,17 +55,17 @@ M: timestamp year. ( timestamp -- )
 : timestamp>string ( timestamp -- str )
     [ (timestamp>string) ] with-string-writer ;
 
-: (write-gmt-offset) ( ratio -- )
+: (write-gmt-offset) ( duration -- )
-    1 /mod swap write-00 60 * write-00 ;
+    [ hour>> write-00 ] [ minute>> write-00 ] bi ;
 
 : write-gmt-offset ( gmt-offset -- )
-    {
+    dup instant <=> {
-        { [ dup zero? ] [ drop "GMT" write ] }
+        { [ dup 0 = ] [ 2drop "GMT" write ] }
-        { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] }
+        { [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] }
-        { [ dup 0 > ] [ "+" write (write-gmt-offset) ] }
+        { [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] }
     } cond ;
 
-: timestamp>rfc822-string ( timestamp -- str )
+: timestamp>rfc822 ( timestamp -- str )
     #! RFC822 timestamp format
     #! Example: Tue, 15 Nov 1994 08:12:31 +0200
     [
@@ -76,13 +77,18 @@ M: timestamp year. ( timestamp -- )
 : timestamp>http-string ( timestamp -- str )
     #! http timestamp format
     #! Example: Tue, 15 Nov 1994 08:12:31 GMT
-    >gmt timestamp>rfc822-string ;
+    >gmt timestamp>rfc822 ;
 
-: write-rfc3339-gmt-offset ( n -- )
+: (write-rfc3339-gmt-offset) ( duration -- )
-    dup zero? [ drop "Z" write ] [
+    [ hour>> write-00 CHAR: : write1 ]
-        dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if
+    [ minute>> write-00 ] bi ;
-        60 * 60 /mod swap write-00 CHAR: : write1 write-00
+
-    ] if ;
+: write-rfc3339-gmt-offset ( duration -- )
+    dup instant <=> {
+        { [ dup 0 = ] [ 2drop "Z" write ] }
+        { [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
+        { [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] }
+    } cond ;
     
 : (timestamp>rfc3339) ( timestamp -- )
     dup year>> number>string write CHAR: - write1

extra/calendar/unix/unix.factor

@@ -1,4 +1,3 @@
-
 USING: alien alien.c-types arrays calendar.backend
 kernel structs math unix.time namespaces ;
 
@@ -8,11 +7,11 @@ TUPLE: unix-calendar ;
 
 T{ unix-calendar } calendar-backend set-global
 
-: get-time
+: get-time ( -- alien )
     f time <uint> localtime ;
 
-: timezone-name
+: timezone-name ( -- string )
     get-time tm-zone ;
 
-M: unix-calendar gmt-offset
+M: unix-calendar gmt-offset ( -- hours minutes seconds )
-    get-time tm-gmtoff 3600 / ;
+    get-time tm-gmtoff 3600 /mod 60 /mod ;

extra/calendar/windows/windows.factor

@@ -8,8 +8,14 @@ T{ windows-calendar } calendar-backend set-global
 
 : TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
 
-M: windows-calendar gmt-offset ( -- float )
+M: windows-calendar gmt-offset ( -- hours minutes seconds )
     "TIME_ZONE_INFORMATION" <c-object>
-    dup GetTimeZoneInformation
+    dup GetTimeZoneInformation {
-    TIME_ZONE_ID_INVALID = [ win32-error ] when
+        { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error ] }
-    TIME_ZONE_INFORMATION-Bias 60 / neg ;
+        { [ dup { TIME_ZONE_ID_UNKNOWN TIME_ZONE_ID_STANDARD } member? ]
+            [ TIME_ZONE_INFORMATION-Bias 60 / neg ] }
+        { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
+            [ TIME_ZONE_INFORMATION-Bias 60 / neg ]
+            [ TIME_ZONE_INFORMATION-DaylightBias ] bi
+        ] }
+    } cond ;

extra/channels/remote/remote.factor

@@ -14,7 +14,7 @@ IN: channels.remote
 PRIVATE>
 
 : publish ( channel -- id )
-    random-256 dup >r remote-channels set-at r> ;
+    256 random-bits dup >r remote-channels set-at r> ;
 
 : get-channel ( id -- channel )
     remote-channels at ;

extra/cocoa/messages/messages.factor

@@ -59,7 +59,7 @@ objc-methods global [ H{ } assoc-like ] change-at
 
 : lookup-method ( selector -- method )
     dup objc-methods get at
-    [ ] [ "No such method: " swap append throw ] ?if ;
+    [ ] [ "No such method: " prepend throw ] ?if ;
 
 : make-dip ( quot n -- quot' )
     dup
@@ -90,7 +90,7 @@ MACRO: (send) ( selector super? -- quot )
 ! Runtime introspection
 : (objc-class) ( string word -- class )
     dupd execute
-    [ ] [ "No such class: " swap append throw ] ?if ; inline
+    [ ] [ "No such class: " prepend throw ] ?if ; inline
 
 : objc-class ( string -- class )
     \ objc_getClass (objc-class) ;

extra/cocoa/windows/windows.factor

@@ -30,7 +30,8 @@ IN: cocoa.windows
 : <ViewWindow> ( view rect -- window )
     <NSWindow> [ swap -> setContentView: ] keep
     dup dup -> contentView -> setInitialFirstResponder:
-    dup 1 -> setAcceptsMouseMovedEvents: ;
+    dup 1 -> setAcceptsMouseMovedEvents:
+    dup 0 -> setReleasedWhenClosed: ;
 
 : window-content-rect ( window -- rect )
     NSWindow over -> frame rot -> styleMask

extra/combinators/cleave/cleave.factor

@@ -54,6 +54,8 @@ MACRO: 2cleave ( seq -- )
 
 : bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline
 
+: 2bi* ( w x y z p q -- p(x) q(y) ) >r -rot 2slip r> call ; inline
+
 : tri* ( x y z p q r -- p(x) q(y) r(z) )
   >r rot >r bi* r> r> call ; inline
 
@@ -68,7 +70,7 @@ MACRO: spread ( seq -- )
   dup
     [ drop [ >r ] ]        map concat
   swap
-    [ [ r> ] swap append ] map concat
+    [ [ r> ] prepend ] map concat
   append ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

extra/combinators/lib/lib.factor

@@ -8,13 +8,6 @@ continuations ;
 
 IN: combinators.lib
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: generate ( generator predicate -- obj )
-    #! Call 'generator' until the result satisfies 'predicate'.
-    [ slip over slip ] 2keep
-    roll [ 2drop ] [ rot drop generate ] if ; inline
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! Generalized versions of core combinators
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -82,11 +75,11 @@ MACRO: && ( quots -- ? )
     [ [ not ] append [ f ] ] t short-circuit ;
 
 MACRO: <-&& ( quots -- )
-    [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
+    [ [ dup ] prepend [ not ] append [ f ] ] t short-circuit
     [ nip ] append ;
 
 MACRO: <--&& ( quots -- )
-    [ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit
+    [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
     [ 2nip ] append ;
 
 MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
@@ -137,11 +130,14 @@ MACRO: map-call-with ( quots -- )
     [ (make-call-with) ] keep length [ narray ] curry compose ;
 
 : (make-call-with2) ( quots -- quot )
-    [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
+    [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
     [ 2drop ] append ;
 
 MACRO: map-call-with2 ( quots -- )
-    [ (make-call-with2) ] keep length [ narray ] curry append ;
+    [
+        [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
+        [ 2drop ] append    
+    ] keep length [ narray ] curry append ;
 
 MACRO: map-exec-with ( words -- )
     [ 1quotation ] map [ map-call-with ] curry ;
@@ -163,5 +159,19 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
 : and? ( obj quot1 quot2 -- ? )
     >r keep r> rot [ call ] [ 2drop f ] if ; inline
 
+MACRO: multikeep ( word out-indexes -- ... )
+    [
+        dup >r [ \ npick \ >r 3array % ] each
+        %
+        r> [ drop \ r> , ] each
+    ] [ ] make ;
+
 : retry ( quot n -- )
     [ drop ] rot compose attempt-all ; inline
+
+: do-while ( pred body tail -- )
+    >r tuck 2slip r> while ;
+
+: generate ( generator predicate -- obj )
+    [ dup ] swap [ dup [ nip ] unless not ] 3compose
+    swap [ ] do-while ;

extra/concurrency/messaging/messaging.factor

@@ -40,7 +40,7 @@ M: thread send ( message thread -- )
 TUPLE: synchronous data sender tag ;
 
 : <synchronous> ( data -- sync )
-    self random-256 synchronous construct-boa ;
+    self 256 random-bits synchronous construct-boa ;
 
 TUPLE: reply data tag ;
 

extra/core-foundation/core-foundation.factor

@@ -83,7 +83,7 @@ FUNCTION: void CFRelease ( void* cf ) ;
     dup <CFBundle> [
         CFBundleLoadExecutable drop
     ] [
-        "Cannot load bundled named " swap append throw
+        "Cannot load bundled named " prepend throw
     ] ?if ;
 
 FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;

extra/core-foundation/fsevents/fsevents.factor

@@ -150,7 +150,8 @@ SYMBOL: event-stream-callbacks
 : event-stream-counter \ event-stream-counter counter ;
 
 [
-    H{ } clone event-stream-callbacks set-global
+    event-stream-callbacks global
+    [ [ drop expired? not ] assoc-subset ] change-at
     1 \ event-stream-counter set-global
 ] "core-foundation" add-init-hook
 

extra/cpu/8080/emulator/emulator.factor

@@ -446,7 +446,7 @@ M: cpu reset ( cpu -- )
 SYMBOL: rom-root
 
 : rom-dir ( -- string )
-  rom-root get [ home "roms" path+ dup exists? [ drop f ] unless ] unless* ;
+  rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ;
 
 : load-rom* ( seq cpu -- )
   #! 'seq' is an array of arrays. Each array contains
@@ -455,7 +455,7 @@ SYMBOL: rom-root
   #! file path shoul dbe relative to the '/roms' resource path.
   rom-dir [
     cpu-ram [
-      swap first2 rom-dir swap path+ binary [      
+      swap first2 rom-dir prepend-path binary [      
         swap (load-rom)
       ] with-file-reader
     ] curry each 
@@ -1027,14 +1027,14 @@ SYMBOL: $4
   8-bit-registers sp <&>
   "," token <& 
   8-bit-registers <&>
-  just [ first2 swap first2 swap >r swap append r> curry ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry ] <@ ;  
 
 : ADC-R,(RR)-instruction ( -- parser )
   "ADC-R,(RR)" "ADC" complex-instruction
   8-bit-registers sp <&>
   "," token <& 
   16-bit-registers indirect <&>
-  just [ first2 swap first2 swap >r swap append r> curry ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry ] <@ ;  
 
 : SBC-R,N-instruction ( -- parser )
   "SBC-R,N" "SBC" complex-instruction
@@ -1047,14 +1047,14 @@ SYMBOL: $4
   8-bit-registers sp <&>
   "," token <& 
   8-bit-registers <&>
-  just [ first2 swap first2 swap >r swap append r> curry  ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry  ] <@ ;  
 
 : SBC-R,(RR)-instruction ( -- parser )
   "SBC-R,(RR)" "SBC" complex-instruction
   8-bit-registers sp <&>
   "," token <& 
   16-bit-registers indirect  <&>
-  just [ first2 swap first2 swap >r swap append r> curry  ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry  ] <@ ;  
 
 : SUB-R-instruction ( -- parser )
   "SUB-R" "SUB" complex-instruction
@@ -1082,21 +1082,21 @@ SYMBOL: $4
   8-bit-registers sp <&>
   "," token <& 
   8-bit-registers <&>
-  just [ first2 swap first2 swap >r swap append r> curry ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry ] <@ ;  
 
 : ADD-RR,RR-instruction ( -- parser )
   "ADD-RR,RR" "ADD" complex-instruction
   16-bit-registers sp <&>
   "," token <& 
   16-bit-registers <&>
-  just [ first2 swap first2 swap >r swap append r> curry ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry ] <@ ;  
 
 : ADD-R,(RR)-instruction ( -- parser )
   "ADD-R,(RR)" "ADD" complex-instruction
   8-bit-registers sp <&>
   "," token <& 
   16-bit-registers indirect <&>
-  just [ first2 swap first2 swap >r swap append r> curry ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry ] <@ ;  
   
 : LD-RR,NN-instruction
   #! LD BC,nn
@@ -1124,28 +1124,28 @@ SYMBOL: $4
   16-bit-registers indirect sp <&> 
   "," token <&
   8-bit-registers <&>
-  just [ first2 swap first2 swap >r swap append r> curry ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry ] <@ ;  
 
 : LD-R,R-instruction
   "LD-R,R" "LD" complex-instruction
   8-bit-registers sp <&> 
   "," token <&
   8-bit-registers <&>
-  just [ first2 swap first2 swap >r swap append r> curry ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry ] <@ ;  
 
 : LD-RR,RR-instruction
   "LD-RR,RR" "LD" complex-instruction
   16-bit-registers sp <&> 
   "," token <&
   16-bit-registers <&>
-  just [ first2 swap first2 swap >r swap append r> curry ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry ] <@ ;  
 
 : LD-R,(RR)-instruction
   "LD-R,(RR)" "LD" complex-instruction
   8-bit-registers sp <&> 
   "," token <&
   16-bit-registers indirect <&>
-  just [ first2 swap first2 swap >r swap append r> curry ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry ] <@ ;  
 
 : LD-(NN),RR-instruction
   "LD-(NN),RR" "LD" complex-instruction
@@ -1194,14 +1194,14 @@ SYMBOL: $4
   16-bit-registers indirect sp <&> 
   "," token <&
   16-bit-registers <&>
-  just [ first2 swap first2 swap >r swap append r> curry ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry ] <@ ;  
 
 : EX-RR,RR-instruction
   "EX-RR,RR" "EX" complex-instruction
   16-bit-registers sp <&> 
   "," token <&
   16-bit-registers <&>
-  just [ first2 swap first2 swap >r swap append r> curry ] <@ ;  
+  just [ first2 swap first2 swap >r prepend r> curry ] <@ ;  
 
 : 8080-generator-parser
   NOP-instruction 

extra/crypto/blum-blum-shub.factor

@@ -1,36 +0,0 @@
-USING: kernel math sequences namespaces crypto math-contrib ;
-IN: crypto-internals
-
-! TODO: take (log log M) bits instead of 1 bit
-! Blum Blum Shub, M = pq
-TUPLE: bbs x n ;
-
-: generate-bbs-primes ( numbits -- p q )
-    #! two primes congruent to 3 (mod 4)
-    dup [ random-miller-rabin-prime==3(mod4) ] 2apply ;
-
-IN: crypto
-: make-bbs ( numbits -- blum-blum-shub )
-    #! returns a Blum-Blum-Shub tuple
-    generate-bbs-primes * [ find-relative-prime ] keep <bbs> ;
-
-IN: crypto-internals
-SYMBOL: blum-blum-shub 256 make-bbs blum-blum-shub set-global
-
-: next-bbs-bit ( bbs -- bit )
-    #! x = x^2 mod n, return low bit of calculated x
-    [ [ bbs-x ] keep 2 swap bbs-n ^mod ] keep
-    [ set-bbs-x ] keep bbs-x 1 bitand ;
-
-SYMBOL: temp-bbs
-: (bbs-bits) ( numbits bbs -- n )
-    temp-bbs set [ [ temp-bbs get next-bbs-bit ] swap make-bits ] with-scope ;
-
-IN: crypto
-: random-bbs-bits* ( numbits bbs -- n ) (bbs-bits) ;
-: random-bits ( numbits -- n ) blum-blum-shub get (bbs-bits) ;
-: random-bytes ( numbits -- n ) 8 * random-bits ;
-: random ( n -- n )
-    ! #! Cryptographically secure random number using Blum-Blum-Shub 256
-    [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ;
-

extra/db/db.factor

@@ -33,6 +33,19 @@ HOOK: db-close db ( handle -- )
 TUPLE: statement handle sql in-params out-params bind-params bound? ;
 TUPLE: simple-statement ;
 TUPLE: prepared-statement ;
+TUPLE: nonthrowable-statement ;
+: make-nonthrowable ( obj -- obj' )
+    dup sequence? [
+        [ make-nonthrowable ] map
+    ] [
+        nonthrowable-statement construct-delegate
+    ] if ;
+
+MIXIN: throwable-statement
+INSTANCE: statement throwable-statement
+INSTANCE: simple-statement throwable-statement
+INSTANCE: prepared-statement throwable-statement
+
 TUPLE: result-set sql in-params out-params handle n max ;
 : <statement> ( sql in out -- statement )
     { (>>sql) (>>in-params) (>>out-params) } statement construct ;
@@ -50,13 +63,22 @@ GENERIC# row-column-typed 1 ( result-set column -- sql )
 GENERIC: advance-row ( result-set -- )
 GENERIC: more-rows? ( result-set -- ? )
 
-: execute-statement ( statement -- )
+GENERIC: execute-statement ( statement -- )
+
+M: throwable-statement execute-statement ( statement -- )
     dup sequence? [
         [ execute-statement ] each
     ] [
         query-results dispose
     ] if ;
 
+M: nonthrowable-statement execute-statement ( statement -- )
+    dup sequence? [
+        [ execute-statement ] each
+    ] [
+        [ query-results dispose ] [ 2drop ] recover
+    ] if ;
+
 : bind-statement ( obj statement -- )
     swap >>bind-params
     [ bind-statement* ] keep

extra/db/postgresql/lib/lib.factor

@@ -73,7 +73,7 @@ IN: db.postgresql.lib
         sql-spec-type {
             { FACTOR-BLOB [
                 dup [
-                    binary [ serialize ] with-byte-writer
+                    object>bytes
                     malloc-byte-array/length ] [ 0 ] if ] }
             { BLOB [
                 dup [ malloc-byte-array/length ] [ 0 ] if ] }
@@ -164,7 +164,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
         { BLOB [ pq-get-blob ] }
         { FACTOR-BLOB [
             pq-get-blob
-            dup [ binary [ deserialize ] with-byte-reader ] when ] }
+            dup [ bytes>object ] when ] }
         [ no-sql-type ]
     } case ;
     ! PQgetlength PQgetisnull

extra/db/postgresql/postgresql.factor

@@ -10,6 +10,7 @@ IN: db.postgresql
 
 TUPLE: postgresql-db host port pgopts pgtty db user pass ;
 TUPLE: postgresql-statement ;
+INSTANCE: postgresql-statement throwable-statement
 TUPLE: postgresql-result-set ;
 : <postgresql-statement> ( statement in out -- postgresql-statement )
     <statement>
@@ -194,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
         ");" 0%
     ] postgresql-make ;
 
-M: postgresql-db <insert-assigned-statement> ( class -- statement )
+M: postgresql-db <insert-nonnative-statement> ( class -- statement )
     [
         "insert into " 0% 0%
         "(" 0%

extra/db/sqlite/lib/lib.factor

@@ -94,7 +94,7 @@ IN: db.sqlite.lib
         { TIMESTAMP [ sqlite-bind-text-by-name ] }
         { BLOB [ sqlite-bind-blob-by-name ] }
         { FACTOR-BLOB [
-            binary [ serialize ] with-byte-writer
+            object>bytes
             sqlite-bind-blob-by-name
         ] }
         { +native-id+ [ sqlite-bind-int-by-name ] }
@@ -106,6 +106,8 @@ IN: db.sqlite.lib
 : sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
 : sqlite-#columns ( query -- int ) sqlite3_column_count ;
 : sqlite-column ( handle index -- string ) sqlite3_column_text ;
+: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
+: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
 
 : sqlite-column-blob ( handle index -- byte-array/f )
     [ sqlite3_column_bytes ] 2keep
@@ -119,6 +121,7 @@ IN: db.sqlite.lib
     dup array? [ first ] when
     {
         { +native-id+ [ sqlite3_column_int64 ] }
+        { +random-id+ [ sqlite3_column_int64 ] }
         { INTEGER [ sqlite3_column_int ] }
         { BIG-INTEGER [ sqlite3_column_int64 ] }
         { DOUBLE [ sqlite3_column_double ] }
@@ -131,7 +134,7 @@ IN: db.sqlite.lib
         { BLOB [ sqlite-column-blob ] }
         { FACTOR-BLOB [
             sqlite-column-blob
-            dup [ binary [ deserialize ] with-byte-reader ] when
+            dup [ bytes>object ] when
         ] }
         ! { NULL [ 2drop f ] }
         [ no-sql-type ]
@@ -140,7 +143,7 @@ IN: db.sqlite.lib
 : sqlite-row ( handle -- seq )
     dup sqlite-#columns [ sqlite-column ] with map ;
 
-: sqlite-step-has-more-rows? ( step-result -- bool )
+: sqlite-step-has-more-rows? ( prepared -- bool )
     dup SQLITE_ROW =  [
         drop t
     ] [

extra/db/sqlite/sqlite.factor

@@ -6,6 +6,7 @@ prettyprint sequences strings tuples alien.c-types
 continuations db.sqlite.lib db.sqlite.ffi db.tuples
 words combinators.lib db.types combinators
 combinators.cleave io namespaces.lib ;
+USE: tools.walker
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -22,6 +23,8 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
 : with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
 
 TUPLE: sqlite-statement ;
+INSTANCE: sqlite-statement throwable-statement
+
 TUPLE: sqlite-result-set has-more? ;
 
 M: sqlite-db <simple-statement> ( str in out -- obj )
@@ -33,12 +36,20 @@ M: sqlite-db <prepared-statement> ( str in out -- obj )
         set-statement-in-params
         set-statement-out-params
     } statement construct
-    db get db-handle over statement-sql sqlite-prepare
-    over set-statement-handle
     sqlite-statement construct-delegate ;
 
+: sqlite-maybe-prepare ( statement -- statement )
+    dup statement-handle [
+        [
+            delegate
+            db get db-handle over statement-sql sqlite-prepare
+            swap set-statement-handle
+        ] keep
+    ] unless ;
+
 M: sqlite-statement dispose ( statement -- )
-    statement-handle sqlite-finalize ;
+    statement-handle
+    [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
 
 M: sqlite-result-set dispose ( result-set -- )
     f swap set-result-set-handle ;
@@ -46,9 +57,12 @@ M: sqlite-result-set dispose ( result-set -- )
 : sqlite-bind ( triples handle -- )
     swap [ first3 sqlite-bind-type ] with each ;
 
-: reset-statement ( statement -- ) statement-handle sqlite-reset ;
+: reset-statement ( statement -- )
+    sqlite-maybe-prepare
+    statement-handle sqlite-reset ;
 
 M: sqlite-statement bind-statement* ( statement -- )
+    sqlite-maybe-prepare
     dup statement-bound? [ dup reset-statement ] when
     [ statement-bind-params ] [ statement-handle ] bi
     sqlite-bind ;
@@ -57,7 +71,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
     [
         statement-in-params
         [
-            [ sql-spec-column-name ":" swap append ]
+            [ sql-spec-column-name ":" prepend ]
             [ sql-spec-slot-name rot get-slot-named ]
             [ sql-spec-type ] tri 3array
         ] with map
@@ -89,6 +103,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
     sqlite-result-set-has-more? ;
 
 M: sqlite-statement query-results ( query -- result-set )
+    sqlite-maybe-prepare
     dup statement-handle sqlite-result-set <result-set>
     dup advance-row ;
 
@@ -125,7 +140,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
         ");" 0%
     ] sqlite-make ;
 
-M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
+M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
     <insert-native-statement> ;
 
 : where-primary-key% ( specs -- )
@@ -158,7 +173,7 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
 ! : select-sequence ( seq name -- ) ;
 
 M: sqlite-db bind% ( spec -- )
-    dup 1, sql-spec-column-name ":" swap append 0% ;
+    dup 1, sql-spec-column-name ":" prepend 0% ;
 
 M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
     [
@@ -175,6 +190,8 @@ M: sqlite-db modifier-table ( -- hashtable )
     H{
         { +native-id+ "primary key" }
         { +assigned-id+ "primary key" }
+        { +random-id+ "primary key" }
+        ! { +nonnative-id+ "primary key" }
         { +autoincrement+ "autoincrement" }
         { +unique+ "unique" }
         { +default+ "default" }
@@ -193,6 +210,7 @@ M: sqlite-db compound-type ( str seq -- str' )
 M: sqlite-db type-table ( -- assoc )
     H{
         { +native-id+ "integer primary key" }
+        { +random-id+ "integer primary key" }
         { INTEGER "integer" }
         { TEXT "text" }
         { VARCHAR "text" }

extra/db/tuples/tuples-tests.factor

@@ -9,7 +9,7 @@ IN: db.tuples.tests
 TUPLE: person the-id the-name the-number the-real
 ts date time blob factor-blob ;
 
-: <person> ( name age real ts date time blob -- person )
+: <person> ( name age real ts date time blob factor-blob -- person )
     {
         set-person-the-name
         set-person-the-number
@@ -190,11 +190,11 @@ TUPLE: annotation n paste-id summary author mode contents ;
 : test-postgresql ( -- )
 >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
 
-[ native-person-schema test-tuples ] test-sqlite
+: test-repeated-insert
-[ assigned-person-schema test-tuples ] test-sqlite
+    [ ] [ person ensure-table ] unit-test
     
-! [ native-person-schema test-tuples ] test-postgresql
+    [ ] [ person1 get insert-tuple ] unit-test
-! [ assigned-person-schema test-tuples ] test-postgresql
+    [ person1 get insert-tuple ] must-fail ;
 
 TUPLE: serialize-me id data ;
 
@@ -240,8 +240,33 @@ TUPLE: exam id name score ;
 
 ! [ test-ranges ] test-sqlite
 
-\ insert-tuple must-infer
+TUPLE: secret n message ;
-\ update-tuple must-infer
+C: <secret> secret
-\ delete-tuple must-infer
+
-\ select-tuple must-infer
+: test-random-id
-\ define-persistent must-infer
+    secret "SECRET"
+    {
+        { "n" "ID" +random-id+ }
+        { "message" "MESSAGE" TEXT }
+    } define-persistent
+
+    [ ] [ secret ensure-table ] unit-test
+    [ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
+    [ ] [ T{ secret } select-tuples ] unit-test
+    ;
+
+
+
+! [ test-random-id ] test-sqlite
+ [ native-person-schema test-tuples ] test-sqlite
+ [ assigned-person-schema test-tuples ] test-sqlite
+! [ assigned-person-schema test-repeated-insert ] test-sqlite
+! [ native-person-schema test-tuples ] test-postgresql
+! [ assigned-person-schema test-tuples ] test-postgresql
+! [ assigned-person-schema test-repeated-insert ] test-postgresql
+
+! \ insert-tuple must-infer
+! \ update-tuple must-infer
+! \ delete-tuple must-infer
+! \ select-tuple must-infer
+! \ define-persistent must-infer

extra/db/tuples/tuples.factor

@@ -28,7 +28,7 @@ HOOK: create-sql-statement db ( class -- obj )
 HOOK: drop-sql-statement db ( class -- obj )
 
 HOOK: <insert-native-statement> db ( class -- obj )
-HOOK: <insert-assigned-statement> db ( class -- obj )
+HOOK: <insert-nonnative-statement> db ( class -- obj )
 
 HOOK: <update-tuple-statement> db ( class -- obj )
 HOOK: <update-tuples-statement> db ( class -- obj )
@@ -75,21 +75,25 @@ HOOK: insert-tuple* db ( tuple statement -- )
     drop-sql-statement [ execute-statement ] with-disposals ;
 
 : ensure-table ( class -- )
-    [ dup drop-table ] ignore-errors create-table ;
+    [
+        drop-sql-statement make-nonthrowable
+        [ execute-statement ] with-disposals
+    ] [ create-table ] bi ;
 
 : insert-native ( tuple -- )
     dup class
     db get db-insert-statements [ <insert-native-statement> ] cache
     [ bind-tuple ] 2keep insert-tuple* ;
 
-: insert-assigned ( tuple -- )
+: insert-nonnative ( tuple -- )
+! TODO logic here for unique ids
     dup class
-    db get db-insert-statements [ <insert-assigned-statement> ] cache
+    db get db-insert-statements [ <insert-nonnative-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
 : insert-tuple ( tuple -- )
-    dup class db-columns find-primary-key assigned-id? [
+    dup class db-columns find-primary-key nonnative-id? [
-        insert-assigned
+        insert-nonnative
     ] [
         insert-native
     ] if ;

extra/db/types/types.factor

@@ -3,7 +3,8 @@
 USING: arrays assocs db kernel math math.parser
 sequences continuations sequences.deep sequences.lib
 words namespaces tools.walker slots slots.private classes
-mirrors tuples combinators calendar.format symbols ;
+mirrors tuples combinators calendar.format symbols
+singleton ;
 IN: db.types
 
 HOOK: modifier-table db ( -- hash )
@@ -14,22 +15,30 @@ HOOK: compound-type db ( str n -- hash )
 
 TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
 
-SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
+SINGLETON: +native-id+
-+serial+ +unique+ +default+ +null+ +not-null+
+SINGLETON: +assigned-id+
+SINGLETON: +random-id+
+UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
+UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
+
+SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
 +foreign-id+ +has-many+ ;
 
-: (primary-key?) ( obj -- ? )
-    { +native-id+ +assigned-id+ } member? ;
-
 : primary-key? ( spec -- ? )
-    sql-spec-primary-key (primary-key?) ;
+    sql-spec-primary-key +primary-key+? ;
+
+: native-id? ( spec -- ? )
+    sql-spec-primary-key +native-id+? ;
+
+: nonnative-id? ( spec -- ? )
+    sql-spec-primary-key +nonnative-id+? ;
 
 : normalize-spec ( spec -- )
-    dup sql-spec-type dup (primary-key?) [
+    dup sql-spec-type dup +primary-key+? [
         swap set-sql-spec-primary-key
     ] [
         drop dup sql-spec-modifiers [
-            (primary-key?)
+            +primary-key+?
         ] deep-find
         [ swap set-sql-spec-primary-key ] [ drop ] if*
     ] if ;
@@ -37,12 +46,6 @@ SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
 : find-primary-key ( specs -- obj )
     [ sql-spec-primary-key ] find nip ;
 
-: native-id? ( spec -- ? )
-    sql-spec-primary-key +native-id+ = ;
-
-: assigned-id? ( spec -- ? )
-    sql-spec-primary-key +assigned-id+ = ;
-
 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
 
 SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
@@ -69,7 +72,7 @@ TUPLE: no-sql-modifier ;
     dup number? [ number>string ] when ;
 
 : maybe-remove-id ( specs -- obj )
-    [ native-id? not ] subset ;
+    [ +native-id+? not ] subset ;
 
 : remove-relations ( specs -- newcolumns )
     [ relation? not ] subset ;
@@ -124,7 +127,7 @@ TUPLE: no-sql-modifier ;
 : modifiers ( spec -- str )
     sql-spec-modifiers 
     [ lookup-modifier ] map " " join
-    dup empty? [ " " swap append ] unless ;
+    dup empty? [ " " prepend ] unless ;
 
 HOOK: bind% db ( spec -- )
 

extra/delegate/delegate.factor

@@ -7,7 +7,7 @@ IN: delegate
     swap { } like "protocol-words" set-word-prop ;
 
 : PROTOCOL:
-    CREATE dup reset-generic dup define-symbol
+    CREATE-WORD dup define-symbol
     parse-definition swap define-protocol ; parsing
 
 PREDICATE: word protocol "protocol-words" word-prop ;
@@ -27,11 +27,11 @@ M: tuple-class group-words
     swap [ slot-spec-writer ] map append ;
 
 : define-consult-method ( word class quot -- )
-    pick add spin define-method ;
+    pick add >r swap create-method r> define ;
 
 : define-consult ( class group quot -- )
-    >r group-words r>
+    >r group-words swap r>
-    swapd [ define-consult-method ] 2curry each ;
+    [ define-consult-method ] 2curry each ;
 
 : CONSULT:
     scan-word scan-word parse-definition swapd define-consult ; parsing
@@ -39,7 +39,7 @@ M: tuple-class group-words
 : define-mimic ( group mimicker mimicked -- )
     >r >r group-words r> r> [
         pick "methods" word-prop at dup
-        [ "method-def" word-prop spin define-method ]
+        [ >r swap create-method r> word-def define ]
         [ 3drop ] if
     ] 2curry each ; 
 

extra/documents/documents.factor

@@ -74,7 +74,7 @@ TUPLE: document locs ;
     0 swap [ append ] change-nth ;
 
 : append-last ( str seq -- )
-    [ length 1- ] keep [ swap append ] change-nth ;
+    [ length 1- ] keep [ prepend ] change-nth ;
 
 : loc-col/str ( loc document -- str col )
     >r first2 swap r> nth swap ;

extra/editors/editpadpro/editpadpro.factor

@@ -5,7 +5,7 @@ IN: editors.editpadpro
 
 : editpadpro-path
     \ editpadpro-path get-global [
-        program-files "JGsoft" path+
+        program-files "JGsoft" append-path
         t [ >lower "editpadpro.exe" tail? ] find-file
     ] unless* ;
 

extra/editors/editplus/editplus.factor

@@ -4,7 +4,7 @@ IN: editors.editplus
 
 : editplus-path ( -- path )
     \ editplus-path get-global [
-        program-files "\\EditPlus 2\\editplus.exe" path+
+        program-files "\\EditPlus 2\\editplus.exe" append-path
     ] unless* ;
 
 : editplus ( file line -- )

extra/editors/emeditor/emeditor.factor

@@ -4,7 +4,7 @@ IN: editors.emeditor
 
 : emeditor-path ( -- path )
     \ emeditor-path get-global [
-        program-files "\\EmEditor\\EmEditor.exe" path+
+        program-files "\\EmEditor\\EmEditor.exe" append-path
     ] unless* ;
 
 : emeditor ( file line -- )

extra/editors/gvim/windows/windows.factor

@@ -4,6 +4,6 @@ IN: editors.gvim.windows
 
 M: windows-io gvim-path
     \ gvim-path get-global [
-        program-files "vim" path+
+        program-files "vim" append-path
         t [ "gvim.exe" tail? ] find-file
     ] unless* ;

extra/editors/jedit/jedit.factor

@@ -8,7 +8,7 @@ io.encodings.utf8 ;
 IN: editors.jedit
 
 : jedit-server-info ( -- port auth )
-    home "/.jedit/server" path+ ascii [
+    home "/.jedit/server" append-path ascii [
         readln drop
         readln string>number
         readln string>number
@@ -32,7 +32,7 @@ IN: editors.jedit
     ] with-stream ;
 
 : jedit-location ( file line -- )
-    number>string "+line:" swap append 2array
+    number>string "+line:" prepend 2array
     make-jedit-request send-jedit-request ;
 
 : jedit-file ( file -- )

extra/editors/notepadpp/notepadpp.factor

@@ -4,7 +4,7 @@ IN: editors.notepadpp
 
 : notepadpp-path
     \ notepadpp-path get-global [
-        program-files "notepad++\\notepad++.exe" path+
+        program-files "notepad++\\notepad++.exe" append-path
     ] unless* ;
 
 : notepadpp ( file line -- )

extra/editors/scite/scite.factor

@@ -14,7 +14,7 @@ IN: editors.scite
 
 : scite-path ( -- path )
     \ scite-path get-global [
-        program-files "wscite\\SciTE.exe" path+
+        program-files "wscite\\SciTE.exe" append-path
     ] unless* ;
 
 : scite-command ( file line -- cmd )