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

.gitignore

@@ -18,4 +18,4 @@ factor
 temp
 logs
 work
-misc/wordsize
+buildsupport/wordsize

Makefile

@@ -45,8 +45,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 
 EXE_OBJS = $(PLAF_EXE_OBJS)
 
-default: misc/wordsize
+default: build-support/wordsize
-	$(MAKE) `./misc/target`
+	$(MAKE) `./build-support/target`
 
 help:
 	@echo "Run '$(MAKE)' with one of the following parameters:"
@@ -162,8 +162,8 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
 	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
 		$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
 
-misc/wordsize: misc/wordsize.c
+build-support/wordsize: build-support/wordsize.c
-	gcc misc/wordsize.c -o misc/wordsize
+	gcc build-support/wordsize.c -o build-support/wordsize
 
 clean:
 	rm -f vm/*.o

build-support/grovel.c

@@ -0,0 +1,157 @@
+#include <stdio.h>
+
+#if defined(__FreeBSD__)
+	#define BSD
+	#define FREEBSD
+	#define UNIX
+#endif
+
+#if defined(__NetBSD__)
+	#define BSD
+	#define NETBSD
+	#define UNIX
+#endif
+
+#if (__OpenBSD__)
+	#define BSD
+	#define OPENBSD
+	#define UNIX
+#endif
+
+#if defined(linux)
+	#define LINUX
+	#define UNIX
+#endif
+
+#if defined(__amd64__) || defined(__x86_64__)
+	#define BIT64
+#else
+	#define BIT32
+#endif
+
+#if defined(UNIX)
+	#include <sys/types.h>
+	#include <sys/stat.h>
+	#include <sys/socket.h>
+	#include <sys/errno.h>
+	#include <fcntl.h>
+	#include <unistd.h>
+#endif
+
+#define BL printf(" ");
+#define QUOT printf("\"");
+#define NL printf("\n");
+#define LB printf("{"); BL
+#define RB BL printf("}");
+#define SEMI printf(";");
+#define grovel(t) printf("TYPEDEF: "); printf("%d", sizeof(t)); BL printf(#t); NL
+#define grovel2impl(t,n) BL BL BL BL LB QUOT printf(#t); QUOT BL QUOT printf((n)); QUOT RB
+#define grovel2(t,n) grovel2impl(t,n) NL
+#define grovel2end(t,n) grovel2impl(t,n) BL SEMI NL
+#define header(os) printf("vvv %s vvv", (os)); NL
+#define footer(os) printf("^^^ %s ^^^", (os)); NL
+#define header2(os,struct) printf("vvv %s %s vvv", (os), (struct)); NL
+#define footer2(os,struct) printf("^^^ %s %s ^^^", (os), (struct)); NL
+#define struct(n) printf("C-STRUCT: %s\n", (n));
+#define constant(n) printf("#define "); printf(#n); printf(" %d (HEX: %04x)", (n), (n)); NL
+
+void openbsd_types()
+{
+	header2("openbsd", "types");
+	grovel(dev_t);
+	grovel(gid_t);
+	grovel(ino_t);
+	grovel(int32_t);
+	grovel(int64_t);
+	grovel(mode_t);
+	grovel(nlink_t);
+	grovel(off_t);
+	grovel(struct timespec);
+	grovel(uid_t);
+	footer2("openbsd", "types");
+}
+
+void openbsd_stat()
+{
+	header2("openbsd", "stat");
+	struct("stat");
+	grovel2(dev_t, "st_dev");
+	grovel2(ino_t, "st_ino");
+	grovel2(mode_t, "st_mode");
+	grovel2(nlink_t, "st_nlink");
+	grovel2(uid_t, "st_uid");
+	grovel2(gid_t, "st_gid");
+	grovel2(dev_t, "st_rdev");
+	grovel2(int32_t, "st_lspare0");
+	grovel2(struct timespec, "st_atim");
+	grovel2(struct timespec, "st_mtim");
+	grovel2(struct timespec, "st_ctim");
+	grovel2(off_t, "st_size");
+	grovel2(int64_t, "st_blocks");
+	grovel2(u_int32_t, "st_blksize");
+	grovel2(u_int32_t, "st_flags");
+	grovel2(u_int32_t, "st_gen");
+	grovel2(int32_t, "st_lspare1");
+	grovel2(struct timespec, "st_birthtimespec");
+	grovel2(int64_t, "st_qspare1");
+	grovel2end(int64_t, "st_qspare2");
+	footer2("openbsd", "stat");
+}
+
+void unix_types()
+{
+	grovel(dev_t);
+	grovel(gid_t);
+	grovel(ino_t);
+	grovel(int32_t);
+	grovel(int64_t);
+	grovel(mode_t);
+	grovel(nlink_t);
+	grovel(off_t);
+	grovel(struct timespec);
+	grovel(struct stat);
+	grovel(time_t);
+	grovel(uid_t);
+}
+
+void unix_constants()
+{
+	constant(O_RDONLY);
+	constant(O_WRONLY);
+	constant(O_RDWR);
+	constant(O_APPEND);
+	constant(O_CREAT);
+	constant(O_TRUNC);
+	constant(O_EXCL);
+	constant(FD_SETSIZE);
+	constant(SOL_SOCKET);
+	constant(SO_REUSEADDR);
+	constant(SO_OOBINLINE);
+	constant(SO_SNDTIMEO);
+	constant(SO_RCVTIMEO);
+	constant(F_SETFL);
+	constant(O_NONBLOCK);
+	constant(EINTR);
+	constant(EAGAIN);
+	constant(EINPROGRESS);
+}
+	
+int main() {
+#ifdef FREEBSD
+	grovel(blkcnt_t);
+	grovel(blksize_t);
+	grovel(fflags_t);
+#endif
+
+#ifdef OPENBSD
+	openbsd_stat();
+	openbsd_types();
+#endif
+
+#ifdef UNIX
+	unix_types();
+	unix_constants();
+#endif
+
+	return 0;
+}

build-support/target

@@ -0,0 +1,38 @@
+#!/bin/sh
+
+if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ]
+then
+  echo freebsd-x86-32
+elif [ \( `uname -s` = FreeBSD \) -a \( `uname -m` = amd64 \) ]
+then
+  echo freebsd-x86-64
+elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = i386 \) ]
+then
+  echo openbsd-x86-32
+elif [ \( `uname -s` = OpenBSD \) -a \( `uname -m` = amd64 \) ]
+then
+  echo openbsd-x86-64
+elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = i386 \) ]
+then
+  echo netbsd-x86-32
+elif [ \( `uname -s` = NetBSD \) -a \( `uname -p` = x86_64 \) ]
+then
+  echo netbsd-x86-64
+elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
+then
+  echo macosx-ppc
+elif [ `uname -s` = Darwin ]
+then
+  echo macosx-x86-`./build-support/wordsize`
+elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ]
+then
+  echo linux-x86-32
+elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ]
+then
+  echo linux-x86-64
+elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ]
+then
+  echo winnt-x86-`./build-support/wordsize`
+else
+  echo help
+fi

core/alien/alien-docs.factor

@@ -210,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" } "."
@@ -290,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.factor

@@ -2,7 +2,7 @@
 ! 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 
-shuffle arrays macros ;
+arrays ;
 IN: alien
 
 ! Some predicate classes used by the compiler for optimization
@@ -65,21 +65,21 @@ TUPLE: library path abi dll ;
 
 TUPLE: alien-callback return parameters abi quot xt ;
 
-TUPLE: alien-callback-error ;
+ERROR: alien-callback-error ;
 
 : alien-callback ( return parameters abi quot -- alien )
-    \ alien-callback-error construct-empty throw ;
+    alien-callback-error ;
 
 TUPLE: alien-indirect return parameters abi ;
 
-TUPLE: alien-indirect-error ;
+ERROR: alien-indirect-error ;
 
 : alien-indirect ( ... funcptr return parameters abi -- )
-    \ alien-indirect-error construct-empty throw ;
+    alien-indirect-error ;
 
-TUPLE: alien-invoke library function return parameters ;
+TUPLE: alien-invoke library function return parameters abi ;
 
-TUPLE: alien-invoke-error library symbol ;
+ERROR: alien-invoke-error library symbol ;
 
 : alien-invoke ( ... return library function parameters -- ... )
-    2over \ alien-invoke-error construct-boa throw ;
+    2over alien-invoke-error ;

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

@@ -26,9 +26,7 @@ global [
     c-types [ H{ } assoc-like ] change
 ] bind
 
-TUPLE: no-c-type name ;
+ERROR: no-c-type name ;
-
-: no-c-type ( type -- * ) \ no-c-type construct-boa throw ;
 
 : (c-type) ( name -- type/f )
     c-types get-global at dup [

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

@@ -6,14 +6,9 @@ inference.state inference.backend inference.dataflow system
 math.parser classes alien.arrays alien.c-types alien.structs
 alien.syntax cpu.architecture alien inspector quotations assocs
 kernel.private threads continuations.private libc combinators
-compiler.errors continuations layouts ;
+compiler.errors continuations layouts accessors ;
 IN: alien.compiler
 
-! Common protocol for alien-invoke/alien-callback/alien-indirect
-GENERIC: alien-node-parameters ( node -- seq )
-GENERIC: alien-node-return ( node -- ctype )
-GENERIC: alien-node-abi ( node -- str )
-
 : large-struct? ( ctype -- ? )
     dup c-struct? [
         heap-size struct-small-enough? not
@@ -22,11 +17,11 @@ GENERIC: alien-node-abi ( node -- str )
     ] if ;
 
 : alien-node-parameters* ( node -- seq )
-    dup alien-node-parameters
+    dup parameters>>
-    swap alien-node-return large-struct? [ "void*" add* ] when ;
+    swap return>> large-struct? [ "void*" add* ] when ;
 
 : alien-node-return* ( node -- ctype )
-    alien-node-return dup large-struct? [ drop "void" ] when ;
+    return>> dup large-struct? [ drop "void" ] when ;
 
 : c-type-stack-align ( type -- align )
     dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
@@ -51,7 +46,7 @@ GENERIC: alien-node-abi ( node -- str )
 
 : alien-invoke-frame ( node -- n )
     #! One cell is temporary storage, temp@
-    dup alien-node-return return-size
+    dup return>> return-size
     swap alien-stack-frame +
     cell + ;
 
@@ -147,9 +142,9 @@ M: long-long-type flatten-value-type ( type -- )
     pick "void" = [ drop nip call ] [ nip call ] if ; inline
 
 : alien-invoke-stack ( node extra -- )
-    over alien-node-parameters length + dup reify-curries
+    over parameters>> length + dup reify-curries
     over consume-values
-    dup alien-node-return "void" = 0 1 ?
+    dup return>> "void" = 0 1 ?
     swap produce-values ;
 
 : (make-prep-quot) ( parameters -- )
@@ -161,11 +156,11 @@ M: long-long-type flatten-value-type ( type -- )
     ] if ;
 
 : make-prep-quot ( node -- quot )
-    alien-node-parameters
+    parameters>>
     [ <reversed> (make-prep-quot) ] [ ] make ;
 
 : unbox-parameters ( offset node -- )
-    alien-node-parameters [
+    parameters>> [
         %prepare-unbox >r over + r> unbox-parameter
     ] reverse-each-parameter drop ;
 
@@ -174,7 +169,7 @@ M: long-long-type flatten-value-type ( type -- )
     #! parameters. If the C function is returning a structure,
     #! the first parameter is an implicit target area pointer,
     #! so we need to use a different offset.
-    alien-node-return dup large-struct?
+    return>> dup large-struct?
     [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
 
 : objects>registers ( node -- )
@@ -188,14 +183,7 @@ M: long-long-type flatten-value-type ( type -- )
     ] with-param-regs ;
 
 : box-return* ( node -- )
-    alien-node-return [ ] [ box-return ] if-void ;
+    return>> [ ] [ box-return ] if-void ;
-
-M: alien-invoke alien-node-parameters alien-invoke-parameters ;
-M: alien-invoke alien-node-return alien-invoke-return ;
-
-M: alien-invoke alien-node-abi
-    alien-invoke-library library
-    [ library-abi ] [ "cdecl" ] if* ;
 
 M: alien-invoke-error summary
     drop
@@ -205,7 +193,7 @@ M: alien-invoke-error summary
 
 : stdcall-mangle ( symbol node -- symbol )
     "@"
-    swap alien-node-parameters parameter-sizes drop
+    swap parameters>> parameter-sizes drop
     number>string 3append ;
 
 TUPLE: no-such-library name ;
@@ -256,6 +244,10 @@ M: no-such-symbol compiler-error-type
     pop-literal nip over set-alien-invoke-return
     ! Quotation which coerces parameters to required types
     dup make-prep-quot recursive-state get infer-quot
+    ! Set ABI
+    dup alien-invoke-library
+    library [ library-abi ] [ "cdecl" ] if*
+    over set-alien-invoke-abi
     ! Add node to IR
     dup node,
     ! Magic #: consume exactly the number of inputs
@@ -274,10 +266,6 @@ M: alien-invoke generate-node
         iterate-next
     ] with-stack-frame ;
 
-M: alien-indirect alien-node-parameters alien-indirect-parameters ;
-M: alien-indirect alien-node-return alien-indirect-return ;
-M: alien-indirect alien-node-abi alien-indirect-abi ;
-
 M: alien-indirect-error summary
     drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
 
@@ -323,10 +311,6 @@ callbacks global [ H{ } assoc-like ] change-at
 
 : register-callback ( word -- ) dup callbacks get set-at ;
 
-M: alien-callback alien-node-parameters alien-callback-parameters ;
-M: alien-callback alien-node-return alien-callback-return ;
-M: alien-callback alien-node-abi alien-callback-abi ;
-
 M: alien-callback-error summary
     drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
 
@@ -373,7 +357,7 @@ TUPLE: callback-context ;
     wait-to-return ; inline
 
 : prepare-callback-return ( ctype -- quot )
-    alien-node-return {
+    return>> {
         { [ dup "void" = ] [ drop [ ] ] }
         { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
         { [ t ] [ c-type c-type-prep ] }
@@ -390,8 +374,8 @@ TUPLE: callback-context ;
 
 : callback-unwind ( node -- n )
     {
-        { [ dup alien-node-abi "stdcall" = ] [ alien-stack-frame ] }
+        { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
-        { [ dup alien-node-return large-struct? ] [ drop 4 ] }
+        { [ dup return>> large-struct? ] [ drop 4 ] }
         { [ t ] [ drop 0 ] }
     } cond ;
 

core/alien/structs/structs-docs.factor

@@ -1,6 +1,65 @@
 IN: alien.structs
 USING: alien.c-types strings help.markup help.syntax
-alien.syntax sequences io arrays ;
+alien.syntax sequences io arrays slots.deprecated
+kernel words slots assocs namespaces ;
+
+! Deprecated code
+: ($spec-reader-values) ( slot-spec class -- element )
+    dup ?word-name swap 2array
+    over slot-spec-name
+    rot slot-spec-type 2array 2array
+    [ { $instance } swap add ] assoc-map ;
+
+: $spec-reader-values ( slot-spec class -- )
+    ($spec-reader-values) $values ;
+
+: $spec-reader-description ( slot-spec class -- )
+    [
+        "Outputs the value stored in the " ,
+        { $snippet } rot slot-spec-name add ,
+        " slot of " ,
+        { $instance } swap add ,
+        " instance." ,
+    ] { } make $description ;
+
+: $spec-reader ( reader slot-specs class -- )
+    >r slot-of-reader r>
+    over [
+        2dup $spec-reader-values
+        2dup $spec-reader-description
+    ] when 2drop ;
+
+GENERIC: slot-specs ( help-type -- specs )
+
+M: word slot-specs "slots" word-prop ;
+
+: $slot-reader ( reader -- )
+    first dup "reading" word-prop [ slot-specs ] keep
+    $spec-reader ;
+
+: $spec-writer-values ( slot-spec class -- )
+    ($spec-reader-values) reverse $values ;
+
+: $spec-writer-description ( slot-spec class -- )
+    [
+        "Stores a new value to the " ,
+        { $snippet } rot slot-spec-name add ,
+        " slot of " ,
+        { $instance } swap add ,
+        " instance." ,
+    ] { } make $description ;
+
+: $spec-writer ( writer slot-specs class -- )
+    >r slot-of-writer r>
+    over [
+        2dup $spec-writer-values
+        2dup $spec-writer-description
+        dup ?word-name 1array $side-effects
+    ] when 2drop ;
+
+: $slot-writer ( reader -- )
+    first dup "writing" word-prop [ slot-specs ] keep
+    $spec-writer ;
 
 M: string slot-specs c-type struct-type-fields ;
 

core/alien/structs/structs.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic hashtables kernel kernel.private math
 namespaces parser sequences strings words libc slots
-alien.c-types cpu.architecture ;
+slots.deprecated alien.c-types cpu.architecture ;
 IN: alien.structs
 
 : align-offset ( offset type -- offset )

core/alien/syntax/syntax.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov, Alex Chapman.
+! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays alien alien.c-types alien.structs alien.arrays
 kernel math namespaces parser sequences words quotations
@@ -9,7 +9,7 @@ IN: alien.syntax
 <PRIVATE
 
 : parse-arglist ( return seq -- types effect )
-    2 group dup keys swap values
+    2 group dup keys swap values [ "," ?tail drop ] map
     rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
 
 : function-quot ( type lib func types -- quot )

core/bootstrap/compiler/compiler.factor

@@ -79,7 +79,7 @@ nl
 "." write flush
 
 {
-    malloc free memcpy
+    malloc calloc free memcpy
 } compile
 
 " done" print flush

core/bootstrap/image/image.factor

@@ -349,7 +349,7 @@ M: curry '
     [
         {
             dictionary source-files
-            typemap builtins class<map update-map
+            typemap builtins class<map class-map update-map
         } [ dup get swap bootstrap-word set ] each
     ] H{ } make-assoc
     bootstrap-global set

core/bootstrap/primitives.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: bootstrap.primitives
 USING: alien arrays byte-arrays generic hashtables
 hashtables.private io kernel math namespaces parser sequences
 strings vectors words quotations assocs layouts classes tuples
 kernel.private vocabs vocabs.loader source-files definitions
-slots classes.union compiler.units bootstrap.image.private
+slots.deprecated classes.union compiler.units
-io.files ;
+bootstrap.image.private io.files ;
+IN: bootstrap.primitives
 
 "Creating primitives and basic runtime structures..." print flush
 
@@ -30,6 +30,10 @@ crossref off
 "syntax" vocab vocab-words bootstrap-syntax set
 H{ } clone dictionary set
 H{ } clone changed-words set
+H{ } clone root-cache set
+
+! Vocabulary for slot accessors
+"accessors" create-vocab drop
 
 ! Trivial recompile hook. We don't want to touch the code heap
 ! during stage1 bootstrap, it would just waste time.
@@ -90,8 +94,9 @@ call
 } [ create-vocab drop ] each
 
 H{ } clone source-files set
-H{ } clone class<map set
 H{ } clone update-map set
+H{ } clone class<map set
+H{ } clone class-map set
 
 ! Builtin classes
 : builtin-predicate-quot ( class -- quot )
@@ -546,7 +551,7 @@ builtins get num-tags get tail f union-class define-class
     { "eq?" "kernel" }
     { "getenv" "kernel.private" }
     { "setenv" "kernel.private" }
-    { "(stat)" "io.files.private" }
+    { "(exists?)" "io.files.private" }
     { "(directory)" "io.files.private" }
     { "data-gc" "memory" }
     { "code-gc" "memory" }

core/bootstrap/stage2.factor

@@ -12,7 +12,7 @@ SYMBOL: bootstrap-time
 
 : default-image-name ( -- string )
     vm file-name windows? [ "." split1 drop ] when
-    ".image" append ;
+    ".image" append resource-path ;
 
 : do-crossref ( -- )
     "Cross-referencing..." print flush
@@ -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
@@ -57,7 +57,7 @@ millis >r
 
 default-image-name "output-image" set-global
 
-"math help handbook compiler tools ui ui.tools io" "include" set-global
+"math help handbook compiler random tools ui ui.tools io" "include" set-global
 "" "exclude" set-global
 
 parse-command-line
@@ -106,5 +106,5 @@ f error-continuation set-global
     millis r> - dup bootstrap-time set-global
     print-report
 
-    "output-image" get resource-path save-image-and-exit
+    "output-image" get save-image-and-exit
 ] if

core/bootstrap/syntax.factor

@@ -21,6 +21,7 @@ IN: bootstrap.syntax
     "C:"
     "CHAR:"
     "DEFER:"
+    "ERROR:"
     "F{"
     "FV{"
     "FORGET:"

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
@@ -22,6 +22,8 @@ H{ } "s" set
 [ number ] [ number object class-and ] unit-test
 [ number ] [ object number class-and ] unit-test
 [ null ] [ slice reversed class-and ] unit-test
+[ null ] [ general-t \ f class-and ] unit-test
+[ object ] [ general-t \ f class-or ] unit-test
 
 TUPLE: first-one ;
 TUPLE: second-one ;
@@ -63,10 +65,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 ;
 
@@ -180,6 +178,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
     
@@ -224,3 +224,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/classes.factor

@@ -8,11 +8,12 @@ vectors math quotations combinators sorting effects graphs ;
 PREDICATE: word class ( obj -- ? ) "class" word-prop ;
 
 SYMBOL: typemap
+SYMBOL: class-map
 SYMBOL: class<map
 SYMBOL: update-map
 SYMBOL: builtins
 
-PREDICATE: word builtin-class
+PREDICATE: class builtin-class
     "metaclass" word-prop builtin-class eq? ;
 
 PREDICATE: class tuple-class
@@ -58,6 +59,7 @@ PREDICATE: word predicate "predicating" word-prop >boolean ;
         { [ dup builtin-class? ] [ dup set ] }
         { [ dup members ] [ members [ (flatten-class) ] each ] }
         { [ dup superclass ] [ superclass (flatten-class) ] }
+        { [ t ] [ drop ] }
     } cond ;
 
 : flatten-class ( class -- assoc )
@@ -108,11 +110,31 @@ DEFER: (class<)
 : lookup-union ( classes -- class )
     typemap get at dup empty? [ drop object ] [ first ] if ;
 
+: lookup-tuple-union ( classes -- class )
+    class-map get at dup empty? [ drop object ] [ first ] if ;
+
+! : (class-or) ( class class -- class )
+!     [ flatten-builtin-class ] 2apply union lookup-union ;
+! 
+! : (class-and) ( class class -- class )
+!     [ flatten-builtin-class ] 2apply intersect lookup-union ;
+
+: class-or-fixup ( set set -- set )
+    union
+    tuple over key?
+    [ [ drop tuple-class? not ] assoc-subset ] when ;
+
 : (class-or) ( class class -- class )
-    [ flatten-builtin-class ] 2apply union lookup-union ;
+    [ flatten-class ] 2apply class-or-fixup lookup-tuple-union ;
 
 : (class-and) ( class class -- class )
-    [ flatten-builtin-class ] 2apply intersect lookup-union ;
+    2dup [ tuple swap class< ] either? [
+        [ flatten-builtin-class ] 2apply
+        intersect lookup-union
+    ] [
+        [ flatten-class ] 2apply
+        intersect lookup-tuple-union
+    ] if ;
 
 : tuple-class-and ( class1 class2 -- class )
     dupd eq? [ drop null ] unless ;
@@ -219,9 +241,16 @@ M: word reset-class drop ;
 : typemap- ( class -- )
     dup flatten-builtin-class typemap get pop-at ;
 
+! class-map
+: class-map+ ( class -- )
+    dup flatten-class class-map get push-at ;
+
+: class-map- ( class -- )
+    dup flatten-class class-map get pop-at ;
+
 ! Class definition
 : cache-class ( class -- )
-    dup typemap+ dup class<map+ update-map+ ;
+    dup typemap+ dup class-map+ dup class<map+ update-map+ ;
 
 : cache-classes ( assoc -- )
     [ drop cache-class ] assoc-each ;
@@ -229,7 +258,7 @@ M: word reset-class drop ;
 GENERIC: uncache-class ( class -- )
 
 M: class uncache-class
-    dup update-map- dup class<map- typemap- ;
+    dup update-map- dup class<map- dup class-map- typemap- ;
 
 M: word uncache-class drop ;
 

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

@@ -5,16 +5,12 @@ USING: arrays sequences sequences.private math.private
 kernel kernel.private math assocs quotations vectors
 hashtables sorting ;
 
-TUPLE: no-cond ;
+ERROR: no-cond ;
-
-: no-cond ( -- * ) \ no-cond construct-empty throw ;
 
 : cond ( assoc -- )
     [ first call ] find nip dup [ second call ] [ no-cond ] if ;
 
-TUPLE: no-case ;
+ERROR: no-case ;
-
-: no-case ( -- * ) \ no-case construct-empty throw ;
 
 : case ( obj assoc -- )
     [ dup array? [ dupd first = ] [ quotation? ] if ] find nip
@@ -80,7 +76,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/compiler-docs.factor

@@ -8,7 +8,8 @@ $nl
 "The main entry point to the optimizing compiler:"
 { $subsection optimized-recompile-hook }
 "Removing a word's optimized definition:"
-{ $subsection decompile } ;
+{ $subsection decompile }
+"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ;
 
 ARTICLE: "compiler" "Optimizing compiler"
 "Factor is a fully compiled language implementation with two distinct compilers:"

core/compiler/tests/intrinsics.factor

@@ -261,7 +261,7 @@ cell 8 = [
 : compiled-fixnum* fixnum* ;
 
 : test-fixnum*
-    (random) >fixnum (random) >fixnum
+    32 random-bits >fixnum 32 random-bits >fixnum
     2dup
     [ fixnum* ] 2keep compiled-fixnum* =
     [ 2drop ] [ "Oops" throw ] if ;
@@ -271,7 +271,7 @@ cell 8 = [
 : compiled-fixnum>bignum fixnum>bignum ;
 
 : test-fixnum>bignum
-    (random) >fixnum
+    32 random-bits >fixnum
     dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
     [ drop ] [ "Oops" throw ] if ;
 
@@ -280,7 +280,7 @@ cell 8 = [
 : compiled-bignum>fixnum bignum>fixnum ;
 
 : test-bignum>fixnum
-    5 random [ drop (random) ] map product >bignum
+    5 random [ drop 32 random-bits ] map product >bignum
     dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
     [ drop ] [ "Oops" throw ] if ;
 
@@ -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/compiler/units/units-docs.factor

@@ -9,7 +9,9 @@ $nl
 $nl
 "The parser groups all definitions in a source file into one compilation unit, and parsing words do not need to concern themselves with compilation units. However, if definitions are being created at run time, a compilation unit must be created explicitly:"
 { $subsection with-compilation-unit }
-"Words called to associate a definition with a source file location:"
+"Compiling a set of words:"
+{ $subsection compile }
+"Words called to associate a definition with a compilation unit and a source file location:"
 { $subsection remember-definition }
 { $subsection remember-class }
 "Forward reference checking (see " { $link "definition-checking" } "):"

core/cpu/x86/32/32.factor

@@ -5,7 +5,7 @@ cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
 cpu.architecture kernel kernel.private math namespaces sequences
 generator.registers generator.fixup generator system layouts
 alien.compiler combinators command-line
-compiler compiler.units io vocabs.loader ;
+compiler compiler.units io vocabs.loader accessors ;
 IN: cpu.x86.32
 
 PREDICATE: x86-backend x86-32-backend
@@ -244,10 +244,10 @@ M: x86-32-backend %cleanup ( alien-node -- )
     #! have to fix ESP.
     {
         {
-            [ dup alien-node-abi "stdcall" = ]
+            [ dup abi>> "stdcall" = ]
             [ alien-stack-frame ESP swap SUB ]
         } {
-            [ dup alien-node-return large-struct? ]
+            [ dup return>> large-struct? ]
             [ drop EAX PUSH ]
         } {
             [ t ] [ drop ]

core/debugger/debugger.factor

@@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
 tuples continuations continuations.private combinators
 generic.math io.streams.duplex classes compiler.units
 generic.standard vocabs threads threads.private init
-kernel.private libc ;
+kernel.private libc io.encodings ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -75,9 +75,7 @@ SYMBOL: error-hook
 : try ( quot -- )
     [ error-hook get call ] recover ;
 
-TUPLE: assert got expect ;
+ERROR: assert got expect ;
-
-: assert ( got expect -- * ) \ assert construct-boa throw ;
 
 : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
 
@@ -86,28 +84,22 @@ TUPLE: assert got expect ;
 : trim-datastacks ( seq1 seq2 -- seq1' seq2' )
     2dup [ length ] 2apply min tuck tail >r tail r> ;
 
-TUPLE: relative-underflow stack ;
+ERROR: relative-underflow stack ;
-
-: relative-underflow ( before after -- * )
-    trim-datastacks nip \ relative-underflow construct-boa throw ;
 
 M: relative-underflow summary
     drop "Too many items removed from data stack" ;
 
-TUPLE: relative-overflow stack ;
+ERROR: relative-overflow stack ;
 
 M: relative-overflow summary
     drop "Superfluous items pushed to data stack" ;
 
-: relative-overflow ( before after -- * )
-    trim-datastacks drop \ relative-overflow construct-boa throw ;
-
 : assert-depth ( quot -- )
     >r datastack r> swap slip >r datastack r>
     2dup [ length ] compare sgn {
-        { -1 [ relative-underflow ] }
+        { -1 [ trim-datastacks nip relative-underflow ] }
         { 0 [ 2drop ] }
-        { 1 [ relative-overflow ] }
+        { 1 [ trim-datastacks drop relative-overflow ] }
     } case ; inline
 
 : expired-error. ( obj -- )
@@ -210,13 +202,13 @@ M: no-method error.
 M: no-math-method summary
     drop "No suitable arithmetic method" ;
 
-M: check-closed summary
+M: stream-closed-twice summary
     drop "Attempt to perform I/O on closed stream" ;
 
 M: check-method summary
     drop "Invalid parameters for create-method" ;
 
-M: check-tuple summary
+M: no-tuple-class summary
     drop "Invalid class for define-constructor" ;
 
 M: no-cond summary
@@ -254,7 +246,7 @@ M: no-compilation-unit error.
 M: no-vocab summary
     drop "Vocabulary does not exist" ;
 
-M: check-ptr summary
+M: bad-ptr summary
     drop "Memory allocation failed" ;
 
 M: double-free summary
@@ -282,6 +274,10 @@ M: thread error-in-thread ( error thread -- )
         ] bind
     ] if ;
 
+M: encode-error summary drop "Character encoding error" ;
+
+M: decode-error summary drop "Character decoding error" ;
+
 <PRIVATE
 
 : init-debugger ( -- )

core/definitions/definitions.factor

@@ -3,10 +3,7 @@
 IN: definitions
 USING: kernel sequences namespaces assocs graphs ;
 
-TUPLE: no-compilation-unit definition ;
+ERROR: no-compilation-unit definition ;
-
-: no-compilation-unit ( definition -- * )
-    \ no-compilation-unit construct-boa throw ;
 
 GENERIC: where ( defspec -- loc )
 

core/dlists/dlists-docs.factor

@@ -85,7 +85,7 @@ HELP: pop-back*
 { $see-also push-front push-back pop-front pop-front* pop-back } ;
 
 HELP: dlist-find
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
 { $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached.  Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
 { $notes "Returns a boolean to allow dlists to store " { $link f } "."
     $nl
@@ -93,20 +93,20 @@ HELP: dlist-find
 } ;
 
 HELP: dlist-contains?
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
 { $description "Just like " { $link dlist-find } " except it doesn't return the object." }
 { $notes "This operation is O(n)." } ;
 
 HELP: delete-node-if*
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
 { $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any.  Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
 { $notes "This operation is O(n)." } ;
 
 HELP: delete-node-if
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } }
 { $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
 { $notes "This operation is O(n)." } ;
 
 HELP: dlist-each
-{ $values { "quot" quotation } { "dlist" { $link dlist } } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } }
 { $description "Iterate a " { $link dlist } ", calling quot on each element." } ;

core/dlists/dlists-tests.factor

@@ -43,20 +43,20 @@ IN: dlists.tests
     dlist-front dlist-node-next dlist-node-next
 ] unit-test
 
-[ f f ] [ <dlist> [ 1 = ] swap dlist-find ] unit-test
+[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
-[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-find ] unit-test
+[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] dlist-find ] unit-test
-[ f f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-find ] unit-test
+[ f f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
-[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
+[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
 
-[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node-if ] unit-test
+[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
-[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
+[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test
 
 [ 0 ] [ <dlist> dlist-length ] unit-test
 [ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test

core/dlists/dlists.factor

@@ -1,71 +1,67 @@
-! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
+! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
+! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math sequences ;
+USING: combinators kernel math sequences accessors ;
 IN: dlists
 
 TUPLE: dlist front back length ;
 
 : <dlist> ( -- obj )
     dlist construct-empty
-    0 over set-dlist-length ;
+    0 >>length ;
 
-: dlist-empty? ( dlist -- ? ) dlist-front not ;
+: dlist-empty? ( dlist -- ? ) front>> not ;
 
 <PRIVATE
+
 TUPLE: dlist-node obj prev next ;
+
 C: <dlist-node> dlist-node
 
 : inc-length ( dlist -- )
-    [ dlist-length 1+ ] keep set-dlist-length ; inline
+    [ 1+ ] change-length drop ; inline
 
 : dec-length ( dlist -- )
-    [ dlist-length 1- ] keep set-dlist-length ; inline
+    [ 1- ] change-length drop ; inline
 
 : set-prev-when ( dlist-node dlist-node/f -- )
-    [ set-dlist-node-prev ] [ drop ] if* ;
+    [ (>>prev) ] [ drop ] if* ;
 
 : set-next-when ( dlist-node dlist-node/f -- )
-    [ set-dlist-node-next ] [ drop ] if* ;
+    [ (>>next) ] [ drop ] if* ;
 
 : set-next-prev ( dlist-node -- )
-    dup dlist-node-next set-prev-when ;
+    dup next>> set-prev-when ;
 
 : normalize-front ( dlist -- )
-    dup dlist-back [ drop ] [ f swap set-dlist-front ] if ;
+    dup back>> [ f >>front ] unless drop ;
 
 : normalize-back ( dlist -- )
-    dup dlist-front [ drop ] [ f swap set-dlist-back ] if ;
+    dup front>> [ f >>back ] unless drop ;
 
 : set-back-to-front ( dlist -- )
-    dup dlist-back
+    dup back>> [ dup front>> >>back ] unless drop ;
-    [ drop ] [ dup dlist-front swap set-dlist-back ] if ;
 
 : set-front-to-back ( dlist -- )
-    dup dlist-front
+    dup front>> [ dup back>> >>front ] unless drop ;
-    [ drop ] [ dup dlist-back swap set-dlist-front ] if ;
 
-: (dlist-find-node) ( quot dlist-node -- node/f ? )
+: (dlist-find-node) ( dlist-node quot -- node/f ? )
-    dup dlist-node-obj pick dupd call [
+    over [
-        drop nip t
+        [ >r obj>> r> call ] 2keep rot
-    ] [
+        [ drop t ] [ >r next>> r> (dlist-find-node) ] if
-        drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
+    ] [ 2drop f f ] if ; inline
-    ] if ; inline
 
-: dlist-find-node ( quot dlist -- node/f ? )
+: dlist-find-node ( dlist quot -- node/f ? )
-    dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; inline
+    >r front>> r> (dlist-find-node) ; inline
 
-: (dlist-each-node) ( quot dlist -- )
+: dlist-each-node ( dlist quot -- )
-    over
+    [ t ] compose dlist-find-node 2drop ; inline
-    [ 2dup call >r dlist-node-next r> (dlist-each-node) ]
-    [ 2drop ] if ; inline
 
-: dlist-each-node ( quot dlist -- )
-    >r dlist-front r> (dlist-each-node) ; inline
 PRIVATE>
 
 : push-front* ( obj dlist -- dlist-node )
-    [ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep
+    [ front>> f swap <dlist-node> dup dup set-next-prev ] keep
-    [ set-dlist-front ] keep
+    [ (>>front) ] keep
     [ set-back-to-front ] keep
     inc-length ;
 
@@ -76,9 +72,9 @@ PRIVATE>
     [ push-front ] curry each ;
 
 : push-back* ( obj dlist -- dlist-node )
-    [ dlist-back f <dlist-node> ] keep
+    [ back>> f <dlist-node> ] keep
-    [ dlist-back set-next-when ] 2keep
+    [ back>> set-next-when ] 2keep
-    [ set-dlist-back ] 2keep
+    [ (>>back) ] 2keep
     [ set-front-to-back ] keep
     inc-length ;
 
@@ -89,70 +85,75 @@ PRIVATE>
     [ push-back ] curry each ;
 
 : peek-front ( dlist -- obj )
-    dlist-front dlist-node-obj ;
+    front>> obj>> ;
 
 : pop-front ( dlist -- obj )
-    dup dlist-front [
+    dup front>> [
-        dup dlist-node-next
+        dup next>>
-        f rot set-dlist-node-next
+        f rot (>>next)
         f over set-prev-when
-        swap set-dlist-front
+        swap (>>front)
-    ] 2keep dlist-node-obj
+    ] 2keep obj>>
     swap [ normalize-back ] keep dec-length ;
 
 : pop-front* ( dlist -- ) pop-front drop ;
 
 : peek-back ( dlist -- obj )
-    dlist-back dlist-node-obj ;
+    back>> obj>> ;
 
 : pop-back ( dlist -- obj )
-    dup dlist-back [
+    dup back>> [
-        dup dlist-node-prev
+        dup prev>>
-        f rot set-dlist-node-prev
+        f rot (>>prev)
         f over set-next-when
-        swap set-dlist-back
+        swap (>>back)
-    ] 2keep dlist-node-obj
+    ] 2keep obj>>
     swap [ normalize-front ] keep dec-length ;
 
 : pop-back* ( dlist -- ) pop-back drop ;
 
-: dlist-find ( quot dlist -- obj/f ? )
+: dlist-find ( dlist quot -- obj/f ? )
-    dlist-find-node dup [ >r dlist-node-obj r> ] when ; inline
+    dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
 
-: dlist-contains? ( quot dlist -- ? )
+: dlist-contains? ( dlist quot -- ? )
     dlist-find nip ; inline
 
 : unlink-node ( dlist-node -- )
-    dup dlist-node-prev over dlist-node-next set-prev-when
+    dup prev>> over next>> set-prev-when
-    dup dlist-node-next swap dlist-node-prev set-next-when ;
+    dup next>> swap prev>> set-next-when ;
 
 : delete-node ( dlist dlist-node -- )
     {
-        { [ over dlist-front over eq? ] [ drop pop-front* ] }
+        { [ over front>> over eq? ] [ drop pop-front* ] }
-        { [ over dlist-back over eq? ] [ drop pop-back* ] }
+        { [ over back>> over eq? ] [ drop pop-back* ] }
         { [ t ] [ unlink-node dec-length ] }
     } cond ;
 
-: delete-node-if* ( quot dlist -- obj/f ? )
+: delete-node-if* ( dlist quot -- obj/f ? )
-    tuck dlist-find-node [
+    dupd dlist-find-node [
-        [ delete-node ] keep [ dlist-node-obj t ] [ f f ] if*
+        dup [
+            [ delete-node ] keep obj>> t
+        ] [
+            2drop f f
+        ] if
     ] [
         2drop f f
     ] if ; inline
 
-: delete-node-if ( quot dlist -- obj/f )
+: delete-node-if ( dlist quot -- obj/f )
     delete-node-if* drop ; inline
 
 : dlist-delete ( obj dlist -- obj/f )
-    >r [ eq? ] curry r> delete-node-if ;
+    swap [ eq? ] curry delete-node-if ;
 
 : dlist-delete-all ( dlist -- )
-    f over set-dlist-front
+    f >>front
-    f over set-dlist-back
+    f >>back
-    0 swap set-dlist-length ;
+    0 >>length
+    drop ;
 
 : dlist-each ( dlist quot -- )
-    [ dlist-node-obj ] swap compose dlist-each-node ; inline
+    [ obj>> ] swap compose dlist-each-node ; inline
 
 : dlist-slurp ( dlist quot -- )
     over dlist-empty?
@@ -160,4 +161,3 @@ PRIVATE>
     inline
 
 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
-

core/generic/generic-docs.factor

@@ -126,7 +126,7 @@ HELP: method
 { method create-method POSTPONE: M: } related-words
 
 HELP: <method>
-{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
+{ $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
 { $description "Creates a new method." } ;
 
 HELP: methods
@@ -143,7 +143,7 @@ HELP: check-method
 { $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 -- )" } } }
+{ $values { "generic" 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 ;
 

core/generic/math/math-docs.factor

@@ -15,7 +15,7 @@ HELP: no-math-method
 HELP: math-method
 { $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
 { $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
-{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ;
+{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip +/float ]" } } ;
 
 HELP: math-class
 { $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;

core/generic/math/math.factor

@@ -33,10 +33,7 @@ PREDICATE: class math-class ( object -- ? )
     dup empty? [ [ dip ] curry [ ] like ] unless
     r> append ;
 
-TUPLE: no-math-method left right generic ;
+ERROR: no-math-method left right generic ;
-
-: no-math-method ( left right generic -- * )
-    \ no-math-method construct-boa throw ;
 
 : default-math-method ( generic -- quot )
     [ no-math-method ] curry [ ] like ;
@@ -53,7 +50,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

@@ -26,10 +26,7 @@ SYMBOL: (dispatch#)
 
 : unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
 
-TUPLE: no-method object generic ;
+ERROR: no-method object generic ;
-
-: no-method ( object generic -- * )
-    \ no-method construct-boa throw ;
 
 : error-method ( word --  quot )
     picker swap [ no-method ] curry append ;
@@ -161,7 +158,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
@@ -170,7 +167,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/heaps/heaps-tests.factor

@@ -33,7 +33,7 @@ IN: heaps.tests
 : random-alist ( n -- alist )
     [
         [
-            (random) dup number>string swap set
+            32 random-bits dup number>string swap set
         ] times
     ] H{ } make-assoc ;
 

core/inference/inference-tests.factor

@@ -514,10 +514,10 @@ DEFER: an-inline-word
 
 { 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
 
-TUPLE: custom-error ;
+ERROR: custom-error ;
 
 [ T{ effect f 0 0 t } ] [
-    [ custom-error construct-boa throw ] infer
+    [ custom-error ] infer
 ] unit-test
 
 : funny-throw throw ; inline

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

@@ -354,7 +354,7 @@ M: object infer-call
 
 \ setenv { object fixnum } { } <effect> set-primitive-effect
 
-\ (stat) { string } { object object object object } <effect> set-primitive-effect
+\ exists? { string } { object } <effect> set-primitive-effect
 
 \ (directory) { string } { array } <effect> set-primitive-effect
 

core/inference/transforms/transforms.factor

@@ -64,14 +64,11 @@ M: pair (bitfield-quot) ( spec -- quot )
 
 \ get-slots [ [get-slots] ] 1 define-transform
 
-TUPLE: duplicated-slots-error names ;
+ERROR: duplicated-slots-error names ;
 
 M: duplicated-slots-error summary
     drop "Calling set-slots with duplicate slot setters" ;
 
-: duplicated-slots-error ( names -- * )
-    \ duplicated-slots-error construct-boa throw ;
-
 \ set-slots [
     dup all-unique?
     [ <reversed> [get-slots] ] [ duplicated-slots-error ] if

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

@@ -14,19 +14,19 @@ ARTICLE: "encodings-constructors" "Constructing an encoded stream"
 { $subsection <decoder> }
 { $subsection <encoder-duplex> } ;
 
-HELP: <encoder> ( stream encoding -- newstream )
+HELP: <encoder>
 { $values { "stream" "an output stream" }
     { "encoding" "an encoding descriptor" }
     { "newstream" "an encoded output stream" } }
 { $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
 
-HELP: <decoder> ( stream encoding -- newstream )
+HELP: <decoder>
 { $values { "stream" "an input stream" }
     { "encoding" "an encoding descriptor" }
     { "newstream" "an encoded output stream" } }
 { $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
 
-HELP: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
+HELP: <encoder-duplex>
 { $values { "stream-in" "an input stream" }
     { "stream-out" "an output stream" }
     { "encoding" "an encoding descriptor" }
@@ -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
-{ $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" } { "char/f" "a code point or " { $link f } } }
-    { "encoding" "An encoding descriptor tuple" } }
+{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
-{ $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." } ;
 
-HELP: stream-write-encoded ( string stream encoding -- )
+HELP: encode-char
-{ $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,39 @@
 ! 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 encoding -- newstream )
-M: object stream-write-encoded drop stream-write ;
+
+: replacement-char HEX: fffd ;
+
+TUPLE: decoder stream code cr ;
+
+ERROR: decode-error ;
+
+GENERIC: <encoder> ( stream encoding -- newstream )
+
+TUPLE: encoder stream code ;
+
+ERROR: encode-error ;
 
 ! Decoding
 
-TUPLE: decode-error ;
+<PRIVATE
 
-: decode-error ( -- * ) \ decode-error construct-empty throw ;
+M: tuple-class <decoder> construct-empty <decoder> ;
+M: tuple <decoder> f decoder construct-boa ;
 
-SYMBOL: begin
+: >decoder< ( decoder -- stream encoding )
-
+    { decoder-stream decoder-code } get-slots ;
-: push-decoded ( buf ch -- buf ch state )
-    over push 0 begin ;
-
-: push-replacement ( buf -- buf ch state )
-    ! This is the replacement character
-    HEX: fffd push-decoded ;
-
-: space ( resizable -- room-left )
-    dup underlying swap [ length ] 2apply - ;
-
-: full? ( resizable -- ? ) space zero? ;
-
-: end-read-loop ( buf ch state stream quot -- string/f )
-    2drop 2drop >string f like ;
-
-: decode-read-loop ( buf stream encoding -- string/f )
-    pick full? [ 2drop >string ] [
-        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 )
-    rot <sbuf> -rot decode-read-loop ;
-
-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 +59,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 }
@@ -54,9 +54,7 @@ ARTICLE: "fs-meta" "File meta-data"
 { $subsection file-info }
 { $subsection link-info }
 { $subsection exists? }
-{ $subsection directory? }
+{ $subsection directory? } ;
-! { $subsection file-modified }
-{ $subsection stat } ;
 
 ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
 "Operations for deleting and copying files come in two forms:"
@@ -216,15 +214,7 @@ HELP: with-directory
 { $description "Changes the current working directory for the duration of a quotation's execution." }
 { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
 
-HELP: stat ( path -- directory? permissions length modified )
+HELP: append-path
-{ $values { "path" "a pathname string" } { "directory?" "boolean indicating if the file is a directory" } { "permissions" "a Unix permission bitmap (0 on Windows)" } { "length" "the length in bytes as an integer" } { "modified" "the last modification time, as milliseconds since midnight, January 1st 1970 GMT" } }
-{ $description
-    "Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values."
-} ;
-
-{ stat exists? directory? } related-words
-
-HELP: path+
 { $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
 { $description "Concatenates two pathnames." } ;
 
@@ -273,7 +263,7 @@ HELP: normalize-directory
 
 HELP: normalize-pathname
 { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
-{ $description "Called by the " { $link stat } " word, and possibly " { $link <file-reader> } " and " { $link <file-writer> } ", to prepare a pathname before passing it to underlying code." } ;
+{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
 
 HELP: <pathname> ( str -- pathname )
 { $values { "str" "a pathname string" } { "pathname" pathname } }

core/io/files/files-tests.factor

@@ -1,5 +1,6 @@
 IN: io.files.tests
-USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
+USING: tools.test io.files io threads kernel continuations io.encodings.ascii
+io.files.unique sequences strings accessors ;
 
 [ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
 [ ] [ "blahblah" temp-file make-directory ] unit-test
@@ -130,4 +131,16 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
 
 [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
 
-[ ] [ "append-test" ascii <file-appender> dispose ] unit-test
+[ ] [ "append-test" temp-file ascii <file-appender> dispose ] unit-test
+
+
+
+[ 123 ] [
+    "core" ".test" [
+        [
+            ascii [
+                123 CHAR: a <repetition> >string write
+            ] with-file-writer
+        ] keep file-info size>>
+    ] with-unique-file
+] unit-test

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* ;
 
@@ -45,10 +48,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
 
 : special-directory? ( name -- ? ) { "." ".." } member? ;
 
-TUPLE: no-parent-directory path ;
+ERROR: no-parent-directory path ;
-
-: no-parent-directory ( path -- * )
-    \ no-parent-directory construct-boa throw ;
 
 : parent-directory ( path -- parent )
     right-trim-separators {
@@ -83,14 +83,11 @@ SYMBOL: +socket+
 SYMBOL: +unknown+
 
 ! File metadata
-: stat ( path -- directory? permissions length modified )
+: exists? ( path -- ? )
-    normalize-pathname (stat) ;
+    normalize-pathname (exists?) ;
 
-: file-modified ( path -- n ) stat >r 3drop r> ;
+: directory? ( path -- ? )
-
+    file-info file-info-type +directory+ = ;
-: exists? ( path -- ? ) file-modified >boolean ;
-
-: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
 
 ! Current working directory
 HOOK: cd io-backend ( path -- )
@@ -119,7 +116,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 ;
 
@@ -127,7 +124,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 -- )
@@ -146,7 +143,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 -- )
@@ -179,7 +176,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
@@ -193,8 +190,8 @@ DEFER: copy-tree-into
 
 ! Special paths
 : resource-path ( path -- newpath )
-    \ resource-path get [ image parent-directory ] unless*
+    "resource-path" get [ image parent-directory ] unless*
-    swap path+ ;
+    prepend-path ;
 
 : ?resource-path ( path -- newpath )
     "resource:" ?head [ resource-path ] when ;
@@ -236,7 +233,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-tests.factor

@@ -28,15 +28,6 @@ IN: io.tests
 ! Make sure we use correct to_c_string form when writing
 [ ] [ "\0" write ] unit-test
 
-[ "" ] [ 0 read ] unit-test
-
-! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
-
-[
-    "/core/io/test/binary.txt" <resource-reader>
-    [ 0.2 read ] with-stream
-] must-fail
-
 [
     {
         { "It seems " CHAR: J }
@@ -58,3 +49,12 @@ IN: io.tests
         10 [ 65536 read drop ] times
     ] with-file-reader
 ] unit-test
+
+! [ "" ] [ 0 read ] unit-test
+
+! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
+
+! [
+!     "/core/io/test/binary.txt" <resource-reader>
+!     [ 0.2 read ] with-stream
+! ] must-fail

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

@@ -11,11 +11,10 @@ TUPLE: duplex-stream in out closed? ;
 : <duplex-stream> ( in out -- stream )
     f duplex-stream construct-boa ;
 
-TUPLE: check-closed ;
+ERROR: stream-closed-twice ;
 
 : check-closed ( stream -- )
-    duplex-stream-closed?
+    duplex-stream-closed? [ stream-closed-twice ] when ;
-    [ \ check-closed construct-boa throw ] when ;
 
 : duplex-stream-in+ ( duplex -- stream )
     dup check-closed duplex-stream-in ;

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

@@ -23,20 +23,14 @@ SYMBOL: mallocs
 
 PRIVATE>
 
-TUPLE: check-ptr ;
+ERROR: bad-ptr ;
 
 : check-ptr ( c-ptr -- c-ptr )
-    [ \ check-ptr construct-boa throw ] unless* ;
+    [ bad-ptr ] unless* ;
 
-TUPLE: double-free ;
+ERROR: double-free ;
 
-: double-free ( -- * )
+ERROR: realloc-error ptr size ;
-    \ double-free construct-empty throw ;
-
-TUPLE: realloc-error ptr size ;
-
-: realloc-error ( alien size -- * )
-    \ realloc-error construct-boa throw ;
 
 <PRIVATE
 

core/mirrors/mirrors-docs.factor

@@ -2,14 +2,17 @@ USING: help.markup help.syntax slots kernel assocs sequences ;
 IN: mirrors
 
 ARTICLE: "mirrors" "Mirrors"
-"A reflective view of an object's slots and their values:"
+"The " { $vocab-link "mirrors" } " vocabulary defines data types which present an object's slots and slot values as an associative structure. This enables idioms such as iteration over all slots in a tuple, or editing of tuples, sequences and assocs in a generic fashion. This functionality is used by developer tools and meta-programming utilities."
+$nl
+"A mirror provides such a view of a tuple:"
 { $subsection mirror }
 { $subsection <mirror> }
-"A view of a sequence as an associative structure:"
+"An enum provides such a view of a sequence:"
 { $subsection enum }
 { $subsection <enum> }
 "Utility word used by developer tools which inspect objects:"
-{ $subsection make-mirror } ;
+{ $subsection make-mirror }
+{ $see-also "slots" } ;
 
 ABOUT: "mirrors"
 

core/optimizer/specializers/specializers.factor

@@ -35,7 +35,7 @@ IN: optimizer.specializers
     swap "method-class" word-prop add* ;
 
 : specialize-method ( quot method -- quot' )
-    method-declaration [ declare ] curry swap append ;
+    method-declaration [ declare ] curry prepend ;
 
 : specialize-quot ( quot specializer -- quot' )
     dup { number } = [

core/parser/parser-docs.factor

@@ -224,7 +224,7 @@ HELP: skip
 { $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
 { $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
 
-HELP: change-column
+HELP: change-lexer-column
 { $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
 { $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;
 

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 vocabs.loader ;
+sorting tuples compiler.units debugger vocabs vocabs.loader ;
 IN: parser.tests
 
 [
@@ -461,3 +461,11 @@ must-fail-with
 ] times
 
 [ ] [ "parser" reload ] unit-test
+
+[ ] [
+    [ "this-better-not-exist" forget-vocab ] with-compilation-unit
+] unit-test
+
+[
+    "USE: this-better-not-exist" eval
+] must-fail

core/parser/parser.factor

@@ -60,7 +60,7 @@ t parser-notes set-global
     [ swap CHAR: \s eq? xor ] curry find* drop
     [ r> drop ] [ r> length ] if* ;
 
-: change-column ( lexer quot -- )
+: change-lexer-column ( lexer quot -- )
     swap
     [ dup lexer-column swap lexer-line-text rot call ] keep
     set-lexer-column ; inline
@@ -68,14 +68,14 @@ t parser-notes set-global
 GENERIC: skip-blank ( lexer -- )
 
 M: lexer skip-blank ( lexer -- )
-    [ t skip ] change-column ;
+    [ t skip ] change-lexer-column ;
 
 GENERIC: skip-word ( lexer -- )
 
 M: lexer skip-word ( lexer -- )
     [
         2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
-    ] change-column ;
+    ] change-lexer-column ;
 
 : still-parsing? ( lexer -- ? )
     dup lexer-line swap lexer-text length <= ;
@@ -98,10 +98,7 @@ M: lexer skip-word ( lexer -- )
 
 : scan ( -- str/f ) lexer get parse-token ;
 
-TUPLE: bad-escape ;
+ERROR: bad-escape ;
-
-: bad-escape ( -- * )
-    \ bad-escape construct-empty throw ;
 
 M: bad-escape summary drop "Bad escape code" ;
 
@@ -156,7 +153,7 @@ name>char-hook global [
 : parse-string ( -- str )
     lexer get [
         [ swap tail-slice (parse-string) ] "" make swap
-    ] change-column ;
+    ] change-lexer-column ;
 
 TUPLE: parse-error file line col text ;
 
@@ -215,10 +212,7 @@ SYMBOL: in
 : set-in ( name -- )
     check-vocab-string dup in set create-vocab (use+) ;
 
-TUPLE: unexpected want got ;
+ERROR: unexpected want got ;
-
-: unexpected ( want got -- * )
-    \ unexpected construct-boa throw ;
 
 PREDICATE: unexpected unexpected-eof
     unexpected-got not ;
@@ -294,10 +288,7 @@ M: no-word summary
 : CREATE-METHOD ( -- method )
     scan-word bootstrap-word scan-word create-method-in ;
 
-TUPLE: staging-violation word ;
+ERROR: staging-violation word ;
-
-: staging-violation ( word -- * )
-    \ staging-violation construct-boa throw ;
 
 M: staging-violation summary
     drop
@@ -352,9 +343,7 @@ SYMBOL: lexer-factory
         ] if
     ] if ;
 
-TUPLE: bad-number ;
+ERROR: bad-number ;
-
-: bad-number ( -- * ) \ bad-number construct-boa throw ;
 
 : parse-base ( parsed base -- parsed )
     scan swap base> [ bad-number ] unless* parsed ;

core/sequences/sequences.factor

@@ -41,19 +41,14 @@ M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
 : bounds-check? ( n seq -- ? )
     length 1- 0 swap between? ; inline
 
-TUPLE: bounds-error index seq ;
+ERROR: bounds-error index seq ;
-
-: bounds-error ( n seq -- * )
-    \ bounds-error construct-boa throw ;
 
 : bounds-check ( n seq -- n seq )
     2dup bounds-check? [ bounds-error ] unless ; inline
 
 MIXIN: immutable-sequence
 
-TUPLE: immutable seq ;
+ERROR: immutable seq ;
-
-: immutable ( seq -- * ) \ immutable construct-boa throw ;
 
 M: immutable-sequence set-nth immutable ;
 
@@ -190,8 +185,7 @@ TUPLE: slice from to seq ;
 : collapse-slice ( m n slice -- m' n' seq )
     dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline
 
-TUPLE: slice-error reason ;
+ERROR: slice-error reason ;
-: slice-error ( str -- * ) \ slice-error construct-boa throw ;
 
 : check-slice ( from to seq -- from to seq )
     pick 0 < [ "start < 0" slice-error ] when
@@ -299,6 +293,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/deprecated/deprecated.factor

@@ -0,0 +1,95 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel kernel.private math namespaces
+sequences strings words effects generic generic.standard
+classes slots.private combinators slots ;
+IN: slots.deprecated
+
+: reader-effect ( class spec -- effect )
+    >r ?word-name 1array r> slot-spec-name 1array <effect> ;
+
+PREDICATE: word slot-reader "reading" word-prop >boolean ;
+
+: set-reader-props ( class spec -- )
+    2dup reader-effect
+    over slot-spec-reader
+    swap "declared-effect" set-word-prop
+    slot-spec-reader swap "reading" set-word-prop ;
+
+: define-reader ( class spec -- )
+    dup slot-spec-reader [
+        [ set-reader-props ] 2keep
+        dup slot-spec-offset
+        over slot-spec-reader
+        rot slot-spec-type reader-quot
+        define-slot-word
+    ] [
+        2drop
+    ] if ;
+
+: writer-effect ( class spec -- effect )
+    slot-spec-name swap ?word-name 2array 0 <effect> ;
+
+PREDICATE: word slot-writer "writing" word-prop >boolean ;
+
+: set-writer-props ( class spec -- )
+    2dup writer-effect
+    over slot-spec-writer
+    swap "declared-effect" set-word-prop
+    slot-spec-writer swap "writing" set-word-prop ;
+
+: define-writer ( class spec -- )
+    dup slot-spec-writer [
+        [ set-writer-props ] 2keep
+        dup slot-spec-offset
+        swap slot-spec-writer
+        [ set-slot ]
+        define-slot-word
+    ] [
+        2drop
+    ] if ;
+
+: define-slot ( class spec -- )
+    2dup define-reader define-writer ;
+
+: define-slots ( class specs -- )
+    [ define-slot ] with each ;
+
+: reader-word ( class name vocab -- word )
+    >r >r "-" r> 3append r> create ;
+
+: writer-word ( class name vocab -- word )
+    >r [ swap "set-" % % "-" % % ] "" make r> create ;
+
+: (simple-slot-word) ( class name -- class name vocab )
+    over word-vocabulary >r >r word-name r> r> ;
+
+: simple-reader-word ( class name -- word )
+    (simple-slot-word) reader-word ;
+
+: simple-writer-word ( class name -- word )
+    (simple-slot-word) writer-word ;
+
+: short-slot ( class name # -- spec )
+    >r object bootstrap-word over r> f f <slot-spec>
+    2over simple-reader-word over set-slot-spec-reader
+    -rot simple-writer-word over set-slot-spec-writer ;
+
+: long-slot ( spec # -- spec )
+    >r [ dup array? [ first2 create ] when ] map first4 r>
+    -rot <slot-spec> ;
+
+: simple-slots ( class slots base -- specs )
+    over length [ + ] with map [
+        {
+            { [ over not ] [ 2drop f ] }
+            { [ over string? ] [ >r dupd r> short-slot ] }
+            { [ over array? ] [ long-slot ] }
+        } cond
+    ] 2map [ ] subset nip ;
+
+: slot-of-reader ( reader specs -- spec/f )
+    [ slot-spec-reader eq? ] with find nip ;
+
+: slot-of-writer ( writer specs -- spec/f )
+    [ slot-spec-writer eq? ] with find nip ;

core/slots/slots-docs.factor

@@ -4,25 +4,86 @@ effects generic.standard tuples slots.private classes
 strings math ;
 IN: slots
 
+ARTICLE: "accessors" "Slot accessors"
+"For each tuple slot, methods are defined on two accessor words in the " { $vocab-link "accessors" } " vocabulary:"
+{ $list
+    { "The " { $emphasis "reader" } " is named " { $snippet { $emphasis "slot" } ">>" } " and pushes the value of a slot on the stack." }
+    { "The " { $emphasis "writer" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } "." }
+}
+"In addition, two utility words are defined for each distinct slot name used in the system:"
+{ $list
+    { "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
+    { "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." }
+}
+"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names."
+$nl
+"In most cases, using the setter is preferred over the writer because the stack effect is better suited to the common case where the tuple is needed again, and where the new slot value was just computed and so is at the top of the stack. For example, consider the case where you want to create a tuple and fill in the slots with literals. The following version uses setters:"
+{ $code
+    "<email>"
+    "    \"Happy birthday\" >>subject"
+    "    { \"bob@bigcorp.com\" } >>to"
+    "    \"alice@bigcorp.com\" >>from"
+    "send-email"
+}
+"The following uses writers, and requires some stack shuffling:"
+{ $code
+    "<email>"
+    "    \"Happy birthday\" over (>>subject)"
+    "    { \"bob@bigcorp.com\" } over (>>to)"
+    "    \"alice@bigcorp.com\" over (>>from)"
+    "send-email"
+}
+"Even if some of the slot values come from the stack underneath the tuple being constructed, setters win:"
+{ $code
+    "<email>"
+    "    swap >>subject"
+    "    swap >>to"
+    "    \"alice@bigcorp.com\" >>from"
+    "send-email"
+}
+"This is because " { $link swap } " is easier to understand than " { $link tuck } ":"
+{ $code
+    "<email>"
+    "    tuck (>>subject)"
+    "    tuck (>>to)"
+    "    \"alice@bigcorp.com\" over (>>from)"
+    "send-email"
+}
+"The changer word abstracts a common pattern where a slot value is read then stored again; so the following is not idiomatic code:"
+{ $code
+    "find-manager"
+    "    salary>> 0.75 * >>salary"
+}
+"The following version is preferred:"
+{ $code
+    "find-manager"
+    "    [ 0.75 * ] change-salary"
+}
+{ $see-also "slots" "mirrors" } ;
+
 ARTICLE: "slots" "Slots"
-"A " { $emphasis "slot" } " is a component of an object which can store a value. The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object."
+"A " { $emphasis "slot" } " is a component of an object which can store a value."
 $nl
 { $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data."
+"The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object."
 $nl
 "The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance."
 { $subsection slot-spec }
-"Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not."
+"The four words associated with a slot can be looked up in the " { $vocab-link "accessors" } " vocabulary:"
-{ $subsection slot-spec-reader }
+{ $subsection reader-word }
-{ $subsection slot-spec-writer }
+{ $subsection writer-word }
-"Given a reader or writer word and a class, it is possible to find the slot specifier corresponding to this word:"
+{ $subsection setter-word }
-{ $subsection slot-of-reader }
+{ $subsection changer-word }
-{ $subsection slot-of-writer }
+"Looking up a slot by name:"
-"Reader and writer words form classes:"
+{ $subsection slot-named }
-{ $subsection slot-reader }
+"Defining slots dynamically:"
-{ $subsection slot-writer }
+{ $subsection define-reader }
-"Slot readers and writers type check, then call unsafe primitives:"
+{ $subsection define-writer }
-{ $subsection slot }
+{ $subsection define-setter }
-{ $subsection set-slot } ;
+{ $subsection define-changer }
+{ $subsection define-slot-methods }
+{ $subsection define-accessors }
+{ $see-also "accessors" "mirrors" } ;
 
 ABOUT: "slots"
 
@@ -59,53 +120,32 @@ $low-level-note ;
 
 HELP: reader-effect
 { $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
-{ $description "The stack effect of slot reader words is " { $snippet "( obj -- value )" } "." } ;
+{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
-
-HELP: reader-quot
-{ $values { "decl" class } { "quot" "a quotation with stack effect " { $snippet "( obj n -- value )" } } }
-{ $description "Outputs a quotation which reads the " { $snippet "n" } "th slot of an object and declares it as an instance of a class." } ;
-
-HELP: slot-reader
-{ $class-description "The class of slot reader words." }
-{ $examples
-    { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" }
-} ;
 
 HELP: define-reader
-{ $values { "class" class } { "spec" slot-spec } }
+{ $values { "class" class } { "name" string } { "slot" integer } }
-{ $description "Defines a generic word " { $snippet "reader" } " to read a slot from instances of " { $snippet "class" } "." }
+{ $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." }
 $low-level-note ;
 
 HELP: writer-effect
 { $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
 { $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
 
-HELP: slot-writer
-{ $class-description "The class of slot writer words." }
-{ $examples
-    { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" }
-} ;
-
 HELP: define-writer
-{ $values { "class" class } { "spec" slot-spec } }
+{ $values { "class" class } { "name" string } { "slot" integer } }
 { $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
 $low-level-note ;
 
-HELP: define-slot
+HELP: define-slot-methods
-{ $values { "class" class } { "spec" slot-spec } }
+{ $values { "class" class } { "name" string } { "slot" integer } }
-{ $description "Defines a pair of generic words for reading and writing a slot value in instances of " { $snippet "class" } "." }
+{ $description "Defines a reader, writer, setter and changer for a slot in instances of " { $snippet "class" } "." }
 $low-level-note ;
 
-HELP: define-slots
+HELP: define-accessors
 { $values { "class" class } { "specs" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Defines a set of slot reader/writer words." }
+{ $description "Defines slot methods." }
 $low-level-note ;
 
-HELP: simple-slots
-{ $values { "class" class } { "slots" "a sequence of strings" } { "base" "a slot number" } { "specs" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Constructs a slot specification for " { $link define-slots } " where each slot is named by an element of " { $snippet "slots" } " prefixed by the name of the class. Slots are numbered consecutively starting from " { $snippet "base" } ". Reader and writer words are defined in the current vocabulary, with the reader word having the same name as the slot, and the writer word name prefixed by " { $snippet "\"set-\"" } "." }
-{ $notes "This word is used by " { $link define-tuple-class } " and " { $link POSTPONE: TUPLE: } "." } ;
-
 HELP: slot ( obj m -- value )
 { $values { "obj" object } { "m" "a non-negative fixnum" } { "value" object } }
 { $description "Reads the object stored at the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
@@ -116,18 +156,6 @@ HELP: set-slot ( value obj n -- )
 { $description "Writes " { $snippet "value" } " to the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
 { $warning "This word is in the " { $vocab-link "slots.private" } " vocabulary because it does not perform type or bounds checks, and slot numbers are implementation detail." } ;
 
-HELP: slot-of-reader
+HELP: slot-named
-{ $values { "reader" slot-reader } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
+{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
-{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-reader } " is equal to " { $snippet "reader" } "." } ;
+{ $description "Outputs the " { $link slot-spec } " with the given name." } ;
-
-HELP: slot-of-writer
-{ $values { "writer" slot-writer } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
-{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-writer } " is equal to " { $snippet "writer" } "." } ;
-
-HELP: reader-word
-{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
-{ $description "Creates a word named " { $snippet { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;
-
-HELP: writer-word
-{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
-{ $description "Creates a word named " { $snippet "set-" { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;

core/slots/slots.factor

@@ -16,9 +16,6 @@ C: <slot-spec> slot-spec
 : define-slot-word ( class slot word quot -- )
     rot >fixnum add* define-typecheck ;
 
-: reader-effect ( class spec -- effect )
-    >r ?word-name 1array r> slot-spec-name 1array <effect> ;
-
 : reader-quot ( decl -- quot )
     [
         \ slot ,
@@ -26,91 +23,62 @@ C: <slot-spec> slot-spec
         [ drop ] [ 1array , \ declare , ] if
     ] [ ] make ;
 
-PREDICATE: word slot-reader "reading" word-prop >boolean ;
+: slot-named ( name specs -- spec/f )
-
-: set-reader-props ( class spec -- )
-    2dup reader-effect
-    over slot-spec-reader
-    swap "declared-effect" set-word-prop
-    slot-spec-reader swap "reading" set-word-prop ;
-
-: define-reader ( class spec -- )
-    dup slot-spec-reader [
-        [ set-reader-props ] 2keep
-        dup slot-spec-offset
-        over slot-spec-reader
-        rot slot-spec-type reader-quot
-        define-slot-word
-    ] [
-        2drop
-    ] if ;
-
-: writer-effect ( class spec -- effect )
-    slot-spec-name swap ?word-name 2array 0 <effect> ;
-
-PREDICATE: word slot-writer "writing" word-prop >boolean ;
-
-: set-writer-props ( class spec -- )
-    2dup writer-effect
-    over slot-spec-writer
-    swap "declared-effect" set-word-prop
-    slot-spec-writer swap "writing" set-word-prop ;
-
-: define-writer ( class spec -- )
-    dup slot-spec-writer [
-        [ set-writer-props ] 2keep
-        dup slot-spec-offset
-        swap slot-spec-writer
-        [ set-slot ]
-        define-slot-word
-    ] [
-        2drop
-    ] if ;
-
-: define-slot ( class spec -- )
-    2dup define-reader define-writer ;
-
-: define-slots ( class specs -- )
-    [ define-slot ] with each ;
-
-: reader-word ( class name vocab -- word )
-    >r >r "-" r> 3append r> create ;
-
-: writer-word ( class name vocab -- word )
-    >r [ swap "set-" % % "-" % % ] "" make r> create ;
-
-: (simple-slot-word) ( class name -- class name vocab )
-    over word-vocabulary >r >r word-name r> r> ;
-
-: simple-reader-word ( class name -- word )
-    (simple-slot-word) reader-word ;
-
-: simple-writer-word ( class name -- word )
-    (simple-slot-word) writer-word ;
-
-: short-slot ( class name # -- spec )
-    >r object bootstrap-word over r> f f <slot-spec>
-    2over simple-reader-word over set-slot-spec-reader
-    -rot simple-writer-word over set-slot-spec-writer ;
-
-: long-slot ( spec # -- spec )
-    >r [ dup array? [ first2 create ] when ] map first4 r>
-    -rot <slot-spec> ;
-
-: simple-slots ( class slots base -- specs )
-    over length [ + ] with map [
-        {
-            { [ over not ] [ 2drop f ] }
-            { [ over string? ] [ >r dupd r> short-slot ] }
-            { [ over array? ] [ long-slot ] }
-        } cond
-    ] 2map [ ] subset nip ;
-
-: slot-of-reader ( reader specs -- spec/f )
-    [ slot-spec-reader eq? ] with find nip ;
-
-: slot-of-writer ( writer specs -- spec/f )
-    [ slot-spec-writer eq? ] with find nip ;
-
-: slot-named ( string specs -- spec/f )
     [ slot-spec-name = ] with find nip ;
+
+: create-accessor ( name effect -- word )
+    >r "accessors" create dup r>
+    "declared-effect" set-word-prop ;
+
+: reader-effect T{ effect f { "object" } { "value" } } ; inline
+
+: reader-word ( name -- word )
+    ">>" append reader-effect create-accessor ;
+
+: define-reader ( class slot name -- )
+    reader-word object reader-quot define-slot-word ;
+
+: writer-effect T{ effect f { "value" "object" } { } } ; inline
+
+: writer-word ( name -- word )
+    "(>>" swap ")" 3append writer-effect create-accessor ;
+
+: define-writer ( class slot name -- )
+    writer-word [ set-slot ] define-slot-word ;
+
+: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
+
+: setter-word ( name -- word )
+    ">>" prepend setter-effect create-accessor ;
+
+: define-setter ( name -- )
+    dup setter-word dup deferred? [
+        [ \ over , swap writer-word , ] [ ] make define-inline
+    ] [ 2drop ] if ;
+
+: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
+
+: changer-word ( name -- word )
+    "change-" prepend changer-effect create-accessor ;
+
+: define-changer ( name -- )
+    dup changer-word dup deferred? [
+        [
+            [ over >r >r ] %
+            over reader-word ,
+            [ r> call r> swap ] %
+            swap setter-word ,
+        ] [ ] make define-inline
+    ] [ 2drop ] if ;
+
+: define-slot-methods ( class slot name -- )
+    dup define-changer
+    dup define-setter
+    3dup define-reader
+    define-writer ;
+
+: define-accessors ( class specs -- )
+    [
+        dup slot-spec-offset swap slot-spec-name
+        define-slot-methods
+    ] with each ;

core/splitting/splitting-tests.factor

@@ -1,4 +1,4 @@
-USING: splitting tools.test ;
+USING: splitting tools.test kernel sequences arrays ;
 IN: splitting.tests
 
 [ { 1 2 3 } 0 group ] must-fail
@@ -56,3 +56,9 @@ unit-test
 [ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test
 [ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test
 [ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test
+
+[ { V{ "a" "b" } V{ f f } } ] [
+    V{ "a" "b" } clone 2 <groups>
+    2 over set-length
+    >array
+] unit-test

core/splitting/splitting.factor

@@ -17,7 +17,7 @@ M: groups length
     dup groups-seq length swap groups-n [ + 1- ] keep /i ;
 
 M: groups set-length
-    [ groups-n * ] keep delegate set-length ;
+    [ groups-n * ] keep groups-seq set-length ;
 
 : group@ ( n groups -- from to seq )
     [ groups-n [ * dup ] keep + ] keep

core/syntax/syntax-docs.factor

@@ -227,6 +227,9 @@ HELP: foldable
     }
     "The last restriction ensures that words such as " { $link clone } " do not satisfy the foldable word contract. Indeed, " { $link clone } " will output a mutable object if its input is mutable, and so it is undesirable to evaluate it at compile-time, since doing so would give incorrect semantics for code that clones mutable objects and proceeds to mutate them."
 }
+{ $notes
+    "Folding optimizations are not applied if the call site of a word is in the same source file as the word. This is a side-effect of the compilation unit system; see " { $link "compilation-units" } "."
+}
 { $examples "Most operations on numbers are foldable. For example, " { $snippet "2 2 +" } " compiles to a literal 4, since " { $link + } " is declared foldable." } ;
 
 HELP: flushable
@@ -556,10 +559,17 @@ HELP: PREDICATE:
 HELP: TUPLE:
 { $syntax "TUPLE: class slots... ;" }
 { $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
-{ $description "Defines a new tuple class with membership predicate " { $snippet "name?" } "."
+{ $description "Defines a new tuple class."
 $nl
 "Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ;
 
+HELP: ERROR:
+{ $syntax "ERROR: class slots... ;" }
+{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
+{ $description "Defines a new tuple class.  Defines a new word " { $snippet "class?" } " that boa-constructs this tuple and throws it." } ;
+
+{ POSTPONE: ERROR: POSTPONE: TUPLE: } related-words
+
 HELP: C:
 { $syntax "C: constructor class" }
 { $values { "constructor" "a new word to define" } { "class" tuple-class } }

core/syntax/syntax.factor

@@ -163,6 +163,12 @@ IN: bootstrap.syntax
         [ construct-boa ] curry define-inline
     ] define-syntax
 
+    "ERROR:" [
+        CREATE-CLASS dup ";" parse-tokens define-tuple-class
+        dup save-location
+        dup [ construct-boa throw ] curry define
+    ] define-syntax
+
     "FORGET:" [
         scan-word
         dup parsing? [ V{ } clone swap execute first ] when

core/tuples/tuples-docs.factor

@@ -3,11 +3,10 @@ tuples.private classes slots quotations words arrays
 generic.standard sequences definitions compiler.units ;
 IN: tuples
 
-ARTICLE: "tuple-constructors" "Constructors and slots"
+ARTICLE: "tuple-constructors" "Constructors"
-"Tuples are created by calling one of a number of words:"
+"Tuples are created by calling one of two words:"
 { $subsection construct-empty }
 { $subsection construct-boa }
-{ $subsection construct }
 "By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
 $nl
 "A shortcut for defining BOA constructors:"
@@ -19,18 +18,13 @@ $nl
     "C: <rgba> rgba"
     ": <rgba> color construct-boa ; ! identical to above"
     ""
-    ": <rgb>"
+    ": <rgb> f <rgba> ;"
-    "    { 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"
+ARTICLE: "tuple-delegation" "Tuple delegation"
 "If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown."
 { $subsection delegate }
 { $subsection set-delegate }
@@ -48,7 +42,7 @@ $nl
     "{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
     "{ 1 0 0 } <colored> \"my-shape\" set"
     "\"my-ellipse\" get \"my-shape\" get set-delegate"
-    "\"my-shape\" get dup colored-color swap ellipse-center .s"
+    "\"my-shape\" get dup color>> swap center>> .s"
     "{ 0 0 }\n{ 1 0 0 }"
 } ;
 
@@ -58,25 +52,90 @@ ARTICLE: "tuple-introspection" "Tuple introspection"
 { $subsection tuple>array }
 { $subsection tuple-slots }
 "Tuple classes can also be defined at run time:"
-{ $subsection define-tuple-class } ;
+{ $subsection define-tuple-class }
+{ $see-also "slots" "mirrors" } ;
+
+ARTICLE: "tuple-examples" "Tuple examples"
+"An example:"
+{ $code "TUPLE: employee name salary position ;" }
+"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
+{ $table
+    { "Reader" "Writer" "Setter" "Changer" }
+    { { $snippet "name>>" }    { $snippet "(>>name)" }    { $snippet ">>name" }    { $snippet "change-name" }    }
+    { { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } }
+    { { $snippet "position>>" }   { $snippet "(>>position)" }   { $snippet ">>position" }   { $snippet "change-position" }   }
+}
+"We can define a constructor which makes an empty employee:"
+{ $code ": <employee> ( -- employee )"
+    "    employee construct-empty ;" }
+"Or we may wish the default constructor to always give employees a starting salary:"
+{ $code
+    ": <employee> ( -- employee )"
+    "    employee construct-empty"
+    "        40000 >>salary ;"
+}
+"We can define more refined constructors:"
+{ $code
+    ": <manager> ( -- manager )"
+    "    <employee> \"project manager\" >>position ;" }
+"An alternative strategy is to define the most general BOA constructor first:"
+{ $code
+    ": <employee> ( name position -- person )"
+    "    40000 employee construct-boa ;"
+}
+"Now we can define more specific constructors:"
+{ $code
+    ": <manager> ( name -- person )"
+    "    \"manager\" <person> ;" }
+"An example using reader words:"
+{ $code
+    "TUPLE: check to amount number ;"
+    ""
+    "SYMBOL: checks"
+    ""
+    ": <check> ( to amount -- check )"
+    "    checks counter check construct-boa ;"
+    ""
+    ": biweekly-paycheck ( employee -- check )"
+    "    dup name>> swap salary>> 26 / <check> ;"
+}
+"An example of using a changer:"
+{ $code
+    ": positions"
+    "    {"
+    "        \"junior programmer\""
+    "        \"senior programmer\""
+    "        \"project manager\""
+    "        \"department manager\""
+    "        \"executive\""
+    "        \"CTO\""
+    "        \"CEO\""
+    "        \"enterprise Java world dictator\""
+    "    } ;"
+    ""
+    ": next-position ( role -- newrole )"
+    "    positions [ index 1+ ] keep nth ;"
+    ""
+    ": promote ( person -- person )"
+    "    [ 1.2 * ] change-salary"
+    "    [ next-position ] change-position ;"
+} ;
 
 ARTICLE: "tuples" "Tuples"
-"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
+"Tuples are user-defined classes composed of named slots."
+{ $subsection "tuple-examples" }
+"A parsing word defines tuple classes:"
 { $subsection POSTPONE: TUPLE: }
-"An example:"
+"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot."
-{ $code "TUPLE: person name address phone ;" "C: <person> person" }
+$nl
-"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
+"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:"
-{ $table
+{ $subsection "accessors" }
-    { "Reader" "Writer" }
-    { { $snippet "person-name" }    { $snippet "set-person-name" }    }
-    { { $snippet "person-address" } { $snippet "set-person-address" } }
-    { { $snippet "person-phone" }   { $snippet "set-person-phone" }   }
-}
 "Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
 { $subsection "tuple-constructors" }
 "Further topics:"
 { $subsection "tuple-delegation" }
-{ $subsection "tuple-introspection" } ;
+{ $subsection "tuple-introspection" }
+"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
 
 ABOUT: "tuples"
 

core/tuples/tuples-tests.factor

@@ -236,7 +236,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
 
 [
     "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ [ check-tuple? ] is? ] must-fail-with
+] [ [ no-tuple-class? ] is? ] must-fail-with
 
 ! Hardcore unit tests
 USE: threads

core/tuples/tuples.factor

@@ -3,7 +3,8 @@
 USING: arrays definitions hashtables kernel
 kernel.private math namespaces sequences sequences.private
 strings vectors words quotations memory combinators generic
-classes classes.private slots slots.private compiler.units ;
+classes classes.private slots slots.deprecated slots.private
+compiler.units ;
 IN: tuples
 
 M: tuple delegate 3 slot ;
@@ -85,13 +86,14 @@ PRIVATE>
     dupd 4 simple-slots
     2dup [ slot-spec-name ] map "slot-names" set-word-prop
     2dup delegate-slot-spec add* "slots" set-word-prop
-    define-slots ;
+    2dup define-slots
+    define-accessors ;
 
-TUPLE: check-tuple class ;
+ERROR: no-tuple-class class ;
 
 : check-tuple ( class -- )
     dup tuple-class?
-    [ drop ] [ \ check-tuple construct-boa throw ] if ;
+    [ drop ] [ no-tuple-class ] if ;
 
 : define-tuple-class ( class slots -- )
     2dup check-shape

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
 
@@ -115,7 +115,7 @@ 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
@@ -136,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 )
-    vocab dup [ vocab-root ] when ;
+    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? ;
@@ -70,18 +70,9 @@ SYMBOL: load-help?
         docs-were-loaded
     ] [ drop ] if ;
 
-: create-vocab-with-root ( name root -- vocab )
-    swap create-vocab [ set-vocab-root ] keep ;
-
-: update-root ( vocab -- )
-    dup vocab-root
-    [ drop ] [ dup find-vocab-root swap set-vocab-root ] if ;
-
 : reload ( name -- )
     [
-        dup vocab [
+        dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if
-            dup update-root dup load-source load-docs
-        ] [ no-vocab ] ?if
     ] with-compiler-errors ;
 
 : require ( vocab -- )
@@ -104,22 +95,17 @@ SYMBOL: blacklist
 GENERIC: (load-vocab) ( name -- )
 
 M: vocab (load-vocab)
-    dup update-root
-
-    dup vocab-root [
     [
         dup vocab-source-loaded? [ dup load-source ] unless
         dup vocab-docs-loaded? [ dup load-docs ] unless
-        ] [ [ swap add-to-blacklist ] keep rethrow ] recover
+        drop
-    ] when drop ;
+    ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
-
-M: string (load-vocab)
-    ! ".private" ?tail drop
-    dup find-vocab-root >vocab-link (load-vocab) ;
 
 M: vocab-link (load-vocab)
-    dup vocab-name swap vocab-root dup
+    vocab-name create-vocab (load-vocab) ;
-    [ create-vocab-with-root (load-vocab) ] [ 2drop ] if ;
+
+M: string (load-vocab)
+    create-vocab (load-vocab) ;
 
 [
     [
@@ -127,7 +113,11 @@ M: vocab-link (load-vocab)
             rethrow
         ] [
             drop
+            dup find-vocab-root [
                 [ (load-vocab) ] with-compiler-errors
+            ] [
+                dup vocab [ drop ] [ no-vocab ] if
+            ] if
         ] if
     ] with-compiler-errors
 ] load-vocab-hook set-global

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

@@ -7,8 +7,7 @@ IN: vocabs
 SYMBOL: dictionary
 
 TUPLE: vocab
-name root
+name words
-words
 main help
 source-loaded? docs-loaded? ;
 
@@ -60,16 +59,12 @@ M: f vocab-help ;
 : create-vocab ( name -- vocab )
     dictionary get [ <vocab> ] cache ;
 
-TUPLE: no-vocab name ;
+ERROR: no-vocab name ;
-
-: 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 load-vocab-hook get call vocab ;
-    dup vocab [ ] [ no-vocab ] ?if ;
 
 : vocabs ( -- seq )
     dictionary get keys natural-sort ;
@@ -92,10 +87,10 @@ SYMBOL: load-vocab-hook ! ( name -- )
 : 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?
@@ -106,17 +101,14 @@ 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 ;

core/words/words.factor

@@ -21,9 +21,7 @@ M: word definer drop \ : \ ; ;
 
 M: word definition word-def ;
 
-TUPLE: undefined ;
+ERROR: undefined ;
-
-: undefined ( -- * ) \ undefined construct-empty throw ;
 
 PREDICATE: word deferred ( obj -- ? )
     word-def [ undefined ] = ;
@@ -189,12 +187,11 @@ M: word subwords drop f ;
     [ ] [ no-vocab ] ?if
     set-at ;
 
-TUPLE: check-create name vocab ;
+ERROR: bad-create name vocab ;
 
 : check-create ( name vocab -- name vocab )
-    2dup [ string? ] both? [
+    2dup [ string? ] both?
-        \ check-create construct-boa throw
+    [ bad-create ] unless ;
-    ] unless ;
 
 : create ( name vocab -- word )
     check-create 2dup lookup

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/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,13 @@
+USING: vocabs.loader sequences system
+random random.mersenne-twister combinators init
+namespaces ;
+
+"random.mersenne-twister" require
+
+{
+    { [ windows? ] [ "random.windows" require ] }
+    { [ unix? ] [ "random.unix" require ] }
+} cond
+
+[ millis <mersenne-twister> random-generator set-global ]
+"generator.random" add-init-hook

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/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 ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -86,7 +86,7 @@ IN: builder
     +closed+         >>stdin
     "../test-log"    >>stdout
     +stdout+         >>stderr
-    45 minutes       >>timeout ;
+    120 minutes      >>timeout ;
 
 : do-builder-test ( -- )
   builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;

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/builder/util/util.factor

@@ -3,7 +3,7 @@ USING: kernel words namespaces classes parser continuations
        io io.files io.launcher io.sockets
        math math.parser
        combinators sequences splitting quotations arrays strings tools.time
-       sequences.deep new-slots accessors assocs.lib
+       sequences.deep accessors assocs.lib
        io.encodings.utf8
        combinators.cleave bake calendar calendar.format ;
 

extra/bunny/deploy.factor

@@ -1,14 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-math? t }
+    { deploy-word-defs? f }
-    { deploy-reflection 1 }
+    { deploy-random? f }
     { deploy-name "Bunny" }
     { deploy-threads? t }
-    { deploy-word-props? f }
-    { "stop-after-last-window?" t }
-    { deploy-ui? t }
-    { deploy-io 3 }
     { deploy-compiler? t }
-    { deploy-word-defs? f }
+    { deploy-math? t }
     { deploy-c-types? f }
+    { deploy-io 3 }
+    { deploy-reflection 1 }
+    { deploy-ui? t }
+    { "stop-after-last-window?" t }
+    { deploy-word-props? f }
 }

extra/cairo/ffi/ffi.factor

@@ -13,7 +13,7 @@ USING: alien alien.syntax combinators system ;
 IN: cairo.ffi
 
 << "cairo" {
-        { [ win32? ] [ "cairo.dll" ] }
+        { [ win32? ] [ "libcairo-2.dll" ] }
         ! { [ macosx? ] [ "libcairo.dylib" ] }
         { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
         { [ unix? ] [ "libcairo.so.2" ] }

extra/cairo/lib/lib.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types cairo.ffi continuations destructors
-kernel libc locals math combinators.cleave shuffle new-slots
+kernel libc locals math combinators.cleave shuffle
 accessors ;
 IN: cairo.lib
 

extra/cairo/png/png.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.cleave kernel new-slots
+USING: arrays combinators.cleave kernel
 accessors math ui.gadgets ui.render opengl.gl byte-arrays
 namespaces opengl cairo.ffi cairo.lib ;
 IN: cairo.png

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 ;
+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"
@@ -56,31 +59,29 @@ SYMBOL: m
 
 PRIVATE>
 
-: julian-day-number ( year month day -- n )
+:: julian-day-number ( year month day -- n )
     #! Returns a composite date number
     #! Not valid before year -4800
-    [
+    [let* | a [ 14 month - 12 /i ]
-        14 pick - 12 /i a set
+            y [ year 4800 + a - ]
-        pick 4800 + a get - y set
+            m [ month 12 a * + 3 - ] |
-        over 12 a get * + 3 - m set
+        day 153 m * 2 + 5 /i + 365 y * +
-        2nip 153 m get * 2 + 5 /i + 365 y get * +
+        y 4 /i + y 100 /i - y 400 /i + 32045 -
-        y get 4 /i + y get 100 /i - y get 400 /i + 32045 -
+    ] ;
-    ] with-scope ;
 
-: julian-day-number>date ( n -- year month day )
+:: julian-day-number>date ( n -- year month day )
     #! Inverse of julian-day-number
-    [
+    [let* | a [ n 32044 + ]
-        32044 + a set
+            b [ 4 a * 3 + 146097 /i ]
-        4 a get * 3 + 146097 /i b set
+            c [ a 146097 b * 4 /i - ]
-        a get 146097 b get * 4 /i - c set
+            d [ 4 c * 3 + 1461 /i ]
-        4 c get * 3 + 1461 /i d set
+            e [ c 1461 d * 4 /i - ]
-        c get 1461 d get * 4 /i - e set
+            m [ 5 e * 2 + 153 /i ] |
-        5 e get * 2 + 153 /i m set
+        100 b * d + 4800 -
-        100 b get * d get + 4800 -
+        m 10 /i + m 3 +
-        m get 10 /i + m get 3 +
+        12 m 10 /i * -
-        12 m get 10 /i * -
+        e 153 m * 2 + 5 /i - 1+
-        e get 153 m get * 2 + 5 /i - 1+
+    ] ;
-    ] with-scope ;
 
 : >date< ( timestamp -- year month day )
     { year>> month>> day>> } get-slots ;
@@ -226,16 +227,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 +248,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 +264,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,6 +1,5 @@
-
 USING: alien alien.c-types arrays calendar.backend
-       kernel structs math unix.time namespaces ;
+kernel structs math unix.time namespaces ;
 
 IN: calendar.unix
 
@@ -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

@@ -1,15 +1,21 @@
 USING: calendar.backend namespaces alien.c-types
-windows windows.kernel32 kernel math ;
+windows windows.kernel32 kernel math combinators.cleave
+combinators ;
 IN: calendar.windows
 
 TUPLE: windows-calendar ;
 
 T{ windows-calendar } calendar-backend set-global
 
-: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
+M: windows-calendar gmt-offset ( -- hours minutes seconds )
-
-M: windows-calendar gmt-offset ( -- float )
     "TIME_ZONE_INFORMATION" <c-object>
-    dup GetTimeZoneInformation
+    dup GetTimeZoneInformation {
-    TIME_ZONE_ID_INVALID = [ win32-error ] when
+        { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] }
-    TIME_ZONE_INFORMATION-Bias 60 / neg ;
+        { [ dup [ TIME_ZONE_ID_UNKNOWN = ] [ TIME_ZONE_ID_STANDARD = ] bi or ] [
+            drop TIME_ZONE_INFORMATION-Bias ] }
+        { [ dup TIME_ZONE_ID_DAYLIGHT = ] [
+            drop
+            [ TIME_ZONE_INFORMATION-Bias ]
+            [ TIME_ZONE_INFORMATION-DaylightBias ] bi +
+        ] }
+    } cond neg 60 /mod 0 ;

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/circular/circular-tests.factor

@@ -9,7 +9,6 @@ circular strings ;
 [ CHAR: t ] [ "test" <circular> 0 swap nth ] unit-test
 [ "test"  ] [ "test" <circular> >string ] unit-test
 
-[ "test" <circular> 5 swap nth ] must-fail
 [ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
  
 [ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
@@ -18,10 +17,13 @@ circular strings ;
 [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
 
 [ "fob" ] [ "foo" <circular> CHAR: b 2 pick set-nth >string ] unit-test
-[ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
 [ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test
 [ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test
 
 [ "bcd" ] [ 3 <circular-string> "abcd" [ over push-circular ] each >string ] unit-test
 
 [ { 0 0 } ] [ { 0 0 } <circular> -1 over change-circular-start >array ] unit-test
+
+! This no longer fails
+! [ "test" <circular> 5 swap nth ] must-fail
+! [ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail

extra/circular/circular.factor

@@ -18,9 +18,9 @@ M: circular length circular-seq length ;
 
 M: circular virtual@ circular-wrap circular-seq ;
 
-M: circular nth bounds-check virtual@ nth ;
+M: circular nth virtual@ nth ;
 
-M: circular set-nth bounds-check virtual@ set-nth ;
+M: circular set-nth virtual@ set-nth ;
 
 : change-circular-start ( n circular -- )
     #! change start to (start + n) mod length