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

Factor.app/Contents/Info.plist

@@ -32,7 +32,7 @@
 	<key>CFBundlePackageType</key>
 	<string>APPL</string>
 	<key>NSHumanReadableCopyright</key>
-	<string>Copyright © 2003-2007, Slava Pestov and friends</string>
+	<string>Copyright © 2003-2008, Slava Pestov and friends</string>
 	<key>NSServices</key>
 	<array>
 		<dict>

build-support/factor.sh

@@ -89,11 +89,6 @@ set_md5sum() {
 set_gcc() {
     case $OS in
         openbsd) ensure_program_installed egcc; CC=egcc;;
-	netbsd) if [[ $WORD -eq 64 ]] ; then
-			CC=/usr/pkg/gcc34/bin/gcc
-		else
-			CC=gcc
-		fi ;;
         *) CC=gcc;;
     esac
 }

core/alien/alien-docs.factor

@@ -265,7 +265,7 @@ ARTICLE: "embedding-restrictions" "Embedding API restrictions"
 ARTICLE: "embedding-factor" "What embedding looks like from Factor"
 "Factor code will run inside an embedded instance in the same way it would run in a stand-alone instance."
 $nl
-"One exception is the global " { $link stdio } " stream, which is by default not bound to the terminal where the process is running, to avoid conflicting with any I/O the host process might perform. To initialize the terminal stream, " { $link init-stdio } " must be called explicitly."
+"One exception is that the global " { $link input-stream } " and " { $link output-stream } " streams are not bound by default, to avoid conflicting with any I/O the host process might perform. The " { $link init-stdio } " words must be called explicitly to initialize terminal streams."
 $nl
 "There is a word which can detect when Factor is embedded:"
 { $subsection embedded? }

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

@@ -1,7 +1,7 @@
 IN: alien.c-types
 USING: alien help.syntax help.markup libc kernel.private
 byte-arrays math strings hashtables alien.syntax
-bit-arrays float-arrays debugger ;
+bit-arrays float-arrays debugger destructors ;
 
 HELP: <c-type>
 { $values { "type" hashtable } }
@@ -222,6 +222,9 @@ $nl
 { $subsection realloc }
 "You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
 { $subsection free }
+"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
+{ $subsection &free }
+{ $subsection |free }
 "You can unsafely copy a range of bytes from one memory location to another:"
 { $subsection memcpy }
 "You can copy a range of bytes from memory into a byte array:"

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

@@ -5,7 +5,7 @@ assocs kernel kernel.private libc math
 namespaces parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
 layouts system compiler.units io.files io.encodings.binary
-accessors combinators ;
+accessors combinators effects ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -214,7 +214,8 @@ M: long-long-type box-return ( type -- )
     >r ">c-" swap "-array" 3append r> create ;
 
 : define-to-array ( type vocab -- )
-    [ to-array-word ] 2keep >c-array-quot define ;
+    [ to-array-word ] 2keep >c-array-quot
+    (( array -- byte-array )) define-declared ;
 
 : c-array>quot ( type vocab -- quot )
     [
@@ -227,7 +228,8 @@ M: long-long-type box-return ( type -- )
     >r "c-" swap "-array>" 3append r> create ;
 
 : define-from-array ( type vocab -- )
-    [ from-array-word ] 2keep c-array>quot define ;
+    [ from-array-word ] 2keep c-array>quot
+    (( c-ptr n -- array )) define-declared ;
 
 : define-primitive-type ( type name -- )
     "alien.c-types"
@@ -382,4 +384,6 @@ M: long-long-type box-return ( type -- )
     "double" define-primitive-type
 
     os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
+
+    "ulong" "size_t" typedef
 ] with-compilation-unit

core/alien/compiler/compiler-tests.factor

@@ -77,7 +77,7 @@ FUNCTION: tiny ffi_test_17 int x ;
 
 [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
 
-: indirect-test-1
+: indirect-test-1 ( ptr -- result )
     "int" { } "cdecl" alien-indirect ;
 
 { 1 1 } [ indirect-test-1 ] must-infer-as
@@ -86,7 +86,7 @@ FUNCTION: tiny ffi_test_17 int x ;
 
 [ -1 indirect-test-1 ] must-fail
 
-: indirect-test-2
+: indirect-test-2 ( x y ptr -- result )
     "int" { "int" "int" } "cdecl" alien-indirect gc ;
 
 { 3 1 } [ indirect-test-2 ] must-infer-as
@@ -95,7 +95,7 @@ FUNCTION: tiny ffi_test_17 int x ;
 [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
 unit-test
 
-: indirect-test-3
+: indirect-test-3 ( a b c d ptr -- result )
     "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
     gc ;
 
@@ -139,7 +139,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
 
 ! Make sure XT doesn't get clobbered in stack frame
 
-: ffi_test_31
+: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y )
     "void"
     f "ffi_test_31"
     { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
@@ -286,21 +286,21 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 
 ! Test callbacks
 
-: callback-1 "void" { } "cdecl" [ ] alien-callback ;
+: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
 
 [ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
 
 [ t ] [ callback-1 alien? ] unit-test
 
-: callback_test_1 "void" { } "cdecl" alien-indirect ;
+: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
 
 [ ] [ callback-1 callback_test_1 ] unit-test
 
-: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
 
 [ ] [ callback-2 callback_test_1 ] unit-test
 
-: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
 
 [ t ] [
     namestack*
@@ -314,7 +314,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
     ] with-scope
 ] unit-test
 
-: callback-4
+: callback-4 ( -- callback )
     "void" { } "cdecl" [ "Hello world" write ] alien-callback
     gc ;
 
@@ -322,14 +322,14 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
     [ callback-4 callback_test_1 ] with-string-writer
 ] unit-test
 
-: callback-5
+: callback-5 ( -- callback )
     "void" { } "cdecl" [ gc ] alien-callback ;
 
 [ "testing" ] [
     "testing" callback-5 callback_test_1
 ] unit-test
 
-: callback-5a
+: callback-5a ( -- callback )
     "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
 
 ! Hack; if we're on ARM, we probably don't have much RAM, so
@@ -340,26 +340,26 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
 !     ] unit-test
 ! ] unless
 
-: callback-6
+: callback-6 ( -- callback )
     "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
 
 [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
 
-: callback-7
+: callback-7 ( -- callback )
     "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
 
 [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
 
 [ f ] [ namespace global eq? ] unit-test
 
-: callback-8
+: callback-8 ( -- callback )
     "void" { } "cdecl" [
         [ continue ] callcc0
     ] alien-callback ;
 
 [ ] [ callback-8 callback_test_1 ] unit-test
 
-: callback-9
+: callback-9 ( -- callback )
     "int" { "int" "int" "int" } "cdecl" [
         + + 1+
     ] alien-callback ;

core/alien/compiler/compiler.factor

@@ -7,7 +7,7 @@ math.parser classes alien.arrays alien.c-types alien.strings
 alien.structs alien.syntax cpu.architecture alien inspector
 quotations assocs kernel.private threads continuations.private
 libc combinators compiler.errors continuations layouts accessors
-;
+init ;
 IN: alien.compiler
 
 TUPLE: #alien-node < node return parameters abi ;
@@ -216,7 +216,8 @@ M: alien-invoke-error summary
     drop
     "Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
 
-: pop-parameters pop-literal nip [ expand-constants ] map ;
+: pop-parameters ( -- seq )
+    pop-literal nip [ expand-constants ] map ;
 
 : stdcall-mangle ( symbol node -- symbol )
     "@"
@@ -270,7 +271,7 @@ M: no-such-symbol compiler-error-type
     pop-literal nip >>library
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup param-prep-quot f infer-quot
+    dup param-prep-quot recursive-state get infer-quot
     ! Set ABI
     dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
     ! Add node to IR
@@ -278,7 +279,7 @@ M: no-such-symbol compiler-error-type
     ! Magic #: consume exactly the number of inputs
     dup 0 alien-invoke-stack
     ! Quotation which coerces return value to required type
-    return-prep-quot f infer-quot
+    return-prep-quot recursive-state get infer-quot
 ] "infer" set-word-prop
 
 M: #alien-invoke generate-node
@@ -306,13 +307,13 @@ M: alien-indirect-error summary
     pop-parameters >>parameters
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup param-prep-quot [ dip ] curry f infer-quot
+    dup param-prep-quot [ dip ] curry recursive-state get infer-quot
     ! Add node to IR
     dup node,
     ! Magic #: consume the function pointer, too
     dup 1 alien-invoke-stack
     ! Quotation which coerces return value to required type
-    return-prep-quot f infer-quot
+    return-prep-quot recursive-state get infer-quot
 ] "infer" set-word-prop
 
 M: #alien-indirect generate-node
@@ -336,7 +337,7 @@ M: #alien-indirect generate-node
 ! this hashtable, they will all be blown away by code GC, beware
 SYMBOL: callbacks
 
-callbacks global [ H{ } assoc-like ] change-at
+[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
 
 : register-callback ( word -- ) dup callbacks get set-at ;
 
@@ -344,8 +345,8 @@ M: alien-callback-error summary
     drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
 
 : callback-bottom ( node -- )
-    xt>> [ word-xt drop <alien> ] curry
+    xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
-    f infer-quot ;
+    recursive-state get infer-quot ;
 
 \ alien-callback [
     4 ensure-values
@@ -354,7 +355,7 @@ M: alien-callback-error summary
     pop-literal nip >>abi
     pop-parameters >>parameters
     pop-literal nip >>return
-    gensym dup register-callback >>xt
+    gensym >>xt
     callback-bottom
 ] "infer" set-word-prop
 

core/alien/remote-control/remote-control.factor

@@ -4,14 +4,14 @@ USING: alien alien.c-types alien.strings parser threads words
 kernel.private kernel io.encodings.utf8 ;
 IN: alien.remote-control
 
-: eval-callback
+: eval-callback ( -- callback )
     "void*" { "char*" } "cdecl"
     [ eval>string utf8 malloc-string ] alien-callback ;
 
-: yield-callback
+: yield-callback ( -- callback )
     "void" { } "cdecl" [ yield ] alien-callback ;
 
-: sleep-callback
+: sleep-callback ( -- callback )
     "void" { "long" } "cdecl" [ sleep ] alien-callback ;
 
 : ?callback ( word -- alien )

core/alien/strings/strings.factor

@@ -85,10 +85,10 @@ M: string-type c-type-getter
 M: string-type c-type-setter
     drop [ set-alien-cell ] ;
 
-TUPLE: utf16n ;
-
 ! Native-order UTF-16
 
+SINGLETON: utf16n
+
 : utf16n ( -- descriptor )
     little-endian? utf16le utf16be ? ; foldable
 

core/alien/structs/structs-docs.factor

@@ -91,6 +91,6 @@ $nl
 ARTICLE: "c-unions" "C unions"
 "A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
 { $subsection POSTPONE: C-UNION: }
-"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
+"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
 $nl
 "Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;

core/alien/syntax/syntax.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays alien alien.c-types alien.structs alien.arrays
 alien.strings kernel math namespaces parser sequences words
-quotations math.parser splitting effects prettyprint
+quotations math.parser splitting grouping effects prettyprint
 prettyprint.sections prettyprint.backend assocs combinators ;
 IN: alien.syntax
 
@@ -40,7 +40,7 @@ PRIVATE>
 
 : FUNCTION:
     scan "c-library" get scan ";" parse-tokens
-    [ "()" subseq? not ] subset
+    [ "()" subseq? not ] filter
     define-function ; parsing
 
 : TYPEDEF:

core/assocs/assocs-docs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Daniel Ehrenberg and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel sequences
-sequences.private namespaces classes math ;
+sequences.private namespaces math ;
 IN: assocs
 
 ARTICLE: "alists" "Association lists"
@@ -39,9 +39,7 @@ ARTICLE: "assocs-protocol" "Associative mapping protocol"
 "All associative mappings must implement methods on the following generic words:"
 { $subsection at* }
 { $subsection assoc-size }
-"At least one of the following two generic words must have a method; the " { $link assoc } " mixin has default definitions which are mutually recursive:"
 { $subsection >alist }
-{ $subsection assoc-find }
 "Mutable assocs should implement the following additional words:"
 { $subsection set-at }
 { $subsection delete-at }
@@ -68,7 +66,7 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
 
 ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
 "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
-{ $subsection subassoc? }
+{ $subsection assoc-subset? }
 { $subsection assoc-intersect }
 { $subsection update }
 { $subsection assoc-union }
@@ -94,9 +92,10 @@ $nl
 $nl
 "The standard functional programming idioms:"
 { $subsection assoc-each }
+{ $subsection assoc-find }
 { $subsection assoc-map }
 { $subsection assoc-push-if }
-{ $subsection assoc-subset }
+{ $subsection assoc-filter }
 { $subsection assoc-contains? }
 { $subsection assoc-all? }
 "Three additional combinators:"
@@ -139,8 +138,7 @@ HELP: new-assoc
 
 HELP: assoc-find
 { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
-{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key or value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found." }
+{ $description "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." } ;
-{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which first converts the assoc to an association list, then iterates over that with the " { $link find } " combinator for sequences." } ;
 
 HELP: clear-assoc
 { $values { "assoc" assoc } }
@@ -203,7 +201,7 @@ HELP: assoc-push-if
 { $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } }
 { $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
 
-HELP: assoc-subset
+HELP: assoc-filter
 { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
 { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
 
@@ -215,7 +213,7 @@ HELP: assoc-all?
 { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
 { $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
 
-HELP: subassoc?
+HELP: assoc-subset?
 { $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
 { $description "Tests if " { $snippet "assoc2" } " contains all key/value pairs of " { $snippet "assoc1" } "." } ;
 
@@ -281,7 +279,7 @@ HELP: assoc-union
 
 HELP: assoc-diff
 { $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
-{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." } 
+{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc1" } " whose key is not contained in " { $snippet "assoc2" } "." } 
 ;
 HELP: remove-all
 { $values { "assoc" assoc } { "seq" "a sequence" } { "subseq" "a new sequence" } }

core/assocs/assocs-tests.factor

@@ -3,13 +3,13 @@ USING: kernel math namespaces tools.test vectors sequences
 sequences.private hashtables io prettyprint assocs
 continuations ;
 
-[ t ] [ H{ } dup subassoc? ] unit-test
+[ t ] [ H{ } dup assoc-subset? ] unit-test
-[ f ] [ H{ { 1 3 } } H{ } subassoc? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
-[ t ] [ H{ } H{ { 1 3 } } subassoc? ] unit-test
+[ t ] [ H{ } H{ { 1 3 } } assoc-subset? ] unit-test
-[ t ] [ H{ { 1 3 } } H{ { 1 3 } } subassoc? ] unit-test
+[ t ] [ H{ { 1 3 } } H{ { 1 3 } } assoc-subset? ] unit-test
-[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } subassoc? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } assoc-subset? ] unit-test
-[ f ] [ H{ { 1 f } } H{ } subassoc? ] unit-test
+[ f ] [ H{ { 1 f } } H{ } assoc-subset? ] unit-test
-[ t ] [ H{ { 1 f } } H{ { 1 f } } subassoc? ] unit-test
+[ t ] [ H{ { 1 f } } H{ { 1 f } } assoc-subset? ] unit-test
 
 ! Test some combinators
 [
@@ -30,10 +30,10 @@ continuations ;
 [ t ] [ H{ { 1 1 } { 2 2 } } [ = ] assoc-all? ] unit-test
 [ f ] [ H{ { 1 2 } { 2 2 } } [ = ] assoc-all? ] unit-test
 
-[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-subset ] unit-test
+[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-filter ] unit-test
 [ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
     H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
-    [ drop 3 >= ] assoc-subset
+    [ drop 3 >= ] assoc-filter
 ] unit-test
 
 [ 21 ] [
@@ -104,3 +104,17 @@ unit-test
         2drop
     ] { } make
 ] unit-test
+
+[
+    H{
+        { "bangers" "mash" }
+        { "fries" "onion rings" }
+    }
+] [
+    { "bangers" "fries" } H{
+        { "fish" "chips" }
+        { "bangers" "mash" }
+        { "fries" "onion rings" }
+        { "nachos" "cheese" }
+    } extract-keys
+] unit-test

core/assocs/assocs.factor

@@ -20,11 +20,9 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
 
 GENERIC: >alist ( assoc -- newassoc )
 
-GENERIC# assoc-find 1 ( assoc quot -- key value ? ) inline
+: assoc-find ( assoc quot -- key value ? )
-
+    >r >alist r> [ first2 ] prepose find swap
-M: assoc assoc-find
+    [ first2 t ] [ drop f f f ] if ; inline
-    >r >alist [ first2 ] r> compose find swap
-    [ first2 t ] [ drop f f f ] if ;
 
 : key? ( key assoc -- ? ) at* nip ; inline
 
@@ -50,7 +48,7 @@ M: assoc assoc-find
 : assoc-pusher ( quot -- quot' accum )
     V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
 
-: assoc-subset ( assoc quot -- subassoc )
+: assoc-filter ( assoc quot -- subassoc )
     over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline
 
 : assoc-contains? ( assoc quot -- ? )
@@ -98,11 +96,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : assoc-stack ( key seq -- value )
     dup length 1- swap (assoc-stack) ;
 
-: subassoc? ( assoc1 assoc2 -- ? )
+: assoc-subset? ( assoc1 assoc2 -- ? )
     [ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
 
 : assoc= ( assoc1 assoc2 -- ? )
-    2dup subassoc? >r swap subassoc? r> and ;
+    [ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
 
 : assoc-hashcode ( n assoc -- code )
     [
@@ -110,7 +108,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     ] { } assoc>map hashcode* ;
 
 : assoc-intersect ( assoc1 assoc2 -- intersection )
-    swap [ nip key? ] curry assoc-subset ;
+    swap [ nip key? ] curry assoc-filter ;
 
 : update ( assoc1 assoc2 -- )
     swap [ swapd set-at ] curry assoc-each ;
@@ -120,10 +118,10 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     [ rot update ] keep [ swap update ] keep ;
 
 : assoc-diff ( assoc1 assoc2 -- diff )
-    swap [ nip key? not ] curry assoc-subset ;
+    [ nip key? not ] curry assoc-filter ;
 
 : remove-all ( assoc seq -- subseq )
-    swap [ key? not ] curry subset ;
+    swap [ key? not ] curry filter ;
 
 : (substitute)
     [ dupd at* [ nip ] [ drop ] if ] curry ; inline
@@ -150,7 +148,10 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : map>assoc ( seq quot exemplar -- assoc )
     >r [ 2array ] compose { } map-as r> assoc-like ; inline
 
-M: assoc >alist [ 2array ] { } assoc>map ;
+: extract-keys ( seq assoc -- subassoc )
+    [ [ dupd at ] curry ] keep map>assoc ;
+
+! M: assoc >alist [ 2array ] { } assoc>map ;
 
 : value-at ( value assoc -- key/f )
     swap [ = nip ] curry assoc-find 2drop ;

core/bootstrap/compiler/compiler.factor

@@ -5,7 +5,7 @@ namespaces parser kernel kernel.private classes classes.private
 arrays hashtables vectors classes.tuple sbufs inference.dataflow
 hashtables.private sequences.private math classes.tuple.private
 growable namespaces.private assocs words generator command-line
-vocabs io prettyprint libc compiler.units ;
+vocabs io prettyprint libc compiler.units math.order ;
 IN: bootstrap.compiler
 
 ! Don't bring this in when deploying, since it will store a
@@ -18,6 +18,9 @@ IN: bootstrap.compiler
 
 enable-compiler
 
+: compile-uncompiled ( words -- )
+    [ compiled? not ] filter compile ;
+
 nl
 "Compiling..." write flush
 
@@ -39,41 +42,41 @@ nl
 
     underlying
 
-    find-pair-next namestack*
+    namestack*
 
     bitand bitor bitxor bitnot
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
-    + 1+ 1- 2/ < <= > >= shift min
+    + 1+ 1- 2/ < <= > >= shift
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     new-sequence nth push pop peek
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     hashcode* = get set
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     . lines
-} compile
+} compile-uncompiled
 
 "." write flush
 
 {
     malloc calloc free memcpy
-} compile
+} compile-uncompiled
 
-vocabs [ words [ compiled? not ] subset compile "." write flush ] each
+vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush

core/bootstrap/image/image-tests.factor

@@ -1,5 +1,22 @@
 IN: bootstrap.image.tests
-USING: bootstrap.image bootstrap.image.private tools.test ;
+USING: bootstrap.image bootstrap.image.private tools.test
+kernel math ;
 
 \ ' must-infer
 \ write-image must-infer
+
+[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
+
+[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
+
+[ f ] [ [ 2drop 0 ] [ 2drop 0.0 ] eql? ] unit-test
+
+[ t ] [ [ 2drop 0 ] [ 2drop 0 ] eql? ] unit-test
+
+[ f ] [ \ + [ 2drop 0 ] eql? ] unit-test
+
+[ f ] [ 3 [ 0 1 2 ] eql? ] unit-test
+
+[ f ] [ 3 3.0 eql? ] unit-test
+
+[ t ] [ 4.0 4.0 eql? ] unit-test

core/bootstrap/image/image.factor

@@ -4,11 +4,11 @@ USING: alien arrays bit-arrays byte-arrays generic assocs
 hashtables assocs hashtables.private io kernel kernel.private
 math namespaces parser prettyprint sequences sequences.private
 strings sbufs vectors words quotations assocs system layouts
-splitting growable classes classes.builtin classes.tuple
+splitting grouping growable classes classes.builtin classes.tuple
 classes.tuple.private words.private io.binary io.files vocabs
 vocabs.loader source-files definitions debugger float-arrays
 quotations.private sequences.private combinators
-io.encodings.binary ;
+io.encodings.binary math.order accessors ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
@@ -31,6 +31,43 @@ IN: bootstrap.image
 
 <PRIVATE
 
+! Object cache; we only consider numbers equal if they have the
+! same type
+TUPLE: id obj ;
+
+C: <id> id
+
+M: id hashcode* obj>> hashcode* ;
+
+GENERIC: (eql?) ( obj1 obj2 -- ? )
+
+: eql? ( obj1 obj2 -- ? )
+    [ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
+
+M: integer (eql?) = ;
+
+M: sequence (eql?)
+    over sequence? [
+        2dup [ length ] bi@ =
+        [ [ eql? ] 2all? ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
+
+M: object (eql?) = ;
+
+M: id equal?
+    over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
+
+SYMBOL: objects
+
+: (objects) <id> objects get ; inline
+
+: lookup-object ( obj -- n/f ) (objects) at ;
+
+: put-object ( n obj -- ) (objects) set-at ;
+
+: cache-object ( obj quot -- value )
+    >r (objects) r> [ obj>> ] prepose cache ; inline
+
 ! Constants
 
 : image-magic HEX: 0f0e0d0c ; inline
@@ -48,22 +85,12 @@ IN: bootstrap.image
 : 1-offset              8 ; inline
 : -1-offset             9 ; inline
 
-: array-start 2 bootstrap-cells object tag-number - ;
-: scan@ array-start bootstrap-cell - ;
-: wrapper@ bootstrap-cell object tag-number - ;
-: word-xt@ 8 bootstrap-cells object tag-number - ;
-: quot-array@ bootstrap-cell object tag-number - ;
-: quot-xt@ 3 bootstrap-cells object tag-number - ;
-
 : jit-define ( quot rc rt offset name -- )
     >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
 
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
 
-! Object cache
-SYMBOL: objects
-
 ! Image output format
 SYMBOL: big-endian
 
@@ -169,9 +196,9 @@ GENERIC: ' ( obj -- ptr )
 
 ! Bignums
 
-: bignum-bits bootstrap-cell-bits 2 - ;
+: bignum-bits ( -- n ) bootstrap-cell-bits 2 - ;
 
-: bignum-radix bignum-bits 2^ 1- ;
+: bignum-radix ( -- n ) bignum-bits 2^ 1- ;
 
 : bignum>seq ( n -- seq )
     #! n is positive or zero.
@@ -187,7 +214,9 @@ GENERIC: ' ( obj -- ptr )
     2tri ;
 
 M: bignum '
-    bignum tag-number dup [ emit-bignum ] emit-object ;
+    [
+        bignum tag-number dup [ emit-bignum ] emit-object
+    ] cache-object ;
 
 ! Fixnums
 
@@ -202,23 +231,25 @@ M: fixnum '
 ! Floats
 
 M: float '
-    float tag-number dup [
+    [
-        align-here double>bits emit-64
+        float tag-number dup [
-    ] emit-object ;
+            align-here double>bits emit-64
+        ] emit-object
+    ] cache-object ;
 
 ! Special objects
 
 ! Padded with fixnums for 8-byte alignment
 
-: t, t t-offset fixup ;
+: t, ( -- ) t t-offset fixup ;
 
 M: f '
     #! f is #define F RETAG(0,F_TYPE)
     drop \ f tag-number ;
 
-:  0,  0 >bignum '  0-offset fixup ;
+:  0, ( -- )  0 >bignum '  0-offset fixup ;
-:  1,  1 >bignum '  1-offset fixup ;
+:  1, ( -- )  1 >bignum '  1-offset fixup ;
-: -1, -1 >bignum ' -1-offset fixup ;
+: -1, ( -- ) -1 >bignum ' -1-offset fixup ;
 
 ! Words
 
@@ -243,7 +274,7 @@ M: f '
         ] bi
         \ word type-number object tag-number
         [ emit-seq ] emit-object
-    ] keep objects get set-at ;
+    ] keep put-object ;
 
 : word-error ( word msg -- * )
     [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
@@ -252,7 +283,7 @@ M: f '
     [ target-word ] keep or ;
 
 : fixup-word ( word -- offset )
-    transfer-word dup objects get at
+    transfer-word dup lookup-object
     [ ] [ "Not in image: " word-error ] ?if ;
 
 : fixup-words ( -- )
@@ -267,12 +298,12 @@ M: wrapper '
     [ emit ] emit-object ;
 
 ! Strings
-: emit-chars ( seq -- )
+: emit-bytes ( seq -- )
     bootstrap-cell <groups>
     big-endian get [ [ be> ] map ] [ [ le> ] map ] if
     emit-seq ;
 
-: pack-string ( string -- newstr )
+: pad-bytes ( seq -- newseq )
     dup length bootstrap-cell align 0 pad-right ;
 
 : emit-string ( string -- ptr )
@@ -280,13 +311,13 @@ M: wrapper '
         dup length emit-fixnum
         f ' emit
         f ' emit
-        pack-string emit-chars
+        pad-bytes emit-bytes
     ] emit-object ;
 
 M: string '
     #! We pool strings so that each string is only written once
     #! to the image
-    objects get [ emit-string ] cache ;
+    [ emit-string ] cache-object ;
 
 : assert-empty ( seq -- )
     length 0 assert= ;
@@ -297,7 +328,11 @@ M: string '
         [ 0 emit-fixnum ] emit-object
     ] bi* ;
 
-M: byte-array ' byte-array emit-dummy-array ;
+M: byte-array '
+    byte-array type-number object tag-number [
+        dup length emit-fixnum
+        pad-bytes emit-bytes
+    ] emit-object ;
 
 M: bit-array ' bit-array emit-dummy-array ;
 
@@ -305,18 +340,18 @@ M: float-array ' float-array emit-dummy-array ;
 
 ! Tuples
 : (emit-tuple) ( tuple -- pointer )
-    [ tuple>array 1 tail-slice ]
+    [ tuple>array rest-slice ]
     [ class transfer-word tuple-layout ] bi prefix [ ' ] map
     tuple type-number dup [ emit-seq ] emit-object ;
 
 : emit-tuple ( tuple -- pointer )
     dup class word-name "tombstone" =
-    [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
+    [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
 
 M: tuple ' emit-tuple ;
 
 M: tuple-layout '
-    objects get [
+    [
         [
             {
                 [ layout-hashcode , ]
@@ -328,12 +363,12 @@ M: tuple-layout '
         ] { } make [ ' ] map
         \ tuple-layout type-number
         object tag-number [ emit-seq ] emit-object
-    ] cache ;
+    ] cache-object ;
 
 M: tombstone '
     delegate
     "((tombstone))" "((empty))" ? "hashtables.private" lookup
-    word-def first objects get [ emit-tuple ] cache ;
+    word-def first [ emit-tuple ] cache-object ;
 
 ! Arrays
 M: array '
@@ -343,7 +378,7 @@ M: array '
 ! Quotations
 
 M: quotation '
-    objects get [
+    [
         quotation-array '
         quotation type-number object tag-number [
             emit ! array
@@ -351,7 +386,7 @@ M: quotation '
             0 emit ! xt
             0 emit ! code
         ] emit-object
-    ] cache ;
+    ] cache-object ;
 
 ! End of the image
 
@@ -362,8 +397,8 @@ M: quotation '
     [
         {
             dictionary source-files builtins
-            update-map class<-cache class-not-cache
+            update-map class<=-cache
-            classes-intersect-cache class-and-cache
+            class-not-cache classes-intersect-cache class-and-cache
             class-or-cache
         } [ dup get swap bootstrap-word set ] each
     ] H{ } make-assoc
@@ -433,15 +468,13 @@ M: quotation '
     "Writing image to " write
     architecture get boot-image-name resource-path
     [ write "..." print flush ]
-    [ binary <file-writer> [ (write-image) ] with-stream ] bi ;
+    [ binary [ (write-image) ] with-file-writer ] bi ;
 
 PRIVATE>
 
 : make-image ( arch -- )
     [
         architecture set
-        bootstrapping? on
-        load-help? off
         "resource:/core/bootstrap/stage1.factor" run-file
         build-image
         write-image

core/bootstrap/primitives.factor

@@ -5,8 +5,9 @@ hashtables.private io kernel math namespaces parser sequences
 strings vectors words quotations assocs layouts classes
 classes.builtin classes.tuple classes.tuple.private
 kernel.private vocabs vocabs.loader source-files definitions
-slots.deprecated classes.union compiler.units
+slots.deprecated classes.union classes.intersection
-bootstrap.image.private io.files accessors combinators ;
+compiler.units bootstrap.image.private io.files accessors
+combinators ;
 IN: bootstrap.primitives
 
 "Creating primitives and basic runtime structures..." print flush
@@ -30,6 +31,7 @@ crossref off
 ! Bring up a bare cross-compiling vocabulary.
 "syntax" vocab vocab-words bootstrap-syntax set
 H{ } clone dictionary set
+H{ } clone new-classes set
 H{ } clone changed-definitions set
 H{ } clone forgotten-definitions set
 H{ } clone root-cache set
@@ -51,6 +53,8 @@ call
 ! After we execute bootstrap/layouts
 num-types get f <array> builtins set
 
+bootstrapping? on
+
 ! Create some empty vocabs where the below primitives and
 ! classes will go
 {
@@ -59,6 +63,7 @@ num-types get f <array> builtins set
     "arrays"
     "bit-arrays"
     "byte-arrays"
+    "byte-vectors"
     "classes.private"
     "classes.tuple"
     "classes.tuple.private"
@@ -124,7 +129,7 @@ num-types get f <array> builtins set
 : register-builtin ( class -- )
     [ dup lookup-type-number "type" set-word-prop ]
     [ dup "type" word-prop builtins get set-nth ]
-    [ f f builtin-class define-class ]
+    [ f f f builtin-class define-class ]
     tri ;
 
 : define-builtin-slots ( symbol slotspec -- )
@@ -157,7 +162,7 @@ num-types get f <array> builtins set
 
 ! Catch-all class for providing a default method.
 "object" "kernel" create
-[ f builtins get [ ] subset union-class define-class ]
+[ f f { } intersection-class define-class ]
 [ [ drop t ] "predicate" set-word-prop ]
 bi
 
@@ -169,7 +174,7 @@ builtins get num-tags get tail define-union-class
 
 ! Empty class with no instances
 "null" "kernel" create
-[ f { } union-class define-class ]
+[ f { } f union-class define-class ]
 [ [ drop f ] "predicate" set-word-prop ]
 bi
 
@@ -452,6 +457,22 @@ tuple
     }
 } define-tuple-class
 
+"byte-vector" "byte-vectors" create
+tuple
+{
+    {
+        { "byte-array" "byte-arrays" }
+        "underlying"
+        { "underlying" "growable" }
+        { "set-underlying" "growable" }
+    } {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
+    }
+} define-tuple-class
+
 "curry" "kernel" create
 tuple
 {
@@ -590,7 +611,7 @@ tuple
     { "(exists?)" "io.files.private" }
     { "(directory)" "io.files.private" }
     { "gc" "memory" }
-    { "gc-time" "memory" }
+    { "gc-stats" "memory" }
     { "save-image" "memory" }
     { "save-image-and-exit" "memory" }
     { "datastack" "kernel" }
@@ -685,6 +706,7 @@ tuple
     { "resize-float-array" "float-arrays" }
     { "dll-valid?" "alien" }
     { "unimplemented" "kernel.private" }
+    { "gc-reset" "memory" }
 }
 dup length [ >r first2 r> make-primitive ] 2each
 

core/bootstrap/stage1.factor

@@ -13,6 +13,8 @@ vocabs.loader system debugger continuations ;
 
 "resource:core/bootstrap/primitives.factor" run-file
 
+load-help? off
+
 ! Create a boot quotation for the target
 [
     [

core/bootstrap/stage2.factor

@@ -22,13 +22,13 @@ SYMBOL: bootstrap-time
     xref-sources ;
 
 : load-components ( -- )
-    "exclude" "include"
+    "include" "exclude"
-    [ get-global " " split [ empty? not ] subset ] bi@
+    [ get-global " " split harvest ] bi@
     diff
     [ "bootstrap." prepend require ] each ;
 
 : count-words ( pred -- )
-    all-words swap subset length number>string write ;
+    all-words swap filter length number>string write ;
 
 : print-report ( time -- )
     1000 /i
@@ -44,10 +44,6 @@ SYMBOL: bootstrap-time
     "Now, you can run Factor:" print
     vm write " -i=" write "output-image" get print flush ;
 
-! Wrap everything in a catch which starts a listener so
-! you can see what went wrong, instead of dealing with a
-! fep
-
 ! We time bootstrap
 millis >r
 
@@ -91,7 +87,7 @@ f error-continuation set-global
             parse-command-line
             run-user-init
             "run" get run
-            stdio get [ stream-flush ] when*
+            output-stream get [ stream-flush ] when*
         ] [ print-error 1 exit ] recover
     ] set-boot-quot
 

core/bootstrap/syntax.factor

@@ -10,12 +10,14 @@ IN: bootstrap.syntax
     "\""
     "#!"
     "("
+    "(("
     ":"
     ";"
     "<PRIVATE"
     "?{"
     "BIN:"
     "B{"
+    "BV{"
     "C:"
     "CHAR:"
     "DEFER:"
@@ -45,6 +47,7 @@ IN: bootstrap.syntax
     "TUPLE:"
     "T{"
     "UNION:"
+    "INTERSECTION:"
     "USE:"
     "USING:"
     "V{"

core/boxes/boxes-docs.factor

@@ -2,7 +2,7 @@ USING: help.markup help.syntax kernel ;
 IN: boxes
 
 HELP: box
-{ $class-description "A data type holding a single value in the " { $link box-value } " slot. The " { $link box-full? } " slot indicates if the value is set." } ;
+{ $class-description "A data type holding a single value in the " { $snippet "value" } " slot. The " { $snippet "occupied" } " slot indicates if the value is set." } ;
 
 HELP: <box>
 { $values { "box" box } }
@@ -27,12 +27,11 @@ ARTICLE: "boxes" "Boxes"
 { $subsection box }
 "Creating an empty box:"
 { $subsection <box> }
-"Testing if a box is full:"
-{ $subsection box-full? }
 "Storing a value and removing a value from a box:"
 { $subsection >box }
 { $subsection box> }
 "Safely removing a value:"
-{ $subsection ?box } ;
+{ $subsection ?box }
+"Testing if a box is full can be done by reading the " { $snippet "occupied" } " slot." ;
 
 ABOUT: "boxes"

core/boxes/boxes-tests.factor

@@ -1,17 +1,17 @@
 IN: boxes.tests
-USING: boxes namespaces tools.test ;
+USING: boxes namespaces tools.test accessors ;
 
 [ ] [ <box> "b" set ] unit-test
 
 [ ] [ 3 "b" get >box ] unit-test
 
-[ t ] [ "b" get box-full? ] unit-test
+[ t ] [ "b" get occupied>> ] unit-test
 
 [ 4 "b" >box ] must-fail
 
 [ 3 ] [ "b" get box> ] unit-test
 
-[ f ] [ "b" get box-full? ] unit-test
+[ f ] [ "b" get occupied>> ] unit-test
 
 [ "b" get box> ] must-fail
 
@@ -21,4 +21,4 @@ USING: boxes namespaces tools.test ;
 
 [ 12 t ] [ "b" get ?box ] unit-test
 
-[ f ] [ "b" get box-full? ] unit-test
+[ f ] [ "b" get occupied>> ] unit-test

core/boxes/boxes.factor

@@ -1,24 +1,26 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ;
+USING: kernel accessors ;
 IN: boxes
 
-TUPLE: box value full? ;
+TUPLE: box value occupied ;
 
 : <box> ( -- box ) box new ;
 
+ERROR: box-full box ;
+
 : >box ( value box -- )
-    dup box-full? [ "Box already has a value" throw ] when
+    dup occupied>>
-    t over set-box-full?
+    [ box-full ] [ t >>occupied (>>value) ] if ;
-    set-box-value ;
+
+ERROR: box-empty box ;
 
 : box> ( box -- value )
-    dup box-full? [ "Box empty" throw ] unless
+    dup occupied>>
-    dup box-value f pick set-box-value
+    [ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;
-    f rot set-box-full? ;
 
 : ?box ( box -- value/f ? )
-    dup box-full? [ box> t ] [ drop f f ] if ;
+    dup occupied>> [ box> t ] [ drop f f ] if ;
 
 : if-box? ( box quot -- )
     >r ?box r> [ drop ] if ; inline

core/byte-arrays/byte-arrays-docs.factor

@@ -26,5 +26,6 @@ HELP: <byte-array> ( n -- byte-array )
 
 HELP: >byte-array
 { $values { "seq" "a sequence" } { "byte-array" byte-array } }
-{ $description "Outputs a freshly-allocated byte array whose elements have the same boolean values as a given sequence." }
+{ $description
+  "Outputs a freshly-allocated byte array whose elements have the same signed byte values as a given sequence." }
 { $errors "Throws an error if the sequence contains elements other than integers." } ;

core/byte-vectors/byte-vectors.factor

@@ -1,20 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
-sequences.private growable byte-arrays prettyprint.backend
+sequences.private growable byte-arrays ;
-parser accessors ;
 IN: byte-vectors
 
-TUPLE: byte-vector underlying fill ;
-
-M: byte-vector underlying underlying>> { byte-array } declare ;
-
-M: byte-vector set-underlying (>>underlying) ;
-
-M: byte-vector length fill>> { array-capacity } declare ;
-
-M: byte-vector set-fill (>>fill) ;
-
 <PRIVATE
 
 : byte-array>vector ( byte-array length -- byte-vector )
@@ -43,9 +32,3 @@ M: byte-vector equal?
 M: byte-array new-resizable drop <byte-vector> ;
 
 INSTANCE: byte-vector growable
-
-: BV{ \ } [ >byte-vector ] parse-literal ; parsing
-
-M: byte-vector >pprint-sequence ;
-
-M: byte-vector pprint-delims drop \ BV{ \ } ;

core/checksums/checksums-docs.factor

@@ -0,0 +1,55 @@
+USING: help.markup help.syntax kernel math sequences quotations
+math.private byte-arrays strings ;
+IN: checksums
+
+HELP: checksum
+{ $class-description "The class of checksum algorithms." } ;
+
+HELP: hex-string
+{ $values { "seq" "a sequence" } { "str" "a string" } }
+{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
+{ $examples
+    { $example "USING: checksums io ;" "B{ 1 2 3 4 } hex-string print" "01020304" }
+}
+{ $notes "Numbers are zero-padded on the left." } ;
+
+HELP: checksum-stream
+{ $values { "stream" "an input stream" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data read from the stream." }
+{ $side-effects "stream" } ;
+
+HELP: checksum-bytes
+{ $values { "bytes" "a sequence of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a sequence." } ;
+
+HELP: checksum-lines
+{ $values { "lines" "a sequence of sequences of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a sequence." } ;
+
+HELP: checksum-file
+{ $values { "path" "a pathname specifier" } { "checksum" "a checksum specifier" } { "value" byte-array } }
+{ $contract "Computes the checksum of all data in a file." } ;
+
+ARTICLE: "checksums" "Checksums"
+"A " { $emphasis "checksum" } " is a function mapping sequences of bytes to fixed-length strings. While checksums are not one-to-one, a good checksum should have a low probability of collision. Additionally, some checksum algorithms are designed to be hard to reverse, in the sense that finding an input string which hashes to a given checksum string requires a brute-force search."
+$nl
+"Checksums are instances of a class:"
+{ $subsection checksum }
+"Operations on checksums:"
+{ $subsection checksum-bytes }
+{ $subsection checksum-stream }
+{ $subsection checksum-lines }
+"Checksums should implement at least one of " { $link checksum-bytes } " and " { $link checksum-stream } ". Implementing " { $link checksum-lines } " is optional."
+$nl
+"Utilities:"
+{ $subsection checksum-file }
+{ $subsection hex-string }
+"Checksum implementations:"
+{ $subsection "checksums.crc32" }
+{ $vocab-subsection "MD5 checksum" "checksums.md5" }
+{ $vocab-subsection "SHA1 checksum" "checksums.sha1" }
+{ $vocab-subsection "SHA2 checksum" "checksums.sha2" }
+{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" }
+{ $vocab-subsection "OpenSSL checksums" "checksums.openssl" } ;
+
+ABOUT: "checksums"

core/checksums/checksums-tests.factor

@@ -0,0 +1,7 @@
+IN: checksums.tests
+USING: checksums tools.test ;
+
+\ checksum-bytes must-infer
+\ checksum-stream must-infer
+\ checksum-lines must-infer
+\ checksum-file must-infer

core/checksums/checksums.factor

@@ -0,0 +1,25 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences math.parser io io.streams.byte-array
+io.encodings.binary io.files kernel ;
+IN: checksums
+
+MIXIN: checksum
+
+GENERIC: checksum-bytes ( bytes checksum -- value )
+
+GENERIC: checksum-stream ( stream checksum -- value )
+
+GENERIC: checksum-lines ( lines checksum -- value )
+
+M: checksum checksum-bytes >r binary <byte-reader> r> checksum-stream ;
+
+M: checksum checksum-stream >r contents r> checksum-bytes ;
+
+M: checksum checksum-lines >r B{ CHAR: \n } join r> checksum-bytes ;
+
+: checksum-file ( path checksum -- value )
+    >r binary <file-reader> r> checksum-stream ;
+
+: hex-string ( seq -- str )
+    [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;

core/checksums/crc32/crc32-docs.factor

@@ -0,0 +1,11 @@
+USING: help.markup help.syntax math ;
+IN: checksums.crc32
+
+HELP: crc32
+{ $class-description "The CRC32 checksum algorithm." } ;
+
+ARTICLE: "checksums.crc32" "CRC32 checksum"
+"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
+{ $subsection crc32 } ;
+
+ABOUT: "checksums.crc32"

core/checksums/crc32/crc32-tests.factor

@@ -0,0 +1,6 @@
+USING: checksums checksums.crc32 kernel math tools.test namespaces ;
+
+[ B{ 0 0 0 0 } ] [ "" crc32 checksum-bytes ] unit-test
+
+[ B{ HEX: cb HEX: f4 HEX: 39 HEX: 26 } ] [ "123456789" crc32 checksum-bytes ] unit-test
+

core/checksums/crc32/crc32.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math sequences sequences.private namespaces
 words io io.binary io.files io.streams.string quotations
-definitions ;
+definitions checksums ;
-IN: io.crc32
+IN: checksums.crc32
 
 : crc32-polynomial HEX: edb88320 ; inline
 
@@ -20,10 +20,20 @@ IN: io.crc32
     mask-byte crc32-table nth-unsafe >bignum
     swap -8 shift bitxor ; inline
 
-: crc32 ( seq -- n )
+SINGLETON: crc32
-    >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
 
-: lines-crc32 ( seq -- n )
+INSTANCE: crc32 checksum
-    HEX: ffffffff tuck [
+
-        [ (crc32) ] each CHAR: \n (crc32)
+: init-crc32 drop >r HEX: ffffffff dup r> ; inline
-    ] reduce bitxor ;
+
+: finish-crc32 bitxor 4 >be ; inline
+
+M: crc32 checksum-bytes
+    init-crc32
+    [ (crc32) ] each
+    finish-crc32 ;
+
+M: crc32 checksum-lines
+    init-crc32
+    [ [ (crc32) ] each CHAR: \n (crc32) ] each
+    finish-crc32 ;

core/classes/algebra/algebra-docs.factor

@@ -1,14 +1,14 @@
-USING: help.markup help.syntax kernel classes ;
+USING: help.markup help.syntax kernel classes words
+checksums checksums.crc32 sequences math ;
 IN: classes.algebra
 
 ARTICLE: "class-operations" "Class operations"
 "Set-theoretic operations on classes:"
 { $subsection class< }
+{ $subsection class<= }
 { $subsection class-and }
 { $subsection class-or }
 { $subsection classes-intersect? }
-"Topological sort:"
-{ $subsection sort-classes }
 { $subsection min-class }
 "Low-level implementation detail:"
 { $subsection class-types }
@@ -17,6 +17,29 @@ ARTICLE: "class-operations" "Class operations"
 { $subsection class-types }
 { $subsection class-tags } ;
 
+ARTICLE: "class-linearization" "Class linearization"
+"Classes have an intrinsic partial order; given two classes A and B, we either have that A is a subset of B, B is a subset of A, A and B are equal as sets, or they are incomparable. The last two situations present difficulties for method dispatch:"
+{ $list
+    "If a generic word defines a method on a mixin class A and another class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both."
+    { "If a generic word defines methods on two union classes which are incomparable but not disjoint, for example " { $link sequence } " and " { $link number } ", there is an ambiguity because the generic word may be called on an object that is an instance of both unions." }
+}
+"The first ambiguity is resolved with a tie-breaker that compares metaclasses. The intrinsic meta-class order, from most-specific to least-specific:"
+{ $list
+    "Built-in classes and tuple classes"
+    "Predicate classes"
+    "Union classes"
+    "Mixin classes"
+}
+"This means that in the above example, the generic word with methods on a mixin and its sole instance will always call the method for the sole instance, since it is more specific than a mixin class."
+$nl
+"The second problem is resolved with another tie-breaker. When performing the topological sort of classes, if there are multiple candidates at any given step of the sort, lexicographical order on the class name is used."
+$nl
+"Operations:"
+{ $subsection class< }
+{ $subsection sort-classes }
+"Metaclass order:"
+{ $subsection rank-class } ;
+
 HELP: flatten-builtin-class
 { $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
 { $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
@@ -29,14 +52,14 @@ HELP: class-types
 { $values { "class" class } { "seq" "an increasing sequence of integers" } }
 { $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
 
-HELP: class<
+HELP: class<=
 { $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }
 { $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
 { $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
 
 HELP: sort-classes
 { $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
-{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
+{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ;
 
 HELP: class-or
 { $values { "first" class } { "second" class } { "class" class } }

core/classes/algebra/algebra-tests.factor

@@ -1,16 +1,22 @@
-IN: classes.algebra.tests
 USING: alien arrays definitions generic assocs hashtables io
 kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes classes.algebra
 classes.private classes.union classes.mixin classes.predicate
 vectors definitions source-files compiler.units growable
-random inference effects kernel.private sbufs ;
+random inference effects kernel.private sbufs math.order ;
+IN: classes.algebra.tests
 
-: class= [ class< ] 2keep swap class< and ;
+\ class< must-infer
+\ class-and must-infer
+\ class-or must-infer
+\ flatten-class must-infer
+\ flatten-builtin-class must-infer
 
-: class-and* >r class-and r> class= ;
+: class= ( cls1 cls2 -- ? ) [ class<= ] [ swap class<= ] 2bi and ;
 
-: class-or* >r class-or r> class= ;
+: class-and* ( cls1 cls2 cls3 -- ? ) >r class-and r> class= ;
+
+: class-or* ( cls1 cls2 cls3 -- ? ) >r class-or r> class= ;
 
 [ t ] [ object  object  object class-and* ] unit-test
 [ t ] [ fixnum  object  fixnum class-and* ] unit-test
@@ -38,43 +44,43 @@ UNION: both first-one union-class ;
 
 [ f ] [ number vector class-and sequence classes-intersect? ] unit-test
 
-[ t ] [ \ fixnum \ integer class< ] unit-test
+[ t ] [ \ fixnum \ integer class<= ] unit-test
-[ t ] [ \ fixnum \ fixnum class< ] unit-test
+[ t ] [ \ fixnum \ fixnum class<= ] unit-test
-[ f ] [ \ integer \ fixnum class< ] unit-test
+[ f ] [ \ integer \ fixnum class<= ] unit-test
-[ t ] [ \ integer \ object class< ] unit-test
+[ t ] [ \ integer \ object class<= ] unit-test
-[ f ] [ \ integer \ null class< ] unit-test
+[ f ] [ \ integer \ null class<= ] unit-test
-[ t ] [ \ null \ object class< ] unit-test
+[ t ] [ \ null \ object class<= ] unit-test
 
-[ t ] [ \ generic \ word class< ] unit-test
+[ t ] [ \ generic \ word class<= ] unit-test
-[ f ] [ \ word \ generic class< ] unit-test
+[ f ] [ \ word \ generic class<= ] unit-test
 
-[ f ] [ \ reversed \ slice class< ] unit-test
+[ f ] [ \ reversed \ slice class<= ] unit-test
-[ f ] [ \ slice \ reversed class< ] unit-test
+[ f ] [ \ slice \ reversed class<= ] unit-test
 
 PREDICATE: no-docs < word "documentation" word-prop not ;
 
 UNION: no-docs-union no-docs integer ;
 
-[ t ] [ no-docs no-docs-union class< ] unit-test
+[ t ] [ no-docs no-docs-union class<= ] unit-test
-[ f ] [ no-docs-union no-docs class< ] unit-test
+[ f ] [ no-docs-union no-docs class<= ] unit-test
 
 TUPLE: a ;
 TUPLE: b ;
 UNION: c a b ;
 
-[ t ] [ \ c \ tuple class< ] unit-test
+[ t ] [ \ c \ tuple class<= ] unit-test
-[ f ] [ \ tuple \ c class< ] unit-test
+[ f ] [ \ tuple \ c class<= ] unit-test
 
-[ t ] [ \ tuple-class \ class class< ] unit-test
+[ t ] [ \ tuple-class \ class class<= ] unit-test
-[ f ] [ \ class \ tuple-class class< ] unit-test
+[ f ] [ \ class \ tuple-class class<= ] unit-test
 
 TUPLE: tuple-example ;
 
-[ t ] [ \ null \ tuple-example class< ] unit-test
+[ t ] [ \ null \ tuple-example class<= ] unit-test
-[ f ] [ \ object \ tuple-example class< ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
-[ f ] [ \ object \ tuple-example class< ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
-[ t ] [ \ tuple-example \ tuple class< ] unit-test
+[ t ] [ \ tuple-example \ tuple class<= ] unit-test
-[ f ] [ \ tuple \ tuple-example class< ] unit-test
+[ f ] [ \ tuple \ tuple-example class<= ] unit-test
 
 TUPLE: a1 ;
 TUPLE: b1 ;
@@ -84,57 +90,57 @@ UNION: x1 a1 b1 ;
 UNION: y1 a1 c1 ;
 UNION: z1 b1 c1 ;
 
-[ f ] [ z1 x1 y1 class-and class< ] unit-test
+[ f ] [ z1 x1 y1 class-and class<= ] unit-test
 
-[ t ] [ x1 y1 class-and a1 class< ] unit-test
+[ t ] [ x1 y1 class-and a1 class<= ] unit-test
 
 [ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
 
-[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class< ] unit-test
+[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test
 
-[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class< ] unit-test
+[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
 
 [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
 
 [ f ] [ growable \ hi-tag classes-intersect? ] unit-test
 
 [ t ] [
-    growable tuple sequence class-and class<
+    growable tuple sequence class-and class<=
 ] unit-test
 
 [ t ] [
-    growable assoc class-and tuple class<
+    growable assoc class-and tuple class<=
 ] unit-test
 
-[ t ] [ object \ f \ f class-not class-or class< ] unit-test
+[ t ] [ object \ f \ f class-not class-or class<= ] unit-test
 
 [ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
 
 [ f ] [ integer integer class-not classes-intersect? ] unit-test
 
-[ t ] [ array number class-not class< ] unit-test
+[ t ] [ array number class-not class<= ] unit-test
 
-[ f ] [ bignum number class-not class< ] unit-test
+[ f ] [ bignum number class-not class<= ] unit-test
 
 [ vector ] [ vector class-not class-not ] unit-test
 
-[ t ] [ fixnum fixnum bignum class-or class< ] unit-test
+[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test
 
-[ f ] [ fixnum class-not integer class-and array class< ] unit-test
+[ f ] [ fixnum class-not integer class-and array class<= ] unit-test
 
-[ f ] [ fixnum class-not integer class< ] unit-test
+[ f ] [ fixnum class-not integer class<= ] unit-test
 
-[ f ] [ number class-not array class< ] unit-test
+[ f ] [ number class-not array class<= ] unit-test
 
-[ f ] [ fixnum class-not array class< ] unit-test
+[ f ] [ fixnum class-not array class<= ] unit-test
 
-[ t ] [ number class-not integer class-not class< ] unit-test
+[ t ] [ number class-not integer class-not class<= ] unit-test
 
 [ t ] [ vector array class-not class-and vector class= ] unit-test
 
 [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
 
-[ f ] [ fixnum class-not integer class< ] unit-test
+[ f ] [ fixnum class-not integer class<= ] unit-test
 
 [ t ] [ null class-not object class= ] unit-test
 
@@ -147,7 +153,7 @@ UNION: z1 b1 c1 ;
 [ t ] [
     fixnum class-not
     fixnum fixnum class-not class-or
-    class<
+    class<=
 ] unit-test
 
 ! Test method inlining
@@ -187,9 +193,9 @@ UNION: z1 b1 c1 ;
 [ f ] [ null { number fixnum null } min-class ] unit-test
 
 ! Test for hangs?
-: random-class classes random ;
+: random-class ( -- class ) classes random ;
 
-: random-op
+: random-op ( -- word )
     {
         class-and
         class-or
@@ -205,13 +211,13 @@ UNION: z1 b1 c1 ;
     ] unit-test
 ] times
 
-: random-boolean
+: random-boolean ( -- ? )
     { t f } random ;
 
-: boolean>class
+: boolean>class ( ? -- class )
     object null ? ;
 
-: random-boolean-op
+: random-boolean-op ( -- word )
     {
         and
         or
@@ -219,9 +225,10 @@ UNION: z1 b1 c1 ;
         xor
     } random ;
 
-: class-xor [ class-or ] 2keep class-and class-not class-and ;
+: class-xor ( cls1 cls2 -- cls3 )
+    [ class-or ] 2keep class-and class-not class-and ;
 
-: boolean-op>class-op
+: boolean-op>class-op ( word -- word' )
     {
         { and class-and }
         { or class-or }
@@ -241,3 +248,58 @@ UNION: z1 b1 c1 ;
         =
     ] unit-test
 ] times
+
+SINGLETON: xxx
+UNION: yyy xxx ;
+
+[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test
+[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test
+
+[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test
+[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test
+
+TUPLE: xa ;
+TUPLE: xb ;
+TUPLE: xc < xa ;
+TUPLE: xd < xb ;
+TUPLE: xe ;
+TUPLE: xf < xb ;
+TUPLE: xg < xb ;
+TUPLE: xh < xb ;
+
+[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
+
+INTERSECTION: generic-class generic class ;
+
+[ t ] [ generic-class generic class<= ] unit-test
+[ t ] [ generic-class \ class class<= ] unit-test
+
+! Later
+[
+    [ t ] [ \ class generic class-and generic-class class<= ] unit-test
+    [ t ] [ \ class generic class-and generic-class swap class<= ] unit-test
+] drop
+
+[ t ] [ \ word generic-class classes-intersect? ] unit-test
+[ f ] [ number generic-class classes-intersect? ] unit-test
+
+[ H{ { word word } } ] [ 
+    generic-class flatten-class
+] unit-test
+
+INTERSECTION: empty-intersection ;
+
+[ t ] [ object empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection object class<= ] unit-test
+[ t ] [ \ f class-not empty-intersection class<= ] unit-test
+[ f ] [ empty-intersection \ f class-not class<= ] unit-test
+[ t ] [ \ number empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection class-not null class<= ] unit-test
+[ t ] [ null empty-intersection class-not class<= ] unit-test
+
+[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
+
+[ t ] [ object \ f class-not \ f class-or class<= ] unit-test
+
+[ ] [ object flatten-builtin-class drop ] unit-test

core/classes/algebra/algebra.factor

@@ -2,16 +2,16 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel classes classes.builtin combinators accessors
 sequences arrays vectors assocs namespaces words sorting layouts
-math hashtables kernel.private sets ;
+math hashtables kernel.private sets math.order ;
 IN: classes.algebra
 
 : 2cache ( key1 key2 assoc quot -- value )
     >r >r 2array r> [ first2 ] r> compose cache ; inline
 
-DEFER: (class<)
+DEFER: (class<=)
 
-: class< ( first second -- ? )
+: class<= ( first second -- ? )
-    class<-cache get [ (class<) ] 2cache ;
+    class<=-cache get [ (class<=) ] 2cache ;
 
 DEFER: (class-not)
 
@@ -37,7 +37,7 @@ TUPLE: anonymous-union members ;
 
 C: <anonymous-union> anonymous-union
 
-TUPLE: anonymous-intersection members ;
+TUPLE: anonymous-intersection participants ;
 
 C: <anonymous-intersection> anonymous-intersection
 
@@ -45,65 +45,91 @@ TUPLE: anonymous-complement class ;
 
 C: <anonymous-complement> anonymous-complement
 
-: superclass< ( first second -- ? )
+: superclass<= ( first second -- ? )
-    >r superclass r> class< ;
+    >r superclass r> class<= ;
 
-: left-union-class< ( first second -- ? )
+: left-anonymous-union<= ( first second -- ? )
-    >r members r> [ class< ] curry all? ;
+    >r members>> r> [ class<= ] curry all? ;
 
-: right-union-class< ( first second -- ? )
+: right-anonymous-union<= ( first second -- ? )
-    members [ class< ] with contains? ;
+    members>> [ class<= ] with contains? ;
 
-: left-anonymous-union< ( first second -- ? )
+: left-anonymous-intersection<= ( first second -- ? )
-    >r members>> r> [ class< ] curry all? ;
+    >r participants>> r> [ class<= ] curry contains? ;
 
-: right-anonymous-union< ( first second -- ? )
+: right-anonymous-intersection<= ( first second -- ? )
-    members>> [ class< ] with contains? ;
+    participants>> [ class<= ] with all? ;
 
-: left-anonymous-intersection< ( first second -- ? )
+: anonymous-complement<= ( first second -- ? )
-    >r members>> r> [ class< ] curry contains? ;
+    [ class>> ] bi@ swap class<= ;
 
-: right-anonymous-intersection< ( first second -- ? )
+: normalize-class ( class -- class' )
-    members>> [ class< ] with all? ;
-
-: anonymous-complement< ( first second -- ? )
-    [ class>> ] bi@ swap class< ;
-
-: (class<) ( first second -- -1/0/1 )  
     {
-        { [ 2dup eq? ] [ 2drop t ] }
+        { [ dup members ] [ members <anonymous-union> ] }
-        { [ dup object eq? ] [ 2drop t ] }
+        { [ dup participants ] [ participants <anonymous-intersection> ] }
-        { [ over null eq? ] [ 2drop t ] }
+        [ ]
-        { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
-        { [ over anonymous-union? ] [ left-anonymous-union< ] }
-        { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
-        { [ over members ] [ left-union-class< ] }
-        { [ dup anonymous-union? ] [ right-anonymous-union< ] }
-        { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
-        { [ over anonymous-complement? ] [ 2drop f ] }
-        { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
-        { [ dup members ] [ right-union-class< ] }
-        { [ over superclass ] [ superclass< ] }
-        [ 2drop f ]
     } cond ;
 
+: normalize-complement ( class -- class' )
+    class>> normalize-class {
+        { [ dup anonymous-union? ] [
+            members>>
+            [ class-not normalize-class ] map
+            <anonymous-intersection> 
+        ] }
+        { [ dup anonymous-intersection? ] [
+            participants>>
+            [ class-not normalize-class ] map
+            <anonymous-union>
+        ] }
+    } cond ;
+
+: left-anonymous-complement<= ( first second -- ? )
+    >r normalize-complement r> class<= ;
+
+PREDICATE: nontrivial-anonymous-complement < anonymous-complement
+    class>> {
+        [ anonymous-union? ]
+        [ anonymous-intersection? ]
+        [ members ]
+        [ participants ]
+    } cleave or or or ;
+
+PREDICATE: empty-union < anonymous-union members>> empty? ;
+
+PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
+
+: (class<=) ( first second -- -1/0/1 )
+    2dup eq? [ 2drop t ] [
+        [ normalize-class ] bi@ {
+            { [ dup empty-intersection? ] [ 2drop t ] }
+            { [ over empty-union? ] [ 2drop t ] }
+            { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
+            { [ over anonymous-union? ] [ left-anonymous-union<= ] }
+            { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
+            { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
+            { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
+            { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
+            { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
+            { [ over superclass ] [ superclass<= ] }
+            [ 2drop f ]
+        } cond
+    ] if ;
+
 : anonymous-union-intersect? ( first second -- ? )
     members>> [ classes-intersect? ] with contains? ;
 
 : anonymous-intersection-intersect? ( first second -- ? )
-    members>> [ classes-intersect? ] with all? ;
+    participants>> [ classes-intersect? ] with all? ;
 
 : anonymous-complement-intersect? ( first second -- ? )
-    class>> class< not ;
+    class>> class<= not ;
-
-: union-class-intersect? ( first second -- ? )
-    members [ classes-intersect? ] with contains? ;
 
 : tuple-class-intersect? ( first second -- ? )
     {
         { [ over tuple eq? ] [ 2drop t ] }
         { [ over builtin-class? ] [ 2drop f ] }
-        { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }
+        { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
         [ swap classes-intersect? ]
     } cond ;
 
@@ -115,61 +141,57 @@ C: <anonymous-complement> anonymous-complement
     } cond ;
 
 : (classes-intersect?) ( first second -- ? )
-    {
+    normalize-class {
         { [ dup anonymous-union? ] [ anonymous-union-intersect? ] }
         { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }
         { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }
         { [ dup tuple-class? ] [ tuple-class-intersect? ] }
         { [ dup builtin-class? ] [ builtin-class-intersect? ] }
         { [ dup superclass ] [ superclass classes-intersect? ] }
-        { [ dup members ] [ union-class-intersect? ] }
     } cond ;
 
-: left-union-and ( first second -- class )
+: anonymous-union-and ( first second -- class )
-    >r members r> [ class-and ] curry map <anonymous-union> ;
-
-: right-union-and ( first second -- class )
-    members [ class-and ] with map <anonymous-union> ;
-
-: left-anonymous-union-and ( first second -- class )
-    >r members>> r> [ class-and ] curry map <anonymous-union> ;
-
-: right-anonymous-union-and ( first second -- class )
     members>> [ class-and ] with map <anonymous-union> ;
 
-: left-anonymous-intersection-and ( first second -- class )
+: anonymous-intersection-and ( first second -- class )
-    >r members>> r> suffix <anonymous-intersection> ;
+    participants>> swap suffix <anonymous-intersection> ;
-
-: right-anonymous-intersection-and ( first second -- class )
-    members>> swap suffix <anonymous-intersection> ;
 
 : (class-and) ( first second -- class )
     {
-        { [ 2dup class< ] [ drop ] }
+        { [ 2dup class<= ] [ drop ] }
-        { [ 2dup swap class< ] [ nip ] }
+        { [ 2dup swap class<= ] [ nip ] }
         { [ 2dup classes-intersect? not ] [ 2drop null ] }
-        { [ dup members ] [ right-union-and ] }
+        [
-        { [ dup anonymous-union? ] [ right-anonymous-union-and ] }
+            [ normalize-class ] bi@ {
-        { [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] }
+                { [ dup anonymous-union? ] [ anonymous-union-and ] }
-        { [ over members ] [ left-union-and ] }
+                { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
-        { [ over anonymous-union? ] [ left-anonymous-union-and ] }
+                { [ over anonymous-union? ] [ swap anonymous-union-and ] }
-        { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
+                { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
-        [ 2array <anonymous-intersection> ]
+                [ 2array <anonymous-intersection> ]
+            } cond
+        ]
     } cond ;
 
-: left-anonymous-union-or ( first second -- class )
+: anonymous-union-or ( first second -- class )
-    >r members>> r> suffix <anonymous-union> ;
-
-: right-anonymous-union-or ( first second -- class )
     members>> swap suffix <anonymous-union> ;
 
+: ((class-or)) ( first second -- class )
+    [ normalize-class ] bi@ {
+        { [ dup anonymous-union? ] [ anonymous-union-or ] }
+        { [ over anonymous-union? ] [ swap anonymous-union-or ] }
+        [ 2array <anonymous-union> ]
+    } cond ;
+
+: anonymous-complement-or ( first second -- class )
+    2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;
+
 : (class-or) ( first second -- class )
     {
-        { [ 2dup class< ] [ nip ] }
+        { [ 2dup class<= ] [ nip ] }
-        { [ 2dup swap class< ] [ drop ] }
+        { [ 2dup swap class<= ] [ drop ] }
-        { [ dup anonymous-union? ] [ right-anonymous-union-or ] }
+        { [ dup anonymous-complement? ] [ anonymous-complement-or ] }
-        { [ over anonymous-union? ] [ left-anonymous-union-or ] }
+        { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
-        [ 2array <anonymous-union> ]
+        [ ((class-or)) ]
     } cond ;
 
 : (class-not) ( class -- complement )
@@ -180,22 +202,38 @@ C: <anonymous-complement> anonymous-complement
         [ <anonymous-complement> ]
     } cond ;
 
+: class< ( first second -- ? )
+    {
+        { [ 2dup class<= not ] [ 2drop f ] }
+        { [ 2dup swap class<= not ] [ 2drop t ] }
+        [ [ rank-class ] bi@ < ]
+    } cond ;
+
 : largest-class ( seq -- n elt )
-    dup [
+    dup [ [ class< ] with contains? not ] curry find-last
-        [ 2dup class< >r swap class< not r> and ]
+    [ "Topological sort failed" throw ] unless* ;
-        with subset empty?
-    ] curry find [ "Topological sort failed" throw ] unless* ;
 
 : sort-classes ( seq -- newseq )
-    >vector
+    [ [ word-name ] compare ] sort >vector
     [ dup empty? not ]
     [ dup largest-class >r over delete-nth r> ]
     [ ] unfold nip ;
 
 : min-class ( class seq -- class/f )
-    over [ classes-intersect? ] curry subset
+    over [ classes-intersect? ] curry filter
     dup empty? [ 2drop f ] [
-        tuck [ class< ] with all? [ peek ] [ drop f ] if
+        tuck [ class<= ] with all? [ peek ] [ drop f ] if
+    ] if ;
+
+DEFER: (flatten-class)
+DEFER: flatten-builtin-class
+
+: flatten-intersection-class ( class -- )
+    participants [ flatten-builtin-class ] map
+    dup empty? [
+        drop builtins get [ (flatten-class) ] each
+    ] [
+        unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
     ] if ;
 
 : (flatten-class) ( class -- )
@@ -203,6 +241,7 @@ C: <anonymous-complement> anonymous-complement
         { [ dup tuple-class? ] [ dup set ] }
         { [ dup builtin-class? ] [ dup set ] }
         { [ dup members ] [ members [ (flatten-class) ] each ] }
+        { [ dup participants ] [ flatten-intersection-class ] }
         { [ dup superclass ] [ superclass (flatten-class) ] }
         [ drop ]
     } cond ;
@@ -212,7 +251,7 @@ C: <anonymous-complement> anonymous-complement
 
 : flatten-builtin-class ( class -- assoc )
     flatten-class [
-        dup tuple class< [ 2drop tuple tuple ] when
+        dup tuple class<= [ 2drop tuple tuple ] when
     ] assoc-map ;
 
 : class-types ( class -- seq )

core/classes/builtin/builtin.factor

@@ -16,3 +16,5 @@ PREDICATE: builtin-class < class
 M: hi-tag class hi-tag type>class ;
 
 M: object class tag type>class ;
+
+M: builtin-class rank-class drop 0 ;

core/classes/classes-docs.factor

@@ -40,6 +40,7 @@ $nl
 "There are several sorts of classes:"
 { $subsection "builtin-classes" }
 { $subsection "unions" }
+{ $subsection "intersections" }
 { $subsection "mixins" }
 { $subsection "predicates" }
 { $subsection "singletons" }
@@ -47,6 +48,7 @@ $nl
 $nl
 "Classes can be inspected and operated upon:"
 { $subsection "class-operations" }
+{ $subsection "class-linearization" }
 { $see-also "class-index" } ;
 
 ABOUT: "classes"
@@ -55,7 +57,7 @@ HELP: class
 { $values { "object" object } { "class" class } }
 { $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
 { $class-description "The class of all class words." }
-{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
+{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
 
 HELP: classes
 { $values { "seq" "a sequence of class words" } }
@@ -63,7 +65,7 @@ HELP: classes
 
 HELP: tuple-class
 { $class-description "The class of tuple class words." }
-{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
+{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
 
 HELP: update-map
 { $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
@@ -85,7 +87,11 @@ HELP: members
 { $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
 { $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
 
+HELP: participants
+{ $values { "class" class } { "seq" "a sequence of intersection participants, or " { $link f } } }
+{ $description "If " { $snippet "class" } " is an intersection class, outputs a sequence of its participant classes, otherwise outputs " { $link f } "." } ;
+
 HELP: define-class
-{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
+{ $values { "word" word } { "superclass" class } { "members" "a sequence of class words" } { "participants" "a sequence of class words" } { "metaclass" class } }
 { $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link update-map } "." }
 $low-level-note ;

core/classes/classes-tests.factor

@@ -18,14 +18,14 @@ GENERIC: generic-update-test ( x -- y )
 
 M: union-1 generic-update-test drop "union-1" ;
 
-[ f ] [ bignum union-1 class< ] unit-test
+[ f ] [ bignum union-1 class<= ] unit-test
-[ t ] [ union-1 number class< ] unit-test
+[ t ] [ union-1 number class<= ] unit-test
 [ "union-1" ] [ 1.0 generic-update-test ] unit-test
 
 "IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
 
-[ t ] [ bignum union-1 class< ] unit-test
+[ t ] [ bignum union-1 class<= ] unit-test
-[ f ] [ union-1 number class< ] unit-test
+[ f ] [ union-1 number class<= ] unit-test
 [ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
 
 "IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
@@ -52,7 +52,7 @@ M: sequence-mixin collection-size length ;
 
 M: assoc-mixin collection-size assoc-size ;
 
-[ t ] [ array sequence-mixin class< ] unit-test
+[ t ] [ array sequence-mixin class<= ] unit-test
 [ t ] [ { 1 2 3 } sequence-mixin? ] unit-test
 [ 3 ] [ { 1 2 3 } collection-size ] unit-test
 [ f ] [ H{ { 1 2 } { 2 3 } } sequence-mixin? ] unit-test
@@ -67,19 +67,19 @@ MIXIN: mx1
 
 INSTANCE: integer mx1
 
-[ t ] [ integer mx1 class< ] unit-test
+[ t ] [ integer mx1 class<= ] unit-test
-[ t ] [ mx1 integer class< ] unit-test
+[ t ] [ mx1 integer class<= ] unit-test
-[ t ] [ mx1 number class< ] unit-test
+[ t ] [ mx1 number class<= ] unit-test
 
 "IN: classes.tests USE: arrays INSTANCE: array mx1" eval
 
-[ t ] [ array mx1 class< ] unit-test
+[ t ] [ array mx1 class<= ] unit-test
-[ f ] [ mx1 number class< ] unit-test
+[ f ] [ mx1 number class<= ] unit-test
 
 [ \ mx1 forget ] with-compilation-unit
 
 ! Empty unions were causing problems
-GENERIC: empty-union-test
+GENERIC: empty-union-test ( obj -- obj )
 
 UNION: empty-union-1 ;
 
@@ -94,14 +94,14 @@ UNION: redefine-bug-1 fixnum ;
 
 UNION: redefine-bug-2 redefine-bug-1 quotation ;
 
-[ t ] [ fixnum redefine-bug-2 class< ] unit-test
+[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
-[ t ] [ quotation redefine-bug-2 class< ] unit-test
+[ t ] [ quotation redefine-bug-2 class<= ] unit-test
 
 [ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
 
-[ t ] [ bignum redefine-bug-1 class< ] unit-test
+[ t ] [ bignum redefine-bug-1 class<= ] unit-test
-[ f ] [ fixnum redefine-bug-2 class< ] unit-test
+[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
-[ t ] [ bignum redefine-bug-2 class< ] unit-test
+[ t ] [ bignum redefine-bug-2 class<= ] unit-test
 
 USE: io.streams.string
 
@@ -160,3 +160,12 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
 [ t ] [ 3 number instance? ] unit-test
 [ f ] [ 3 null instance? ] unit-test
 [ t ] [ "hi" \ hi-tag instance? ] unit-test
+
+! Regression
+GENERIC: method-forget-test ( obj -- obj )
+TUPLE: method-forget-class ;
+M: method-forget-class method-forget-test ;
+
+[ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
+[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
+[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test

core/classes/classes.factor

@@ -5,21 +5,21 @@ slots.private namespaces sequences strings words vectors math
 quotations combinators sorting effects graphs vocabs ;
 IN: classes
 
-SYMBOL: class<-cache
+SYMBOL: class<=-cache
 SYMBOL: class-not-cache
 SYMBOL: classes-intersect-cache
 SYMBOL: class-and-cache
 SYMBOL: class-or-cache
 
 : init-caches ( -- )
-    H{ } clone class<-cache set
+    H{ } clone class<=-cache set
     H{ } clone class-not-cache set
     H{ } clone classes-intersect-cache set
     H{ } clone class-and-cache set
     H{ } clone class-or-cache set ;
 
 : reset-caches ( -- )
-    class<-cache get clear-assoc
+    class<=-cache get clear-assoc
     class-not-cache get clear-assoc
     classes-intersect-cache get clear-assoc
     class-and-cache get clear-assoc
@@ -33,12 +33,12 @@ PREDICATE: class < word
 PREDICATE: tuple-class < class
     "metaclass" word-prop tuple-class eq? ;
 
-: classes ( -- seq ) all-words [ class? ] subset ;
+: classes ( -- seq ) all-words [ class? ] filter ;
 
 : predicate-word ( word -- predicate )
     [ word-name "?" append ] keep word-vocabulary create ;
 
-: predicate-effect 1 { "?" } <effect> ;
+: predicate-effect T{ effect f 1 { "?" } } ;
 
 PREDICATE: predicate < word "predicating" word-prop >boolean ;
 
@@ -57,36 +57,50 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
     #! Output f for non-classes to work with algebra code
     dup class? [ "members" word-prop ] [ drop f ] if ;
 
+: participants ( class -- seq )
+    #! Output f for non-classes to work with algebra code
+    dup class? [ "participants" word-prop ] [ drop f ] if ;
+
+GENERIC: rank-class ( class -- n )
+
 GENERIC: reset-class ( class -- )
 
 M: word reset-class drop ;
 
-<PRIVATE
-
 ! update-map
 : class-uses ( class -- seq )
-    [ members ] [ superclass ] bi [ suffix ] when* ;
+    [
+        [ members % ]
+        [ participants % ]
+        [ superclass [ , ] when* ]
+        tri
+    ] { } make ;
 
 : class-usages ( class -- assoc )
     [ update-map get at ] closure ;
 
+<PRIVATE
+
 : update-map+ ( class -- )
     dup class-uses update-map get add-vertex ;
 
 : update-map- ( class -- )
     dup class-uses update-map get remove-vertex ;
 
-: make-class-props ( superclass members metaclass -- assoc )
+: make-class-props ( superclass members participants metaclass -- assoc )
     [
-        [ dup [ bootstrap-word ] when "superclass" set ]
+        {
-        [ [ bootstrap-word ] map "members" set ]
+            [ dup [ bootstrap-word ] when "superclass" set ]
-        [ "metaclass" set ]
+            [ [ bootstrap-word ] map "members" set ]
-        tri*
+            [ [ bootstrap-word ] map "participants" set ]
+            [ "metaclass" set ]
+        } spread
     ] H{ } make-assoc ;
 
 : (define-class) ( word props -- )
     >r
     dup reset-class
+    dup class? [ dup new-class ] unless
     dup deferred? [ dup define-symbol ] when
     dup word-props
     r> assoc-union over set-word-props
@@ -102,15 +116,15 @@ GENERIC: update-class ( class -- )
 
 M: class update-class drop ;
 
-GENERIC: update-methods ( assoc -- )
+GENERIC: update-methods ( class assoc -- )
 
 : update-classes ( class -- )
-    class-usages
+    dup class-usages
-    [ [ drop update-class ] assoc-each ]
+    [ nip keys [ update-class ] each ]
     [ update-methods ]
-    bi ;
+    2bi ;
 
-: define-class ( word superclass members metaclass -- )
+: define-class ( word superclass members participants metaclass -- )
     #! If it was already a class, update methods after.
     reset-caches
     make-class-props

core/classes/intersection/intersection-docs.factor

@@ -0,0 +1,28 @@
+USING: generic help.markup help.syntax kernel kernel.private
+namespaces sequences words arrays layouts help effects math
+layouts classes.private classes compiler.units ;
+IN: classes.intersection
+
+ARTICLE: "intersections" "Intersection classes"
+"An object is an instance of a intersection class if it is an instance of all of its participants."
+{ $subsection POSTPONE: INTERSECTION: }
+{ $subsection define-intersection-class }
+"Intersection classes can be introspected:"
+{ $subsection participants }
+"The set of intersection classes is a class:"
+{ $subsection intersection-class }
+{ $subsection intersection-class? }
+"Intersection classes are used to associate a method with objects which are simultaneously instances of multiple different classes, as well as to conveniently define predicates." ;
+
+ABOUT: "intersections"
+
+HELP: define-intersection-class
+{ $values { "class" class } { "participants" "a sequence of classes" } }
+{ $description "Defines a intersection class with specified participants. This is the run time equivalent of " { $link POSTPONE: INTERSECTION: } "." }
+{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
+{ $side-effects "class" } ;
+
+{ intersection-class define-intersection-class POSTPONE: INTERSECTION: } related-words
+
+HELP: intersection-class
+{ $class-description "The class of intersection classes." } ;

core/classes/intersection/intersection.factor

@@ -0,0 +1,33 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words sequences kernel assocs combinators classes
+namespaces arrays math quotations ;
+IN: classes.intersection
+
+PREDICATE: intersection-class < class
+    "metaclass" word-prop intersection-class eq? ;
+
+: intersection-predicate-quot ( members -- quot )
+    dup empty? [
+        drop [ drop t ]
+    ] [
+        unclip "predicate" word-prop swap [
+            "predicate" word-prop [ dup ] swap [ not ] 3append
+            [ drop f ]
+        ] { } map>assoc alist>quot
+    ] if ;
+
+: define-intersection-predicate ( class -- )
+    dup participants intersection-predicate-quot define-predicate ;
+
+M: intersection-class update-class define-intersection-predicate ;
+
+: define-intersection-class ( class participants -- )
+    [ f f rot intersection-class define-class ]
+    [ drop update-classes ]
+    2bi ;
+
+M: intersection-class reset-class
+    { "class" "metaclass" "participants" } reset-props ;
+
+M: intersection-class rank-class drop 2 ;

core/classes/mixin/mixin.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes classes.union words kernel sequences
-definitions combinators arrays accessors ;
+definitions combinators arrays assocs generic accessors ;
 IN: classes.mixin
 
 PREDICATE: mixin-class < union-class "mixin" word-prop ;
@@ -9,9 +9,12 @@ PREDICATE: mixin-class < union-class "mixin" word-prop ;
 M: mixin-class reset-class
     { "class" "metaclass" "members" "mixin" } reset-props ;
 
+M: mixin-class rank-class drop 3 ;
+
 : redefine-mixin-class ( class members -- )
-    dupd define-union-class
+    [ (define-union-class) ]
-    t "mixin" set-word-prop ;
+    [ drop t "mixin" set-word-prop ]
+    2bi ;
 
 : define-mixin-class ( class -- )
     dup mixin-class? [
@@ -28,17 +31,35 @@ TUPLE: check-mixin-class mixin ;
     ] unless ;
 
 : if-mixin-member? ( class mixin true false -- )
-    >r >r check-mixin-class 2dup members memq? r> r> if ; inline
+    [ check-mixin-class 2dup members memq? ] 2dip if ; inline
 
 : change-mixin-class ( class mixin quot -- )
-    [ members swap bootstrap-word ] swap compose keep
+    [ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
     swap redefine-mixin-class ; inline
 
+: update-classes/new ( mixin -- )
+    class-usages
+    [ keys [ update-class ] each ]
+    [ implementors [ make-generic ] each ] bi ;
+
 : add-mixin-instance ( class mixin -- )
-    [ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
+    #! Note: we call update-classes on the new member, not the
+    #! mixin. This ensures that we only have to update the
+    #! methods whose specializer intersects the new member, not
+    #! the entire mixin (since the other mixin members are not
+    #! affected at all). Also, all usages of the mixin will get
+    #! updated by transitivity; the mixins usages appear in
+    #! class-usages of the member, now that it's been added.
+    [ 2drop ] [
+        [ [ suffix ] change-mixin-class ] 2keep drop
+        dup new-class? [ update-classes/new ] [ update-classes ] if
+    ] if-mixin-member? ;
 
 : remove-mixin-instance ( class mixin -- )
-    [ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
+    [
+        [ [ swap remove ] change-mixin-class ] keep
+        update-classes
+    ] [ 2drop ] if-mixin-member? ;
 
 ! Definition protocol implementation ensures that removing an
 ! INSTANCE: declaration from a source file updates the mixin.

core/classes/predicate/predicate.factor

@@ -14,7 +14,7 @@ PREDICATE: predicate-class < class
     ] [ ] make ;
 
 : define-predicate-class ( class superclass definition -- )
-    [ drop f predicate-class define-class ]
+    [ drop f f predicate-class define-class ]
     [ nip "predicate-definition" set-word-prop ]
     [
         2drop
@@ -30,3 +30,5 @@ M: predicate-class reset-class
         "predicate-definition"
         "superclass"
     } reset-props ;
+
+M: predicate-class rank-class drop 1 ;

core/classes/singleton/singleton-docs.factor

@@ -18,7 +18,7 @@ HELP: SINGLETON:
     "Defines a new singleton class. The class word itself is the sole instance of the singleton class."
 }
 { $examples
-    { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
+    { $example "USING: classes.singleton kernel io ;" "IN: scratchpad" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
 } ;
 
 HELP: define-singleton-class

core/classes/singleton/singleton-tests.factor

@@ -10,3 +10,10 @@ GENERIC: zammo ( obj -- str )
 [ ] [ SINGLETON: omg ] unit-test
 [ t ] [ omg singleton-class? ] unit-test
 [ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
+
+SINGLETON: word-and-singleton
+
+: word-and-singleton 3 ;
+
+[ t ] [ \ word-and-singleton word-and-singleton? ] unit-test
+[ 3 ] [ word-and-singleton ] unit-test

core/classes/tuple/tuple-docs.factor

@@ -341,6 +341,7 @@ HELP: new
 { $examples
     { $example
         "USING: kernel prettyprint ;"
+        "IN: scratchpad"
         "TUPLE: employee number name department ;"
         "employee new ."
         "T{ employee f f f f }"

core/classes/tuple/tuple-tests.factor

@@ -4,11 +4,11 @@ namespaces quotations sequences.private classes continuations
 generic.standard effects classes.tuple classes.tuple.private
 arrays vectors strings compiler.units accessors classes.algebra
 calendar prettyprint io.streams.string splitting inspector
-columns ;
+columns math.order classes.private ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
-: <rect> rect boa ;
+: <rect> ( x y w h -- rect ) rect boa ;
 
 : move ( x rect -- rect )
     [ + ] change-x ;
@@ -69,7 +69,7 @@ C: <predicate-test> predicate-test
 PREDICATE: silly-pred < tuple
     class \ rect = ;
 
-GENERIC: area
+GENERIC: area ( obj -- n )
 M: silly-pred area dup w>> swap h>> * ;
 
 TUPLE: circle radius ;
@@ -88,7 +88,7 @@ C: <empty> empty
 [ t length ] [ object>> t eq? ] must-fail-with
 
 [ "<constructor-test>" ]
-[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
+[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
 
 TUPLE: size-test a b c d ;
 
@@ -164,7 +164,7 @@ C: <t4> t4
 [ 1 ] [ <t4> 1 m2 ] unit-test
 
 ! another combination issue
-GENERIC: silly
+GENERIC: silly ( obj -- obj obj )
 
 UNION: my-union slice repetition column array vector reversed ;
 
@@ -208,8 +208,8 @@ C: <erg's-reshape-problem> erg's-reshape-problem
 
 ! We want to make sure constructors are recompiled when
 ! tuples are reshaped
-: cons-test-1 \ erg's-reshape-problem new ;
+: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
-: cons-test-2 \ erg's-reshape-problem boa ;
+: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
 
 "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
 
@@ -233,8 +233,8 @@ TUPLE: laptop < computer battery ;
 C: <laptop> laptop
 
 [ t ] [ laptop tuple-class? ] unit-test
-[ t ] [ laptop tuple class< ] unit-test
+[ t ] [ laptop tuple class<= ] unit-test
-[ t ] [ laptop computer class< ] unit-test
+[ t ] [ laptop computer class<= ] unit-test
 [ t ] [ laptop computer classes-intersect? ] unit-test
 
 [ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
@@ -242,7 +242,7 @@ C: <laptop> laptop
 [ t ] [ "laptop" get computer? ] unit-test
 [ t ] [ "laptop" get tuple? ] unit-test
 
-: test-laptop-slot-values
+: test-laptop-slot-values ( -- )
     [ laptop ] [ "laptop" get class ] unit-test
     [ "Pentium" ] [ "laptop" get cpu>> ] unit-test
     [ 128 ] [ "laptop" get ram>> ] unit-test
@@ -266,8 +266,8 @@ TUPLE: server < computer rackmount ;
 C: <server> server
 
 [ t ] [ server tuple-class? ] unit-test
-[ t ] [ server tuple class< ] unit-test
+[ t ] [ server tuple class<= ] unit-test
-[ t ] [ server computer class< ] unit-test
+[ t ] [ server computer class<= ] unit-test
 [ t ] [ server computer classes-intersect? ] unit-test
 
 [ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
@@ -275,7 +275,7 @@ C: <server> server
 [ t ] [ "server" get computer? ] unit-test
 [ t ] [ "server" get tuple? ] unit-test
 
-: test-server-slot-values
+: test-server-slot-values ( -- )
     [ server ] [ "server" get class ] unit-test
     [ "PowerPC" ] [ "server" get cpu>> ] unit-test
     [ 64 ] [ "server" get ram>> ] unit-test
@@ -286,8 +286,8 @@ test-server-slot-values
 [ f ] [ "server" get laptop? ] unit-test
 [ f ] [ "laptop" get server? ] unit-test
 
-[ f ] [ server laptop class< ] unit-test
+[ f ] [ server laptop class<= ] unit-test
-[ f ] [ laptop server class< ] unit-test
+[ f ] [ laptop server class<= ] unit-test
 [ f ] [ laptop server classes-intersect? ] unit-test
 
 [ f ] [ 1 2 <computer> laptop? ] unit-test
@@ -306,9 +306,9 @@ TUPLE: electronic-device ;
 
 [ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
 
-[ f ] [ electronic-device laptop class< ] unit-test
+[ f ] [ electronic-device laptop class<= ] unit-test
-[ t ] [ server electronic-device class< ] unit-test
+[ t ] [ server electronic-device class<= ] unit-test
-[ t ] [ laptop server class-or electronic-device class< ] unit-test
+[ t ] [ laptop server class-or electronic-device class<= ] unit-test
 
 [ t ] [ "laptop" get electronic-device? ] unit-test
 [ t ] [ "laptop" get computer? ] unit-test
@@ -375,7 +375,7 @@ C: <test2> test2
 
 "a" "b" <test2> "test" set
 
-: test-a/b
+: test-a/b ( -- )
     [ "a" ] [ "test" get a>> ] unit-test
     [ "b" ] [ "test" get b>> ] unit-test ;
 
@@ -403,7 +403,7 @@ TUPLE: move-up-2 < move-up-1 c ;
 
 T{ move-up-2 f "a" "b" "c" } "move-up" set
 
-: test-move-up
+: test-move-up ( -- )
     [ "a" ] [ "move-up" get a>> ] unit-test
     [ "b" ] [ "move-up" get b>> ] unit-test
     [ "c" ] [ "move-up" get c>> ] unit-test ;
@@ -541,4 +541,27 @@ TUPLE: another-forget-accessors-test ;
 ] unit-test
 
 ! Missing error check
-[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
+[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
+
+! Class forget messyness
+TUPLE: subclass-forget-test ;
+
+TUPLE: subclass-forget-test-1 < subclass-forget-test ;
+TUPLE: subclass-forget-test-2 < subclass-forget-test ;
+TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
+
+[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
+
+[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ]
+[ subclass-forget-test-2 class-usages ]
+unit-test
+
+[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ]
+[ subclass-forget-test-3 class-usages ]
+unit-test
+
+[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
+[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
+[ subclass-forget-test-3 new ] must-fail
+
+[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail

core/classes/tuple/tuple.factor

@@ -102,7 +102,7 @@ ERROR: bad-superclass class ;
     dup tuple-predicate-quot define-predicate ;
 
 : superclass-size ( class -- n )
-    superclasses 1 head-slice*
+    superclasses but-last-slice
     [ slot-names length ] map sum ;
 
 : generate-tuple-slots ( class slots -- slot-specs )
@@ -160,13 +160,13 @@ M: tuple-class update-class
     tri ;
 
 : define-new-tuple-class ( class superclass slots -- )
-    [ drop f tuple-class define-class ]
+    [ drop f f tuple-class define-class ]
     [ nip "slot-names" set-word-prop ]
     [ 2drop update-classes ]
     3tri ;
 
 : subclasses ( class -- classes )
-    class-usages keys [ tuple-class? ] subset ;
+    class-usages keys [ tuple-class? ] filter ;
 
 : each-subclass ( class quot -- )
     >r subclasses r> each ; inline
@@ -176,7 +176,7 @@ M: tuple-class update-class
         2drop
         [
             [ update-tuples-after ]
-            [ changed-definition ]
+            [ +inlined+ changed-definition ]
             [ redefined ]
             tri
         ] each-subclass
@@ -226,6 +226,8 @@ M: tuple-class reset-class
         } reset-props
     ] bi ;
 
+M: tuple-class rank-class drop 0 ;
+
 M: tuple clone
     (clone) dup delegate clone over set-delegate ;
 

core/classes/union/union-docs.factor

@@ -4,7 +4,7 @@ layouts classes.private classes compiler.units ;
 IN: classes.union
 
 ARTICLE: "unions" "Union classes"
-"An object is an instance of a union class if it is an instance of one of its members. Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates."
+"An object is an instance of a union class if it is an instance of one of its members."
 { $subsection POSTPONE: UNION: }
 { $subsection define-union-class }
 "Union classes can be introspected:"
@@ -12,7 +12,7 @@ ARTICLE: "unions" "Union classes"
 "The set of union classes is a class:"
 { $subsection union-class }
 { $subsection union-class? } 
-"Unions are used to define behavior shared between a fixed set of classes."
+"Unions are used to define behavior shared between a fixed set of classes, as well as to conveniently define predicates."
 { $see-also "mixins" "tuple-subclassing" } ;
 
 ABOUT: "unions"

core/classes/union/union.factor

@@ -7,7 +7,6 @@ IN: classes.union
 PREDICATE: union-class < class
     "metaclass" word-prop union-class eq? ;
 
-! Union classes for dispatch on multiple classes.
 : union-predicate-quot ( members -- quot )
     dup empty? [
         drop [ drop f ]
@@ -23,10 +22,13 @@ PREDICATE: union-class < class
 
 M: union-class update-class define-union-predicate ;
 
+: (define-union-class) ( class members -- )
+    f swap f union-class define-class ;
+
 : define-union-class ( class members -- )
-    [ f swap union-class define-class ]
+    [ (define-union-class) ] [ drop update-classes ] 2bi ;
-    [ drop update-classes ]
-    2bi ;
 
 M: union-class reset-class
     { "class" "metaclass" "members" } reset-props ;
+
+M: union-class rank-class drop 2 ;

core/combinators/combinators-docs.factor

@@ -10,8 +10,10 @@ ARTICLE: "combinators-quot" "Quotation construction utilities"
 { $subsection alist>quot } ;
 
 ARTICLE: "combinators" "Additional combinators"
-"The " { $vocab-link "combinators" } " vocabulary provides generalizations of certain combinators from the " { $vocab-link "kernel" } " vocabulary."
+"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
 $nl
+"A looping combinator:"
+{ $subsection while }
 "Generalization of " { $link bi } " and " { $link tri } ":"
 { $subsection cleave }
 "Generalization of " { $link bi* } " and " { $link tri* } ":"
@@ -95,7 +97,7 @@ HELP: case
     "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
     $nl
     "The following two phrases are equivalent:"
-    { $code "{ { X [ Y ] } { Y [ T ] } } case" }
+    { $code "{ { X [ Y ] } { Z [ T ] } } case" }
     { $code "dup X = [ drop Y ] [ dup Z = [ drop T ] [ no-case ] if ] if" }
 }
 { $examples

core/combinators/combinators.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: combinators
 USING: arrays sequences sequences.private math.private
 kernel kernel.private math assocs quotations vectors
-hashtables sorting words sets ;
+hashtables sorting words sets math.order ;
+IN: combinators
 
 : cleave ( x seq -- )
     [ call ] with each ;
@@ -95,10 +95,10 @@ M: hashtable hashcode*
 
 : (distribute-buckets) ( buckets pair keys -- )
     dup t eq? [
-        drop [ swap push-new ] curry each
+        drop [ swap adjoin ] curry each
     ] [
         [
-            >r 2dup r> hashcode pick length rem rot nth push-new
+            >r 2dup r> hashcode pick length rem rot nth adjoin
         ] each 2drop
     ] if ;
 

core/command-line/command-line.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: command-line
 USING: init continuations debugger hashtables io kernel
 kernel.private namespaces parser sequences strings system
 splitting io.files ;
+IN: command-line
 
 : run-bootstrap-init ( -- )
     "user-init" get [
@@ -36,7 +36,7 @@ SYMBOL: main-vocab-hook
         main-vocab-hook get [ call ] [ "listener" ] if*
     ] if ;
 
-: default-cli-args
+: default-cli-args ( -- )
     global [
         "quiet" off
         "script" off
@@ -54,7 +54,7 @@ SYMBOL: main-vocab-hook
     "none" "run" set-global ;
 
 : parse-command-line ( -- )
-    cli-args [ cli-arg ] subset
+    cli-args [ cli-arg ] filter
     "script" get [ script-mode ] when
     ignore-cli-args? [ drop ] [ [ run-file ] each ] if
     "e" get [ eval ] when* ;

core/compiler/compiler.factor

@@ -4,38 +4,55 @@ USING: kernel namespaces arrays sequences io inference.backend
 inference.state generator debugger words compiler.units
 continuations vocabs assocs alien.compiler dlists optimizer
 definitions math compiler.errors threads graphs generic
-inference ;
+inference combinators ;
 IN: compiler
 
 : ripple-up ( word -- )
     compiled-usage [ drop queue-compile ] assoc-each ;
 
 : save-effect ( word effect -- )
-    over "compiled-uses" word-prop [
-        2dup swap "compiled-effect" word-prop =
-        [ over ripple-up ] unless
-    ] when
-    "compiled-effect" set-word-prop ;
-
-: finish-compile ( word effect dependencies -- )
-    >r dupd save-effect r>
-    over compiled-unxref
-    over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
-
-: compile-succeeded ( word -- effect dependencies )
     [
-        [ word-dataflow optimize ] keep dup generate
+        over "compiled-effect" word-prop = [
-    ] computing-dependencies ;
+            dup "compiled-uses" word-prop
+            [ dup ripple-up ] when
+        ] unless drop
+    ]
+    [ "compiled-effect" set-word-prop ] 2bi ;
+
+: compile-begins ( word -- )
+    f swap compiler-error ;
 
 : compile-failed ( word error -- )
-    f pick compiled get set-at
+    [ swap compiler-error ]
-    swap compiler-error ;
+    [
+        drop
+        [ f swap compiled get set-at ]
+        [ f save-effect ]
+        bi
+    ] 2bi ;
+
+: compile-succeeded ( effect word -- )
+    [ swap save-effect ]
+    [ compiled-unxref ]
+    [
+        dup crossref?
+        [ dependencies get compiled-xref ] [ drop ] if
+    ] tri ;
 
 : (compile) ( word -- )
-    f over compiler-error
+    [
-    [ dup compile-succeeded finish-compile ]
+        H{ } clone dependencies set
-    [ dupd compile-failed f save-effect ]
+
-    recover ;
+        {
+            [ compile-begins ]
+            [
+                [ word-dataflow ] [ compile-failed return ] recover
+                optimize
+            ]
+            [ dup generate ]
+            [ compile-succeeded ]
+        } cleave
+    ] curry with-return ;
 
 : compile-loop ( assoc -- )
     dup assoc-empty? [ drop ] [

core/compiler/constants/constants.factor

@@ -4,19 +4,22 @@ USING: math kernel layouts system ;
 IN: compiler.constants
 
 ! These constants must match vm/memory.h
-: card-bits 6 ;
+: card-bits 8 ;
-: card-mark HEX: 40 HEX: 80 bitor ;
+: deck-bits 18 ;
+: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
 
 ! These constants must match vm/layouts.h
-: header-offset object tag-number neg ;
+: header-offset ( -- n ) object tag-number neg ;
-: float-offset 8 float tag-number - ;
+: float-offset ( -- n ) 8 float tag-number - ;
-: string-offset 4 bootstrap-cells object tag-number - ;
+: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
-: profile-count-offset 7 bootstrap-cells object tag-number - ;
+: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
-: byte-array-offset 2 bootstrap-cells object tag-number - ;
+: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
-: alien-offset 3 bootstrap-cells object tag-number - ;
+: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
-: underlying-alien-offset bootstrap-cell object tag-number - ;
+: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
-: tuple-class-offset bootstrap-cell tuple tag-number - ;
+: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
-: class-hash-offset bootstrap-cell object tag-number - ;
+: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
-: word-xt-offset 8 bootstrap-cells object tag-number - ;
+: word-xt-offset ( -- n ) 8 bootstrap-cells object tag-number - ;
-: word-code-offset 9 bootstrap-cells object tag-number - ;
+: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
-: compiled-header-size 4 bootstrap-cells ;
+: word-code-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
+: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: compiled-header-size ( -- n ) 4 bootstrap-cells ;

core/compiler/errors/errors-docs.factor

@@ -21,19 +21,19 @@ HELP: compiler-error
 
 HELP: compiler-error.
 { $values { "error" "an error" } { "word" word } }
-{ $description "Prints a compiler error to the " { $link stdio } " stream." } ;
+{ $description "Prints a compiler error to " { $link output-stream } "." } ;
 
 HELP: compiler-errors.
 { $values { "type" symbol } }
-{ $description "Prints compiler errors to the " { $link stdio } " stream. The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
+{ $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
 HELP: :errors
-{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
+{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
 
 HELP: :warnings
-{ $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ;
+{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
 
 HELP: :linkage
-{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ;
+{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
 
 { :errors :warnings } related-words
 

core/compiler/errors/errors.factor

@@ -27,7 +27,7 @@ SYMBOL: with-compiler-errors?
 : errors-of-type ( type -- assoc )
     compiler-errors get-global
     swap [ >r nip compiler-error-type r> eq? ] curry
-    assoc-subset ;
+    assoc-filter ;
 
 : compiler-errors. ( type -- )
     errors-of-type >alist sort-keys
@@ -59,11 +59,11 @@ PRIVATE>
         [ set-at ] [ delete-at drop ] if
     ] [ 2drop ] if ;
 
-: :errors +error+ compiler-errors. ;
+: :errors ( -- ) +error+ compiler-errors. ;
 
-: :warnings +warning+ compiler-errors. ;
+: :warnings ( -- ) +warning+ compiler-errors. ;
 
-: :linkage +linkage+ compiler-errors. ;
+: :linkage ( -- ) +linkage+ compiler-errors. ;
 
 : with-compiler-errors ( quot -- )
     with-compiler-errors? get "quiet" get or [ call ] [

core/compiler/tests/intrinsics.factor

@@ -1,11 +1,11 @@
-IN: compiler.tests
 USING: arrays compiler.units kernel kernel.private math
 math.constants math.private sequences strings tools.test words
 continuations sequences.private hashtables.private byte-arrays
 strings.private system random layouts vectors.private
-sbufs.private strings.private slots.private alien
+sbufs.private strings.private slots.private alien math.order
 alien.accessors alien.c-types alien.syntax alien.strings
 namespaces libc sequences.private io.encodings.ascii ;
+IN: compiler.tests
 
 ! Make sure that intrinsic ops compile to correct code.
 [ ] [ 1 [ drop ] compile-call ] unit-test
@@ -252,7 +252,7 @@ cell 8 = [
 ! Some randomized tests
 : compiled-fixnum* fixnum* ;
 
-: test-fixnum*
+: test-fixnum* ( -- )
     32 random-bits >fixnum 32 random-bits >fixnum
     2dup
     [ fixnum* ] 2keep compiled-fixnum* =
@@ -262,7 +262,7 @@ cell 8 = [
 
 : compiled-fixnum>bignum fixnum>bignum ;
 
-: test-fixnum>bignum
+: test-fixnum>bignum ( -- )
     32 random-bits >fixnum
     dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
     [ drop ] [ "Oops" throw ] if ;
@@ -271,7 +271,7 @@ cell 8 = [
 
 : compiled-bignum>fixnum bignum>fixnum ;
 
-: test-bignum>fixnum
+: test-bignum>fixnum ( -- )
     5 random [ drop 32 random-bits ] map product >bignum
     dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
     [ drop ] [ "Oops" throw ] if ;
@@ -377,7 +377,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 ] prepend ;
+: xword-def ( word -- 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/tests/redefine.factor

@@ -0,0 +1,14 @@
+IN: compiler.tests
+USING: compiler tools.test math parser ;
+
+GENERIC: method-redefine-test ( a -- b )
+
+M: integer method-redefine-test 3 + ;
+
+: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
+
+[ 6 ] [ method-redefine-test-1 ] unit-test
+
+[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
+
+[ 7 ] [ method-redefine-test-1 ] unit-test

core/compiler/tests/simple.factor

@@ -69,31 +69,31 @@ IN: compiler.tests
 
 ! Regression
 
-: empty ;
+: empty ( -- ) ;
 
 [ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test
 
-: dummy-if-1 t [ ] [ ] if ;
+: dummy-if-1 ( -- ) t [ ] [ ] if ;
 
 [ ] [ dummy-if-1 ] unit-test
 
-: dummy-if-2 f [ ] [ ] if ;
+: dummy-if-2 ( -- ) f [ ] [ ] if ;
 
 [ ] [ dummy-if-2 ] unit-test
 
-: dummy-if-3 t [ 1 ] [ 2 ] if ;
+: dummy-if-3 ( -- n ) t [ 1 ] [ 2 ] if ;
 
 [ 1 ] [ dummy-if-3 ] unit-test
 
-: dummy-if-4 f [ 1 ] [ 2 ] if ;
+: dummy-if-4 ( -- n ) f [ 1 ] [ 2 ] if ;
 
 [ 2 ] [ dummy-if-4 ] unit-test
 
-: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
+: dummy-if-5 ( -- n ) 0 dup 1 fixnum<= [ drop 1 ] [ ] if ;
 
 [ 1 ] [ dummy-if-5 ] unit-test
 
-: dummy-if-6
+: dummy-if-6 ( n -- n )
     dup 1 fixnum<= [
         drop 1
     ] [
@@ -102,7 +102,7 @@ IN: compiler.tests
 
 [ 17 ] [ 10 dummy-if-6 ] unit-test
 
-: dead-code-rec
+: dead-code-rec ( -- obj )
     t [
         3.2
     ] [
@@ -111,11 +111,11 @@ IN: compiler.tests
 
 [ 3.2 ] [ dead-code-rec ] unit-test
 
-: one-rec [ f one-rec ] [ "hi" ] if ;
+: one-rec ( ? -- obj ) [ f one-rec ] [ "hi" ] if ;
 
 [ "hi" ] [ t one-rec ] unit-test
 
-: after-if-test
+: after-if-test ( -- n )
     t [ ] [ ] if 5 ;
 
 [ 5 ] [ after-if-test ] unit-test
@@ -127,37 +127,37 @@ DEFER: countdown-b
 
 [ ] [ 10 countdown-b ] unit-test
 
-: dummy-when-1 t [ ] when ;
+: dummy-when-1 ( -- ) t [ ] when ;
 
 [ ] [ dummy-when-1 ] unit-test
 
-: dummy-when-2 f [ ] when ;
+: dummy-when-2 ( -- ) f [ ] when ;
 
 [ ] [ dummy-when-2 ] unit-test
 
-: dummy-when-3 dup [ dup fixnum* ] when ;
+: dummy-when-3 ( a -- b ) dup [ dup fixnum* ] when ;
 
 [ 16 ] [ 4 dummy-when-3 ] unit-test
 [ f ] [ f dummy-when-3 ] unit-test
 
-: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ;
+: dummy-when-4 ( a b -- a b ) dup [ dup dup fixnum* fixnum* ] when swap ;
 
 [ 64 f ] [ f 4 dummy-when-4 ] unit-test
 [ f t ] [ t f dummy-when-4 ] unit-test
 
-: dummy-when-5 f [ dup fixnum* ] when ;
+: dummy-when-5 ( a -- b ) f [ dup fixnum* ] when ;
 
 [ f ] [ f dummy-when-5 ] unit-test
 
-: dummy-unless-1 t [ ] unless ;
+: dummy-unless-1 ( -- ) t [ ] unless ;
 
 [ ] [ dummy-unless-1 ] unit-test
 
-: dummy-unless-2 f [ ] unless ;
+: dummy-unless-2 ( -- ) f [ ] unless ;
 
 [ ] [ dummy-unless-2 ] unit-test
 
-: dummy-unless-3 dup [ drop 3 ] unless ;
+: dummy-unless-3 ( a -- b ) dup [ drop 3 ] unless ;
 
 [ 3 ] [ f dummy-unless-3 ] unit-test
 [ 4 ] [ 4 dummy-unless-3 ] unit-test
@@ -201,7 +201,7 @@ DEFER: countdown-b
     ] compile-call
 ] unit-test
 
-GENERIC: single-combination-test
+GENERIC: single-combination-test ( obj1 obj2 -- obj )
 
 M: object single-combination-test drop ;
 M: f single-combination-test nip ;
@@ -214,13 +214,13 @@ M: integer single-combination-test drop ;
 
 DEFER: single-combination-test-2
 
-: single-combination-test-4
+: single-combination-test-4 ( obj -- obj )
     dup [ single-combination-test-2 ] when ;
 
-: single-combination-test-3
+: single-combination-test-3 ( obj -- obj )
     drop 3 ;
 
-GENERIC: single-combination-test-2
+GENERIC: single-combination-test-2 ( obj -- obj )
 M: object single-combination-test-2 single-combination-test-3 ;
 M: f single-combination-test-2 single-combination-test-4 ;
 

core/compiler/tests/stack-trace.factor

@@ -1,25 +1,25 @@
 IN: compiler.tests
 USING: compiler tools.test namespaces sequences
 kernel.private kernel math continuations continuations.private
-words splitting sorting ;
+words splitting grouping sorting ;
 
 : symbolic-stack-trace ( -- newseq )
     error-continuation get continuation-call callstack>array
     2 group flip first ;
 
-: foo 3 throw 7 ;
+: foo ( -- * ) 3 throw 7 ;
-: bar foo 4 ;
+: bar ( -- * ) foo 4 ;
-: baz bar 5 ;
+: baz ( -- * ) bar 5 ;
 [ baz ] [ 3 = ] must-fail-with
 [ t ] [
     symbolic-stack-trace
-    [ word? ] subset
+    [ word? ] filter
     { baz bar foo throw } tail?
 ] unit-test
 
-: bleh [ 3 + ] map [ 0 > ] subset ;
+: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
 
-: stack-trace-contains? symbolic-stack-trace memq? ;
+: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ;
 
 [ t ] [
     [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
@@ -31,7 +31,7 @@ words splitting sorting ;
     \ > stack-trace-contains?
 ] unit-test
 
-: quux { 1 2 3 } [ "hi" throw ] sort ;
+: quux ( -- seq ) { 1 2 3 } [ "hi" throw ] sort ;
 
 [ t ] [
     [ 10 quux ] ignore-errors

core/compiler/tests/templates.factor

@@ -31,7 +31,7 @@ unit-test
 
 [ 2 ] [ 1 2 [ swap fixnum/i ] compile-call ] unit-test
 
-: foo ;
+: foo ( -- ) ;
 
 [ 5 5 ]
 [ 1.2 [ tag [ foo ] keep ] compile-call ]
@@ -103,10 +103,10 @@ unit-test
 
 
 ! Test how dispatch handles the end of a basic block
-: try-breaking-dispatch
+: try-breaking-dispatch ( n a b -- a b str )
     float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
 
-: try-breaking-dispatch-2
+: try-breaking-dispatch-2 ( -- ? )
     1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
 
 [ t ] [
@@ -143,7 +143,7 @@ unit-test
 ] unit-test
 
 ! Regression
-: foox
+: foox ( obj -- obj )
     dup not
     [ drop 3 ] [ dup tuple? [ drop 4 ] [ drop 5 ] if ] if ;
 
@@ -189,7 +189,7 @@ TUPLE: my-tuple ;
 ] unit-test
 
 ! Regression
-: a-dummy drop "hi" print ;
+: a-dummy ( -- ) drop "hi" print ;
 
 [ ] [
     1 [
@@ -203,7 +203,7 @@ TUPLE: my-tuple ;
     ] compile-call
 ] unit-test
 
-: float-spill-bug
+: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
     {
         [ dup float+ ]
         [ dup float+ ]

core/compiler/units/units.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel continuations assocs namespaces sequences words
-vocabs definitions hashtables init ;
+vocabs definitions hashtables init sets ;
 IN: compiler.units
 
 SYMBOL: old-definitions
@@ -14,7 +14,7 @@ TUPLE: redefine-error def ;
     { { "Continue" t } } throw-restarts drop ;
 
 : add-once ( key assoc -- )
-    2dup key? [ over redefine-error ] when dupd set-at ;
+    2dup key? [ over redefine-error ] when conjoin ;
 
 : (remember-definition) ( definition loc assoc -- )
     >r over set-where r> add-once ;
@@ -53,7 +53,7 @@ GENERIC: definitions-changed ( assoc obj -- )
     [ definitions-changed ] with each ;
 
 : changed-vocabs ( assoc -- vocabs )
-    [ drop word? ] assoc-subset
+    [ drop word? ] assoc-filter
     [ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
 
 : updated-definitions ( -- assoc )
@@ -66,14 +66,14 @@ GENERIC: definitions-changed ( assoc obj -- )
 
 : compile ( words -- )
     recompile-hook get call
-    dup [ drop compiled-crossref? ] assoc-contains?
+    dup [ drop crossref? ] assoc-contains?
     modify-code-heap ;
 
 SYMBOL: outdated-tuples
 SYMBOL: update-tuples-hook
 
 : call-recompile-hook ( -- )
-    changed-definitions get keys [ word? ] subset
+    changed-definitions get [ drop word? ] assoc-filter
     compiled-usages recompile-hook get call ;
 
 : call-update-tuples-hook ( -- )
@@ -82,18 +82,28 @@ SYMBOL: update-tuples-hook
 : finish-compilation-unit ( -- )
     call-recompile-hook
     call-update-tuples-hook
-    dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
+    dup [ drop crossref? ] assoc-contains? modify-code-heap ;
-    updated-definitions notify-definition-observers ;
+
+: with-nested-compilation-unit ( quot -- )
+    [
+        H{ } clone changed-definitions set
+        H{ } clone outdated-tuples set
+        [ finish-compilation-unit ] [ ] cleanup
+    ] with-scope ; inline
 
 : with-compilation-unit ( quot -- )
     [
         H{ } clone changed-definitions set
         H{ } clone forgotten-definitions set
         H{ } clone outdated-tuples set
+        H{ } clone new-classes set
         <definitions> new-definitions set
         <definitions> old-definitions set
-        [ finish-compilation-unit ]
+        [
-        [ ] cleanup
+            finish-compilation-unit
+            updated-definitions
+            notify-definition-observers
+        ] [ ] cleanup
     ] with-scope ; inline
 
 : compile-call ( quot -- )

core/continuations/continuations-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax kernel kernel.private
 continuations.private parser vectors arrays namespaces
-assocs words quotations io ;
+assocs words quotations ;
 IN: continuations
 
 ARTICLE: "errors-restartable" "Restartable errors"
@@ -28,13 +28,7 @@ $nl
 { $heading "Anti-pattern #3: Dropping and rethrowing" }
 "Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using  " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
 { $heading "Anti-pattern #4: Logging and rethrowing" }
-"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information."
+"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
-{ $heading "Anti-pattern #5: Leaking external resources" }
-"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
-{ $code
-    "<external-resource> ... do stuff ... dispose"
-}
-"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ;
 
 ARTICLE: "errors" "Error handling"
 "Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
@@ -88,19 +82,6 @@ $nl
 
 ABOUT: "continuations"
 
-HELP: dispose
-{ $values { "object" "a disposable object" } }
-{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
-$nl
-"No further operations can be performed on a disposable object after this call."
-$nl
-"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." }
-{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
-
-HELP: with-disposal
-{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
-{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
-
 HELP: catchstack*
 { $values { "catchstack" "a vector of continuations" } }
 { $description "Outputs the current catchstack." } ;

core/continuations/continuations-tests.factor

@@ -1,6 +1,6 @@
 USING: kernel math namespaces io tools.test sequences vectors
 continuations debugger parser memory arrays words
-kernel.private ;
+kernel.private accessors ;
 IN: continuations.tests
 
 : (callcc1-test)
@@ -39,7 +39,7 @@ IN: continuations.tests
 
 "!!! The following error is part of the test" print
 
-[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test
+[ ] [ [ [ "2 car" ] eval ] try ] unit-test
 
 [ f throw ] must-fail
 
@@ -100,3 +100,7 @@ SYMBOL: error-counter
     [ 3 ] [ always-counter get ] unit-test
     [ 1 ] [ error-counter get ] unit-test
 ] with-scope
+
+[ ] [ [ return ] with-return ] unit-test
+
+[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with

core/continuations/continuations.factor

@@ -26,7 +26,7 @@ SYMBOL: restarts
     #! with a declaration.
     f { object } declare ;
 
-: init-catchstack V{ } clone 1 setenv ;
+: init-catchstack ( -- ) V{ } clone 1 setenv ;
 
 PRIVATE>
 
@@ -101,6 +101,14 @@ PRIVATE>
 : continue ( continuation -- )
     f swap continue-with ;
 
+SYMBOL: return-continuation
+
+: with-return ( quot -- )
+    [ [ return-continuation set ] prepose callcc0 ] with-scope ; inline
+
+: return ( -- )
+    return-continuation get continue ;
+
 GENERIC: compute-restarts ( error -- seq )
 
 <PRIVATE
@@ -131,15 +139,16 @@ SYMBOL: thread-error-hook
     over >r compose [ dip rethrow ] curry
     recover r> call ; inline
 
+ERROR: attempt-all-error ;
+
 : attempt-all ( seq quot -- obj )
-    [
+    over empty? [
-        [ [ , f ] compose [ , drop t ] recover ] curry all?
+        attempt-all-error
-    ] { } make peek swap [ rethrow ] when ; inline
+    ] [
-
+        [
-GENERIC: dispose ( object -- )
+            [ [ , f ] compose [ , drop t ] recover ] curry all?
-
+        ] { } make peek swap [ rethrow ] when
-: with-disposal ( object quot -- )
+    ] if ; inline
-    over [ dispose ] curry [ ] cleanup ; inline
 
 TUPLE: condition error restarts continuation ;
 

core/cpu/architecture/architecture.factor

@@ -41,12 +41,12 @@ HOOK: stack-frame cpu ( frame-size -- n )
 ! Set up caller stack frame
 HOOK: %prologue cpu ( n -- )
 
-: %prologue-later \ %prologue-later , ;
+: %prologue-later ( -- ) \ %prologue-later , ;
 
 ! Tear down stack frame
 HOOK: %epilogue cpu ( n -- )
 
-: %epilogue-later \ %epilogue-later , ;
+: %epilogue-later ( -- ) \ %epilogue-later , ;
 
 ! Store word XT in stack frame
 HOOK: %save-word-xt cpu ( -- )
@@ -195,7 +195,7 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 HOOK: %box-alien cpu ( dst src -- )
 
 ! GC check
-HOOK: %gc cpu
+HOOK: %gc cpu ( -- )
 
 : operand ( var -- op ) get v>operand ; inline
 

core/cpu/ppc/architecture/architecture.factor

@@ -4,7 +4,7 @@ USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
 kernel kernel.private math memory namespaces sequences words
 assocs generator generator.registers generator.fixup system
 layouts classes words.private alien combinators
-compiler.constants ;
+compiler.constants math.order ;
 IN: cpu.ppc.architecture
 
 ! PowerPC register assignments

core/cpu/ppc/assembler/assembler.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: generator.fixup generic kernel memory namespaces
+words math math.bitfields math.order io.binary ;
 IN: cpu.ppc.assembler
-USING: generator.fixup generic kernel math memory namespaces
-words math.bitfields io.binary ;
 
 ! See the Motorola or IBM documentation for details. The opcode
 ! names are standard, and the operand order is the same as in

core/cpu/ppc/bootstrap.factor

@@ -72,7 +72,7 @@ big-endian on
 ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
 
 : jit-call-quot ( -- )
-    temp-reg quot-reg quot-xt@ LWZ             ! load quotation-xt
+    temp-reg quot-reg quot-xt-offset LWZ       ! load quotation-xt
     temp-reg MTCTR                             ! jump to quotation-xt
     BCTR ;
 
@@ -93,7 +93,7 @@ big-endian on
     temp-reg ds-reg 0 LWZ                      ! load index
     temp-reg dup 1 SRAWI                       ! turn it into an array offset
     quot-reg dup temp-reg ADD                  ! compute quotation location
-    quot-reg dup array-start LWZ               ! load quotation
+    quot-reg dup array-start-offset LWZ        ! load quotation
     ds-reg dup 4 SUBI                          ! pop index
     jit-call-quot
 ] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -18,13 +18,13 @@ IN: cpu.ppc.intrinsics
     "obj" get operand-tag - ;
 
 : %slot-literal-any-tag
-    "obj" operand "scratch" operand %untag
+    "obj" operand "scratch1" operand %untag
-    "val" operand "scratch" operand "n" get cells ;
+    "val" operand "scratch1" operand "n" get cells ;
 
 : %slot-any
-    "obj" operand "scratch" operand %untag
+    "obj" operand "scratch1" operand %untag
     "offset" operand "n" operand 1 SRAWI
-    "scratch" operand "val" operand "offset" operand ;
+    "scratch1" operand "val" operand "offset" operand ;
 
 \ slot {
     ! Slot number is literal and the tag is known
@@ -39,7 +39,7 @@ IN: cpu.ppc.intrinsics
     {
         [ %slot-literal-any-tag LWZ ] H{
             { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "scratch" } { f "val" } } }
+            { +scratch+ { { f "scratch1" } { f "val" } } }
             { +output+ { "val" } }
         }
     }
@@ -47,7 +47,7 @@ IN: cpu.ppc.intrinsics
     {
         [ %slot-any LWZX ] H{
             { +input+ { { f "obj" } { f "n" } } }
-            { +scratch+ { { f "val" } { f "scratch" } { f "offset" } } }
+            { +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } }
             { +output+ { "val" } }
         }
     }
@@ -56,14 +56,22 @@ IN: cpu.ppc.intrinsics
 : load-cards-offset ( dest -- )
     "cards_offset" f pick %load-dlsym  dup 0 LWZ ;
 
+: load-decks-offset ( dest -- )
+    "decks_offset" f pick %load-dlsym  dup 0 LWZ ;
+
 : %write-barrier ( -- )
     "val" get operand-immediate? "obj" get fresh-object? or [
-        "obj" operand "scratch" operand card-bits SRWI
+        card-mark "scratch1" operand LI
+
+        ! Mark the card
         "val" operand load-cards-offset
-        "scratch" operand dup "val" operand ADD
+        "obj" operand "scratch2" operand card-bits SRWI
-        "val" operand "scratch" operand 0 LBZ
+        "scratch2" operand "scratch1" operand "val" operand STBX
-        "val" operand dup card-mark ORI
+
-        "val" operand "scratch" operand 0 STB
+        ! Mark the card deck
+        "val" operand load-decks-offset
+        "obj" operand "scratch2" operand deck-bits SRWI
+        "scratch2" operand "scratch1" operand "val" operand STBX
     ] unless ;
 
 \ set-slot {
@@ -71,7 +79,7 @@ IN: cpu.ppc.intrinsics
     {
         [ %slot-literal-known-tag STW %write-barrier ] H{
             { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "scratch" } } }
+            { +scratch+ { { f "scratch1" } { f "scratch2" } } }
             { +clobber+ { "val" } }
         }
     }
@@ -79,7 +87,7 @@ IN: cpu.ppc.intrinsics
     {
         [ %slot-literal-any-tag STW %write-barrier ] H{
             { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "scratch" } } }
+            { +scratch+ { { f "scratch1" } { f "scratch2" } } }
             { +clobber+ { "val" } }
         }
     }
@@ -87,7 +95,7 @@ IN: cpu.ppc.intrinsics
     {
         [ %slot-any STWX %write-barrier ] H{
             { +input+ { { f "val" } { f "obj" } { f "n" } } }
-            { +scratch+ { { f "scratch" } { f "offset" } } }
+            { +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } }
             { +clobber+ { "val" } }
         }
     }

core/cpu/x86/32/32.factor

@@ -22,29 +22,32 @@ M: x86.32 temp-reg-2 ECX ;
 
 M: temp-reg v>operand drop EBX ;
 
-M: x86.32 %alien-invoke ( symbol dll -- )
+M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
-    (CALL) rel-dlsym ;
+
+M: x86.32 %alien-invoke (CALL) rel-dlsym ;
 
 ! On x86, parameters are never passed in registers.
 M: int-regs return-reg drop EAX ;
 M: int-regs param-regs drop { } ;
 M: int-regs vregs drop { EAX ECX EDX EBP } ;
 M: int-regs push-return-reg return-reg PUSH ;
-: load/store-int-return return-reg stack-reg rot [+] ;
+: load/store-int-return ( n reg-class -- src dst )
+    return-reg stack-reg rot [+] ;
 M: int-regs load-return-reg load/store-int-return MOV ;
 M: int-regs store-return-reg load/store-int-return swap MOV ;
 
 M: float-regs param-regs drop { } ;
 M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
-: FSTP 4 = [ FSTPS ] [ FSTPL ] if ;
+: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
 
 M: float-regs push-return-reg
     stack-reg swap reg-size [ SUB  stack-reg [] ] keep FSTP ;
 
-: FLD 4 = [ FLDS ] [ FLDL ] if ;
+: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
 
-: load/store-float-return reg-size >r stack@ r> ;
+: load/store-float-return ( n reg-class -- op size )
+    [ stack@ ] [ reg-size ] bi* ;
 M: float-regs load-return-reg load/store-float-return FLD ;
 M: float-regs store-return-reg load/store-float-return FSTP ;
 
@@ -150,7 +153,7 @@ M: x86.32 %box ( n reg-class func -- )
         >r (%box) r> f %alien-invoke
     ] with-aligned-stack ;
     
-: (%box-long-long)
+: (%box-long-long) ( n -- )
     #! If n is f, push the return registers onto the stack; we
     #! are boxing a return value of a C function. If n is an
     #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
@@ -165,7 +168,7 @@ M: x86.32 %box ( n reg-class func -- )
 
 M: x86.32 %box-long-long ( n func -- )
     8 [
-        >r (%box-long-long) r> f %alien-invoke
+        [ (%box-long-long) ] [ f %alien-invoke ] bi*
     ] with-aligned-stack ;
 
 M: x86.32 %box-large-struct ( n size -- )
@@ -259,7 +262,7 @@ os windows? [
     4 "double" c-type set-c-type-align
 ] unless
 
-: sse2? "Intrinsic" throw ;
+: sse2? ( -- ? ) "Intrinsic" throw ;
 
 \ sse2? [
     { EAX EBX ECX EDX } [ PUSH ] each

core/cpu/x86/64/64.factor

@@ -130,7 +130,10 @@ M: x86.64 %prepare-box-struct ( size -- )
 
 M: x86.64 %prepare-var-args RAX RAX XOR ;
 
-M: x86.64 %alien-invoke ( symbol dll -- )
+M: x86.64 %alien-global
+    [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
+
+M: x86.64 %alien-invoke
     0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
 
 M: x86.64 %prepare-alien-indirect ( -- )
@@ -181,7 +184,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
 : split-struct ( pairs -- seq )
     [
         [ 8 mod zero? [ t , ] when , ] assoc-each
-    ] { } make { t } split [ empty? not ] subset ;
+    ] { } make { t } split harvest ;
 
 : flatten-large-struct ( type -- )
     heap-size cell align

core/cpu/x86/allot/allot.factor

@@ -6,7 +6,7 @@ sequences generic arrays generator generator.fixup
 generator.registers system layouts alien ;
 IN: cpu.x86.allot
 
-: allot-reg
+: allot-reg ( -- reg )
     #! We temporarily use the datastack register, since it won't
     #! be accessed inside the quotation given to %allot in any
     #! case.

core/cpu/x86/architecture/architecture.factor

@@ -1,17 +1,18 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.compiler arrays
-cpu.x86.assembler cpu.architecture kernel kernel.private math
+cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
-memory namespaces sequences words generator generator.registers
+kernel kernel.private math memory namespaces sequences words
-generator.fixup system layouts combinators compiler.constants ;
+generator generator.registers generator.fixup system layouts
+combinators compiler.constants math.order ;
 IN: cpu.x86.architecture
 
-HOOK: ds-reg cpu
+HOOK: ds-reg cpu ( -- reg )
-HOOK: rs-reg cpu
+HOOK: rs-reg cpu ( -- reg )
-HOOK: stack-reg cpu
+HOOK: stack-reg cpu ( -- reg )
-HOOK: stack-save-reg cpu
+HOOK: stack-save-reg cpu ( -- reg )
 
-: stack@ stack-reg swap [+] ;
+: stack@ ( n -- op ) stack-reg swap [+] ;
 
 : reg-stack ( n reg -- op ) swap cells neg [+] ;
 
@@ -35,14 +36,14 @@ GENERIC: load-return-reg ( stack@ reg-class -- )
 GENERIC: store-return-reg ( stack@ reg-class -- )
 
 ! Only used by inline allocation
-HOOK: temp-reg-1 cpu
+HOOK: temp-reg-1 cpu ( -- reg )
-HOOK: temp-reg-2 cpu
+HOOK: temp-reg-2 cpu ( -- reg )
 
 HOOK: address-operand cpu ( address -- operand )
 
-HOOK: fixnum>slot@ cpu
+HOOK: fixnum>slot@ cpu ( op -- )
 
-HOOK: prepare-division cpu
+HOOK: prepare-division cpu ( -- )
 
 M: immediate load-literal v>operand swap v>operand MOV ;
 
@@ -52,7 +53,7 @@ M: x86 stack-frame ( n -- i )
 M: x86 %save-word-xt ( -- )
     temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
 
-: factor-area-size 4 cells ;
+: factor-area-size ( -- n ) 4 cells ;
 
 M: x86 %prologue ( n -- )
     dup cell + PUSH
@@ -62,8 +63,7 @@ M: x86 %prologue ( n -- )
 M: x86 %epilogue ( n -- )
     stack-reg swap ADD ;
 
-: %alien-global ( symbol dll register -- )
+HOOK: %alien-global cpu ( symbol dll register -- )
-    [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
 
 M: x86 %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
@@ -120,7 +120,7 @@ M: x86 %peek [ v>operand ] bi@ MOV ;
 
 M: x86 %replace swap %peek ;
 
-: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
+: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
 M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
 
@@ -139,7 +139,7 @@ M: x86 small-enough? ( n -- ? )
 
 : %tag-fixnum ( reg -- ) tag-bits get SHL ;
 
-: temp@ stack-reg \ stack-frame get rot - [+] ;
+: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
 
 : struct-return@ ( size n -- n )
     [

core/cpu/x86/assembler/assembler-tests.factor

@@ -36,3 +36,6 @@ IN: cpu.x86.assembler.tests
 
 [ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test
 [ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test
+
+[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
+[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test

core/cpu/x86/assembler/assembler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generator.fixup io.binary kernel
 combinators kernel.private math namespaces parser sequences
-words system layouts ;
+words system layouts math.order accessors ;
 IN: cpu.x86.assembler
 
 ! A postfix assembler for x86 and AMD64.
@@ -11,11 +11,6 @@ IN: cpu.x86.assembler
 ! In 64-bit mode, { 1234 } is RIP-relative.
 ! Beware!
 
-: n, >le % ; inline
-: 4, 4 n, ; inline
-: 2, 2 n, ; inline
-: cell, bootstrap-cell n, ; inline
-
 ! Register operands -- eg, ECX
 <<
 
@@ -27,7 +22,7 @@ IN: cpu.x86.assembler
 : define-registers ( names size -- )
     >r dup length r> [ define-register ] curry 2each ;
 
-: REGISTERS:
+: REGISTERS: ( -- )
     scan-word ";" parse-tokens swap define-registers ; parsing
 
 >>
@@ -45,6 +40,10 @@ REGISTERS: 128
 XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
 XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
 
+TUPLE: byte value ;
+
+C: <byte> byte
+
 <PRIVATE
 
 #! Extended AMD64 registers (R8-R15) return true.
@@ -75,50 +74,38 @@ M: register extended? "register" word-prop 7 > ;
 ! Addressing modes
 TUPLE: indirect base index scale displacement ;
 
-M: indirect extended? indirect-base extended? ;
+M: indirect extended? base>> extended? ;
 
-: canonicalize-EBP
+: canonicalize-EBP ( indirect -- indirect )
     #! { EBP } ==> { EBP 0 }
-    dup indirect-base { EBP RBP R13 } memq? [
+    dup base>> { EBP RBP R13 } member? [
-        dup indirect-displacement [
+        dup displacement>> [ 0 >>displacement ] unless
-            drop
+    ] when ;
-        ] [
-            0 swap set-indirect-displacement
-        ] if
-    ] [
-        drop
-    ] if ;
 
-: canonicalize-ESP
+: canonicalize-ESP ( indirect -- indirect )
     #! { ESP } ==> { ESP ESP }
-    dup indirect-base { ESP RSP R12 } memq? [
+    dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
-        ESP swap set-indirect-index
-    ] [
-        drop
-    ] if ;
 
-: canonicalize ( indirect -- )
+: canonicalize ( indirect -- indirect )
     #! Modify the indirect to work around certain addressing mode
     #! quirks.
-    dup canonicalize-EBP
+    canonicalize-EBP canonicalize-ESP ;
-    canonicalize-ESP ;
 
 : <indirect> ( base index scale displacement -- indirect )
-    indirect boa dup canonicalize ;
+    indirect boa canonicalize ;
 
-: reg-code "register" word-prop 7 bitand ;
+: reg-code ( reg -- n ) "register" word-prop 7 bitand ;
 
-: indirect-base* indirect-base EBP or reg-code ;
+: indirect-base* ( op -- n ) base>> EBP or reg-code ;
 
-: indirect-index* indirect-index ESP or reg-code ;
+: indirect-index* ( op -- n ) index>> ESP or reg-code ;
 
-: indirect-scale* indirect-scale 0 or ;
+: indirect-scale* ( op -- n ) scale>> 0 or ;
 
 GENERIC: sib-present? ( op -- ? )
 
 M: indirect sib-present?
-    dup indirect-base { ESP RSP } memq?
+    [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
-    over indirect-index rot indirect-scale or or ;
 
 M: register sib-present? drop f ;
 
@@ -130,16 +117,23 @@ M: indirect r/m
 
 M: register r/m reg-code ;
 
-: byte? -128 127 between? ;
+! Immediate operands
+UNION: immediate byte integer ;
+
+GENERIC: fits-in-byte? ( value -- ? )
+
+M: byte fits-in-byte? drop t ;
+
+M: integer fits-in-byte? -128 127 between? ;
 
 GENERIC: modifier ( op -- n )
 
 M: indirect modifier
-    dup indirect-base [
+    dup base>> [
-        indirect-displacement {
+        displacement>> {
-            { [ dup not ]      [ BIN: 00 ] }
+            { [ dup not ] [ BIN: 00 ] }
-            { [ dup byte? ]    [ BIN: 01 ] }
+            { [ dup fits-in-byte? ] [ BIN: 01 ] }
-            { [ dup integer? ] [ BIN: 10 ] }
+            { [ dup immediate? ] [ BIN: 10 ] }
         } cond nip
     ] [
         drop BIN: 00
@@ -147,14 +141,23 @@ M: indirect modifier
 
 M: register modifier drop BIN: 11 ;
 
+GENERIC# n, 1 ( value n -- )
+
+M: integer n, >le % ;
+M: byte n, >r value>> r> n, ;
+: 1, ( n -- ) 1 n, ; inline
+: 4, ( n -- ) 4 n, ; inline
+: 2, ( n -- ) 2 n, ; inline
+: cell, ( n -- ) bootstrap-cell n, ; inline
+
 : mod-r/m, ( reg# indirect -- )
-    dup modifier 6 shift rot 3 shift rot r/m bitor bitor , ;
+    [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
 
 : sib, ( indirect -- )
     dup sib-present? [
-        dup indirect-base*
+        [ indirect-base* ]
-        over indirect-index* 3 shift bitor
+        [ indirect-index* 3 shift ]
-        swap indirect-scale* 6 shift bitor ,
+        [ indirect-scale* 6 shift ] tri bitor bitor ,
     ] [
         drop
     ] if ;
@@ -162,9 +165,9 @@ M: register modifier drop BIN: 11 ;
 GENERIC: displacement, ( op -- )
 
 M: indirect displacement,
-    dup indirect-displacement dup [
+    dup displacement>> dup [
-        swap indirect-base
+        swap base>>
-        [ dup byte? [ , ] [ 4, ] if ] [ 4, ] if
+        [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
     ] [
         2drop
     ] if ;
@@ -172,18 +175,19 @@ M: indirect displacement,
 M: register displacement, drop ;
 
 : addressing ( reg# indirect -- )
-    [ mod-r/m, ] keep [ sib, ] keep displacement, ;
+    [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
 
 ! Utilities
 UNION: operand register indirect ;
 
-: operand-64? ( operand -- ? )
+GENERIC: operand-64? ( operand -- ? )
-    dup indirect? [
+
-        dup indirect-base register-64?
+M: indirect operand-64?
-        swap indirect-index register-64? or
+    [ base>> ] [ index>> ] bi [ operand-64? ] either? ;
-    ] [
+
-        register-64?
+M: register-64 operand-64? drop t ;
-    ] if ;
+
+M: object operand-64? drop f ;
 
 : rex.w? ( rex.w reg r/m -- ? )
     {
@@ -192,14 +196,13 @@ UNION: operand register indirect ;
         [ nip operand-64? ]
     } cond and ;
 
-: rex.r
+: rex.r ( m op -- n )
     extended? [ BIN: 00000100 bitor ] when ;
 
-: rex.b
+: rex.b ( m op -- n )
     [ extended? [ BIN: 00000001 bitor ] when ] keep
     dup indirect? [
-        indirect-index extended?
+        index>> extended? [ BIN: 00000010 bitor ] when
-        [ BIN: 00000010 bitor ] when
     ] [
         drop
     ] if ;
@@ -222,7 +225,7 @@ UNION: operand register indirect ;
     #! the opcode.
     >r dupd prefix-1 reg-code r> + , ;
 
-: opcode, dup array? [ % ] [ , ] if ;
+: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
 
 : extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
 
@@ -230,25 +233,34 @@ UNION: operand register indirect ;
 
 : opcode-or ( opcode mask -- opcode' )
     swap dup array?
-    [ 1 cut* first rot bitor suffix ] [ bitor ] if ;
+    [ unclip-last rot bitor suffix ] [ bitor ] if ;
 
-: 1-operand ( op reg rex.w opcode -- )
+: 1-operand ( op reg,rex.w,opcode -- )
     #! The 'reg' is not really a register, but a value for the
     #! 'reg' field of the mod-r/m byte.
-    >r >r over r> prefix-1 r> opcode, swap addressing ;
+    first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
 
-: immediate-1 ( imm dst reg rex.w opcode -- )
+: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
-    1-operand , ;
+    pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
 
-: immediate-1/4 ( imm dst reg rex.w opcode -- )
+: immediate-1 ( imm dst reg,rex.w,opcode -- )
+    immediate-operand-size-bit 1-operand 1, ;
+
+: immediate-4 ( imm dst reg,rex.w,opcode -- )
+    immediate-operand-size-bit 1-operand 4, ;
+
+: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+    pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
+
+: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
     #! If imm is a byte, compile the opcode and the byte.
-    #! Otherwise, set the 32-bit operand flag in the opcode, and
+    #! Otherwise, set the 8-bit operand flag in the opcode, and
     #! compile the cell. The 'reg' is not really a register, but
     #! a value for the 'reg' field of the mod-r/m byte.
-    >r >r pick byte? [
+    pick fits-in-byte? [
-        r> r> BIN: 10 opcode-or immediate-1
+        immediate-fits-in-size-bit immediate-1
     ] [
-        r> r> 1-operand 4,
+        immediate-4
     ] if ;
 
 : (2-operand) ( dst src op -- )
@@ -283,22 +295,24 @@ PRIVATE>
 ! Moving stuff
 GENERIC: PUSH ( op -- )
 M: register PUSH f HEX: 50 short-operand ;
-M: integer PUSH HEX: 68 , 4, ;
+M: immediate PUSH HEX: 68 , 4, ;
-M: operand PUSH BIN: 110 f HEX: ff 1-operand ;
+M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ;
 
 GENERIC: POP ( op -- )
 M: register POP f HEX: 58 short-operand ;
-M: operand POP BIN: 000 f HEX: 8f 1-operand ;
+M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
 
 ! MOV where the src is immediate.
 GENERIC: (MOV-I) ( src dst -- )
 M: register (MOV-I) t HEX: b8 short-operand cell, ;
-M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ;
+M: operand (MOV-I)
+    { BIN: 000 t HEX: c6 }
+    pick byte? [ immediate-1 ] [ immediate-4 ] if ;
 
 PREDICATE: callable < word register? not ;
 
 GENERIC: MOV ( dst src -- )
-M: integer MOV swap (MOV-I) ;
+M: immediate MOV swap (MOV-I) ;
 M: callable MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
 M: operand MOV HEX: 88 2-operand ;
 
@@ -306,38 +320,38 @@ M: operand MOV HEX: 88 2-operand ;
 
 ! Control flow
 GENERIC: JMP ( op -- )
-: (JMP) HEX: e9 , 0 4, rc-relative ;
+: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
 M: callable JMP (JMP) rel-word ;
 M: label JMP (JMP) label-fixup ;
-M: operand JMP BIN: 100 t HEX: ff 1-operand ;
+M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
 
 GENERIC: CALL ( op -- )
-: (CALL) HEX: e8 , 0 4, rc-relative ;
+: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
 M: callable CALL (CALL) rel-word ;
 M: label CALL (CALL) label-fixup ;
-M: operand CALL BIN: 010 t HEX: ff 1-operand ;
+M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
 
 GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) extended-opcode, 0 4, rc-relative ;
+: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
 M: callable JUMPcc (JUMPcc) rel-word ;
 M: label JUMPcc (JUMPcc) label-fixup ;
 
-: JO  HEX: 80 JUMPcc ;
+: JO  ( dst -- ) HEX: 80 JUMPcc ;
-: JNO HEX: 81 JUMPcc ;
+: JNO ( dst -- ) HEX: 81 JUMPcc ;
-: JB  HEX: 82 JUMPcc ;
+: JB  ( dst -- ) HEX: 82 JUMPcc ;
-: JAE HEX: 83 JUMPcc ;
+: JAE ( dst -- ) HEX: 83 JUMPcc ;
-: JE  HEX: 84 JUMPcc ; ! aka JZ
+: JE  ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
-: JNE HEX: 85 JUMPcc ;
+: JNE ( dst -- ) HEX: 85 JUMPcc ;
-: JBE HEX: 86 JUMPcc ;
+: JBE ( dst -- ) HEX: 86 JUMPcc ;
-: JA  HEX: 87 JUMPcc ;
+: JA  ( dst -- ) HEX: 87 JUMPcc ;
-: JS  HEX: 88 JUMPcc ;
+: JS  ( dst -- ) HEX: 88 JUMPcc ;
-: JNS HEX: 89 JUMPcc ;
+: JNS ( dst -- ) HEX: 89 JUMPcc ;
-: JP  HEX: 8a JUMPcc ;
+: JP  ( dst -- ) HEX: 8a JUMPcc ;
-: JNP HEX: 8b JUMPcc ;
+: JNP ( dst -- ) HEX: 8b JUMPcc ;
-: JL  HEX: 8c JUMPcc ;
+: JL  ( dst -- ) HEX: 8c JUMPcc ;
-: JGE HEX: 8d JUMPcc ;
+: JGE ( dst -- ) HEX: 8d JUMPcc ;
-: JLE HEX: 8e JUMPcc ;
+: JLE ( dst -- ) HEX: 8e JUMPcc ;
-: JG  HEX: 8f JUMPcc ;
+: JG  ( dst -- ) HEX: 8f JUMPcc ;
 
 : LEAVE ( -- ) HEX: c9 , ;
 
@@ -347,57 +361,57 @@ M: label JUMPcc (JUMPcc) label-fixup ;
 ! Arithmetic
 
 GENERIC: ADD ( dst src -- )
-M: integer ADD swap BIN: 000 t HEX: 81 immediate-1/4 ;
+M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
 M: operand ADD OCT: 000 2-operand ;
 
 GENERIC: OR ( dst src -- )
-M: integer OR swap BIN: 001 t HEX: 81 immediate-1/4 ;
+M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
 M: operand OR OCT: 010 2-operand ;
 
 GENERIC: ADC ( dst src -- )
-M: integer ADC swap BIN: 010 t HEX: 81 immediate-1/4 ;
+M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
 M: operand ADC OCT: 020 2-operand ;
 
 GENERIC: SBB ( dst src -- )
-M: integer SBB swap BIN: 011 t HEX: 81 immediate-1/4 ;
+M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
 M: operand SBB OCT: 030 2-operand ;
 
 GENERIC: AND ( dst src -- )
-M: integer AND swap BIN: 100 t HEX: 81 immediate-1/4 ;
+M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
 M: operand AND OCT: 040 2-operand ;
 
 GENERIC: SUB ( dst src -- )
-M: integer SUB swap BIN: 101 t HEX: 81 immediate-1/4 ;
+M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
 M: operand SUB OCT: 050 2-operand ;
 
 GENERIC: XOR ( dst src -- )
-M: integer XOR swap BIN: 110 t HEX: 81 immediate-1/4 ;
+M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
 M: operand XOR OCT: 060 2-operand ;
 
 GENERIC: CMP ( dst src -- )
-M: integer CMP swap BIN: 111 t HEX: 81 immediate-1/4 ;
+M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
 M: operand CMP OCT: 070 2-operand ;
 
-: NOT  ( dst -- ) BIN: 010 t HEX: f7 1-operand ;
+: NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
-: NEG  ( dst -- ) BIN: 011 t HEX: f7 1-operand ;
+: NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
-: MUL  ( dst -- ) BIN: 100 t HEX: f7 1-operand ;
+: MUL  ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
-: IMUL ( src -- ) BIN: 101 t HEX: f7 1-operand ;
+: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
-: DIV  ( dst -- ) BIN: 110 t HEX: f7 1-operand ;
+: DIV  ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
-: IDIV ( src -- ) BIN: 111 t HEX: f7 1-operand ;
+: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
 
-: CDQ HEX: 99 , ;
+: CDQ ( -- ) HEX: 99 , ;
-: CQO HEX: 48 , CDQ ;
+: CQO ( -- ) HEX: 48 , CDQ ;
 
-: ROL ( dst n -- ) swap BIN: 000 t HEX: c1 immediate-1 ;
+: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
-: ROR ( dst n -- ) swap BIN: 001 t HEX: c1 immediate-1 ;
+: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
-: RCL ( dst n -- ) swap BIN: 010 t HEX: c1 immediate-1 ;
+: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
-: RCR ( dst n -- ) swap BIN: 011 t HEX: c1 immediate-1 ;
+: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
-: SHL ( dst n -- ) swap BIN: 100 t HEX: c1 immediate-1 ;
+: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
-: SHR ( dst n -- ) swap BIN: 101 t HEX: c1 immediate-1 ;
+: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
-: SAR ( dst n -- ) swap BIN: 111 t HEX: c1 immediate-1 ;
+: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
 
 GENERIC: IMUL2 ( dst src -- )
-M: integer IMUL2 swap dup reg-code t HEX: 69 immediate-1/4 ;
+M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
 M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
 
 : MOVSX ( dst src -- )
@@ -409,34 +423,34 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
 ! Conditional move
 : MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
 
-: CMOVO  HEX: 40 MOVcc ;
+: CMOVO  ( dst src -- ) HEX: 40 MOVcc ;
-: CMOVNO HEX: 41 MOVcc ;
+: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
-: CMOVB  HEX: 42 MOVcc ;
+: CMOVB  ( dst src -- ) HEX: 42 MOVcc ;
-: CMOVAE HEX: 43 MOVcc ;
+: CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
-: CMOVE  HEX: 44 MOVcc ; ! aka CMOVZ
+: CMOVE  ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
-: CMOVNE HEX: 45 MOVcc ;
+: CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
-: CMOVBE HEX: 46 MOVcc ;
+: CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
-: CMOVA  HEX: 47 MOVcc ;
+: CMOVA  ( dst src -- ) HEX: 47 MOVcc ;
-: CMOVS  HEX: 48 MOVcc ;
+: CMOVS  ( dst src -- ) HEX: 48 MOVcc ;
-: CMOVNS HEX: 49 MOVcc ;
+: CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
-: CMOVP  HEX: 4a MOVcc ;
+: CMOVP  ( dst src -- ) HEX: 4a MOVcc ;
-: CMOVNP HEX: 4b MOVcc ;
+: CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
-: CMOVL  HEX: 4c MOVcc ;
+: CMOVL  ( dst src -- ) HEX: 4c MOVcc ;
-: CMOVGE HEX: 4d MOVcc ;
+: CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
-: CMOVLE HEX: 4e MOVcc ;
+: CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
-: CMOVG  HEX: 4f MOVcc ;
+: CMOVG  ( dst src -- ) HEX: 4f MOVcc ;
 
 ! CPU Identification
 
-: CPUID HEX: a2 extended-opcode, ;
+: CPUID ( -- ) HEX: a2 extended-opcode, ;
 
 ! x87 Floating Point Unit
 
-: FSTPS ( operand -- ) BIN: 011 f HEX: d9 1-operand ;
+: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
-: FSTPL ( operand -- ) BIN: 011 f HEX: dd 1-operand ;
+: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
 
-: FLDS ( operand -- ) BIN: 000 f HEX: d9 1-operand ;
+: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
-: FLDL ( operand -- ) BIN: 000 f HEX: dd 1-operand ;
+: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
 
 ! SSE multimedia instructions
 

core/cpu/x86/bootstrap.factor

@@ -60,7 +60,7 @@ big-endian off
     arg0 \ f tag-number CMP                    ! compare it with f
     arg0 arg1 [] CMOVNE                        ! load true branch if not equal
     arg0 arg1 bootstrap-cell [+] CMOVE         ! load false branch if equal
-    arg0 quot-xt@ [+] JMP                      ! jump to quotation-xt
+    arg0 quot-xt-offset [+] JMP                ! jump to quotation-xt
 ] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
 
 [
@@ -70,8 +70,8 @@ big-endian off
     fixnum>slot@                               ! turn it into an array offset
     ds-reg bootstrap-cell SUB                  ! pop index
     arg0 arg1 ADD                              ! compute quotation location
-    arg0 arg0 array-start [+] MOV              ! load quotation
+    arg0 arg0 array-start-offset [+] MOV       ! load quotation
-    arg0 quot-xt@ [+] JMP                      ! execute branch
+    arg0 quot-xt-offset [+] JMP                ! execute branch
 ] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
 
 [

core/cpu/x86/intrinsics/intrinsics.factor

@@ -20,16 +20,16 @@ IN: cpu.x86.intrinsics
 } define-intrinsic
 
 ! Slots
-: %slot-literal-known-tag
+: %slot-literal-known-tag ( -- op )
     "obj" operand
     "n" get cells
     "obj" get operand-tag - [+] ;
 
-: %slot-literal-any-tag
+: %slot-literal-any-tag ( -- op )
     "obj" operand %untag
     "obj" operand "n" get cells [+] ;
 
-: %slot-any
+: %slot-any ( -- op )
     "obj" operand %untag
     "n" operand fixnum>slot@
     "obj" operand "n" operand [+] ;
@@ -63,9 +63,15 @@ IN: cpu.x86.intrinsics
 : generate-write-barrier ( -- )
     #! Mark the card pointed to by vreg.
     "val" get operand-immediate? "obj" get fresh-object? or [
+        ! Mark the card
         "obj" operand card-bits SHR
         "cards_offset" f temp-reg v>operand %alien-global
-        temp-reg v>operand "obj" operand [+] card-mark OR
+        temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
+
+        ! Mark the card deck
+        "obj" operand deck-bits card-bits - SHR
+        "decks_offset" f temp-reg v>operand %alien-global
+        temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
     ] unless ;
 
 \ set-slot {
@@ -393,15 +399,15 @@ IN: cpu.x86.intrinsics
         { +clobber+ { "offset" } }
     } ;
 
-: define-getter
+: define-getter ( word quot reg -- )
     [ %alien-integer-get ] 2curry
     alien-integer-get-template
     define-intrinsic ;
 
-: define-unsigned-getter
+: define-unsigned-getter ( word reg -- )
     [ small-reg dup XOR MOV ] swap define-getter ;
 
-: define-signed-getter
+: define-signed-getter ( word reg -- )
     [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
 
 : %alien-integer-set ( quot reg -- )
@@ -423,7 +429,7 @@ IN: cpu.x86.intrinsics
         { +clobber+ { "value" "offset" } }
     } ;
 
-: define-setter
+: define-setter ( word reg -- )
     [ swap MOV ] swap
     [ %alien-integer-set ] 2curry
     alien-integer-set-template

core/debugger/debugger-docs.factor

@@ -1,7 +1,7 @@
 USING: alien arrays generic generic.math help.markup help.syntax
 kernel math memory strings sbufs vectors io io.files classes
 help generic.standard continuations system debugger.private
-io.files.private ;
+io.files.private listener ;
 IN: debugger
 
 ARTICLE: "errors-assert" "Assertions"
@@ -64,7 +64,7 @@ HELP: :3
 
 HELP: error.
 { $values { "error" "an error" } }
-{ $contract "Print an error to the " { $link stdio } " stream.  You can define methods on this generic word to print human-readable messages for custom errors." }
+{ $contract "Print an error to " { $link output-stream } ". You can define methods on this generic word to print human-readable messages for custom errors." }
 { $notes "Code should call " { $link print-error } " instead, which handles the case where the printing of the error itself throws an error." } ;
 
 HELP: error-help
@@ -75,19 +75,15 @@ HELP: error-help
 
 HELP: print-error
 { $values { "error" "an error" } }
-{ $description "Print an error to the " { $link stdio } " stream." }
+{ $description "Print an error to " { $link output-stream } "." }
 { $notes "This word is called by the listener and other tools which report caught errors to the user." } ;
 
 HELP: restarts.
-{ $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ;
+{ $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
-
-HELP: error-hook
-{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
-{ $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
 
 HELP: try
 { $values { "quot" "a quotation" } }
-{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
+{ $description "Attempts to call a quotation; if it throws an error, the error is printed to " { $link output-stream } ", stacks are restored, and execution continues after the call to " { $link try } "." }
 { $examples
     "The following example prints an error and keeps going:"
     { $code

core/debugger/debugger.factor

@@ -1,12 +1,13 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays definitions generic hashtables inspector io kernel
-math namespaces prettyprint sequences assocs sequences.private
+math namespaces prettyprint prettyprint.config sequences assocs
-strings io.styles vectors words system splitting math.parser
+sequences.private strings io.styles vectors words system
-classes.tuple continuations continuations.private combinators
+splitting math.parser classes.tuple continuations
-generic.math io.streams.duplex classes.builtin classes
+continuations.private combinators generic.math
-compiler.units generic.standard vocabs threads threads.private
+classes.builtin classes compiler.units generic.standard vocabs
-init kernel.private libc io.encodings mirrors accessors ;
+threads threads.private init kernel.private libc io.encodings
+mirrors accessors math.order destructors ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -35,12 +36,12 @@ M: string error. print ;
 : :vars ( -- )
     error-continuation get continuation-name namestack. ;
 
-: :res ( n -- )
+: :res ( n -- * )
     1- restarts get-global nth f restarts set-global restart ;
 
-: :1 1 :res ;
+: :1 ( -- * ) 1 :res ;
-: :2 2 :res ;
+: :2 ( -- * ) 2 :res ;
-: :3 3 :res ;
+: :3 ( -- * ) 3 :res ;
 
 : restart. ( restart n -- )
     [
@@ -63,17 +64,14 @@ M: string error. print ;
     [ global [ "Error in print-error!" print drop ] bind ]
     recover ;
 
-SYMBOL: error-hook
+: print-error-and-restarts ( error -- )
-
-[
     print-error
     restarts.
     nl
-    "Type :help for debugging help." print flush
+    "Type :help for debugging help." print flush ;
-] error-hook set-global
 
 : try ( quot -- )
-    [ error-hook get call ] recover ;
+    [ print-error-and-restarts ] recover ;
 
 ERROR: assert got expect ;
 
@@ -95,11 +93,11 @@ M: relative-overflow summary
     drop "Superfluous items pushed to data stack" ;
 
 : assert-depth ( quot -- )
-    >r datastack r> swap slip >r datastack r>
+    >r datastack r> dip >r datastack r>
-    2dup [ length ] compare sgn {
+    2dup [ length ] compare {
-        { -1 [ trim-datastacks nip relative-underflow ] }
+        { +lt+ [ trim-datastacks nip relative-underflow ] }
-        { 0 [ 2drop ] }
+        { +eq+ [ 2drop ] }
-        { 1 [ trim-datastacks drop relative-overflow ] }
+        { +gt+ [ trim-datastacks drop relative-overflow ] }
     } case ; inline
 
 : expired-error. ( obj -- )
@@ -145,15 +143,15 @@ M: relative-overflow summary
 : stack-overflow. ( obj name -- )
     write " stack overflow" print drop ;
 
-: datastack-underflow. "Data" stack-underflow. ;
+: datastack-underflow. ( obj -- ) "Data" stack-underflow. ;
-: datastack-overflow. "Data" stack-overflow. ;
+: datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
-: retainstack-underflow. "Retain" stack-underflow. ;
+: retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
-: retainstack-overflow. "Retain" stack-overflow. ;
+: retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ;
 
-: memory-error.
+: memory-error. ( error -- )
     "Memory protection fault at address " write third .h ;
 
-: primitive-error.
+: primitive-error. ( error -- ) 
     "Unimplemented primitive" print drop ;
 
 PREDICATE: kernel-error < array
@@ -163,7 +161,7 @@ PREDICATE: kernel-error < array
         [ second 0 15 between? ]
     } cond ;
 
-: kernel-errors
+: kernel-errors ( error -- n errors )
     second {
         { 0  [ expired-error.          ] }
         { 1  [ io-error.               ] }
@@ -208,9 +206,6 @@ M: no-next-method summary
 M: inconsistent-next-method summary
     drop "Executing call-next-method with inconsistent parameters" ;
 
-M: stream-closed-twice summary
-    drop "Attempt to perform I/O on closed stream" ;
-
 M: check-method summary
     drop "Invalid parameters for create-method" ;
 
@@ -240,6 +235,15 @@ M: condition error-help error>> error-help ;
 
 M: assert summary drop "Assertion failed" ;
 
+M: assert error.
+    "Assertion failed" print
+    standard-table-style [
+        15 length-limit set
+        5 line-limit set
+        [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
+        [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
+    ] tabular-output ;
+
 M: immutable summary drop "Sequence is immutable" ;
 
 M: redefine-error error.
@@ -266,8 +270,7 @@ M: double-free summary
 M: realloc-error summary
     drop "Memory reallocation failed" ;
 
-: error-in-thread. ( -- )
+: error-in-thread. ( thread -- )
-    error-thread get-global
     "Error in thread " write
     [
         dup thread-id #
@@ -281,7 +284,7 @@ M: thread error-in-thread ( error thread -- )
         die drop
     ] [
         global [
-            error-in-thread. print-error flush
+            error-thread get-global error-in-thread. print-error flush
         ] bind
     ] if ;
 
@@ -293,6 +296,12 @@ M: no-such-slot summary drop "No such slot" ;
 
 M: immutable-slot summary drop "Slot is immutable" ;
 
+M: bad-create summary drop "Bad parameters to create" ;
+
+M: attempt-all-error summary drop "Nothing to attempt" ;
+
+M: already-disposed summary drop "Attempting to operate on disposed object" ;
+
 <PRIVATE
 
 : init-debugger ( -- )

core/definitions/definitions-tests.factor

@@ -1,6 +1,6 @@
-IN: definitions.tests
 USING: tools.test generic kernel definitions sequences
 compiler.units words ;
+IN: definitions.tests
 
 GENERIC: some-generic ( a -- b )
 

core/definitions/definitions.factor

@@ -7,10 +7,21 @@ ERROR: no-compilation-unit definition ;
 
 SYMBOL: changed-definitions
 
-: changed-definition ( defspec -- )
+SYMBOL: +inlined+
-    dup changed-definitions get
+SYMBOL: +called+
-    [ no-compilation-unit ] unless*
+
-    set-at ;
+: changed-definition ( defspec how -- )
+    swap changed-definitions get
+    [ set-at ] [ no-compilation-unit ] if* ;
+
+SYMBOL: new-classes
+
+: new-class ( word -- )
+    dup new-classes get
+    [ set-at ] [ no-compilation-unit ] if* ;
+
+: new-class? ( word -- ? )
+    new-classes get key? ;
 
 GENERIC: where ( defspec -- loc )
 
@@ -47,7 +58,17 @@ M: object uses drop f ;
 
 : xref ( defspec -- ) dup uses crossref get add-vertex ;
 
-: usage ( defspec -- seq ) \ f or crossref get at keys ;
+: usage ( defspec -- seq ) crossref get at keys ;
+
+GENERIC: irrelevant? ( defspec -- ? )
+
+M: object irrelevant? drop f ;
+
+GENERIC: smart-usage ( defspec -- seq )
+
+M: f smart-usage drop \ f smart-usage ;
+
+M: object smart-usage usage [ irrelevant? not ] filter ;
 
 : unxref ( defspec -- )
     dup uses crossref get remove-vertex ;

core/destructors/destructors-docs.factor

@@ -0,0 +1,71 @@
+USING: help.markup help.syntax libc kernel continuations io ;
+IN: destructors
+
+HELP: dispose
+{ $values { "disposable" "a disposable object" } }
+{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
+$nl
+"No further operations can be performed on a disposable object after this call."
+$nl
+"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
+{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
+$nl
+"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ;
+
+HELP: dispose*
+{ $values { "disposable" "a disposable object" } }
+{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." }
+{ $notes
+    "This word should not be called directly. It can be implemented on objects with a " { $snippet "disposable" } " slot to ensure that the object is only disposed once."
+} ;
+
+HELP: with-disposal
+{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
+{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
+
+HELP: with-destructors
+{ $values { "quot" "a quotation" } }
+{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type.  After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown.  However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
+{ $notes
+    "Destructors generalize " { $link with-disposal } ". The following two lines are equivalent, except that the second line establishes a new dynamic scope:"
+    { $code
+        "[ X ] with-disposal"
+        "[ &dispose X ] with-destructors"
+    }
+}
+{ $examples
+    { $code "[ 10 malloc &free ] with-destructors" }
+} ;
+
+HELP: &dispose
+{ $values { "disposable" "a disposable object" } }
+{ $description "Marks the object for unconditional disposal at the end of the current " { $link with-destructors } " scope." } ;
+
+HELP: |dispose
+{ $values { "disposable" "a disposable object" } }
+{ $description "Marks the object for disposal in the event of an error at the end of the current " { $link with-destructors } " scope." } ;
+
+ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns"
+"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
+{ $code
+    "<external-resource> ... do stuff ... dispose"
+}
+"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ;
+
+ARTICLE: "destructors" "Deterministic resource disposal"
+"Operating system resources such as streams, memory mapped files, and so on are not managed by Factor's garbage collector and must be released when you are done with them. Failing to release a resource can lead to reduced performance and instability."
+$nl
+"Disposable object protocol:"
+{ $subsection dispose }
+{ $subsection dispose* }
+"Utility word for scoped disposal:"
+{ $subsection with-disposal }
+"Utility word for disposing multiple objects:"
+{ $subsection dispose-each }
+"Utility words for more complex disposal patterns:"
+{ $subsection with-destructors }
+{ $subsection &dispose }
+{ $subsection |dispose }
+{ $subsection "destructors-anti-patterns" } ;
+
+ABOUT: "destructors"

core/destructors/destructors-tests.factor

@@ -1,6 +1,24 @@
-USING: destructors kernel tools.test continuations ;
+USING: destructors kernel tools.test continuations accessors
+namespaces sequences ;
 IN: destructors.tests
 
+TUPLE: dispose-error ;
+
+M: dispose-error dispose 3 throw ;
+
+TUPLE: dispose-dummy disposed? ;
+
+M: dispose-dummy dispose t >>disposed? drop ;
+
+T{ dispose-error } "a" set
+T{ dispose-dummy } "b" set
+
+[ f ] [ "b" get disposed?>> ] unit-test
+
+[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
+
+[ t ] [ "b" get disposed?>> ] unit-test
+
 TUPLE: dummy-obj destroyed? ;
 
 : <dummy-obj> dummy-obj new ;
@@ -13,10 +31,10 @@ M: dummy-destructor dispose ( obj -- )
     dummy-destructor-obj t swap set-dummy-obj-destroyed? ;
 
 : destroy-always
-    <dummy-destructor> add-always-destructor ;
+    <dummy-destructor> &dispose drop ;
 
 : destroy-later
-    <dummy-destructor> add-error-destructor ;
+    <dummy-destructor> |dispose drop ;
 
 [ t ] [
     [

core/destructors/destructors.factor

@@ -0,0 +1,56 @@
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors continuations kernel namespaces
+sequences vectors ;
+IN: destructors
+
+TUPLE: disposable disposed ;
+
+GENERIC: dispose* ( disposable -- )
+
+ERROR: already-disposed disposable ;
+
+: check-disposed ( disposable -- )
+    dup disposed>> [ already-disposed ] [ drop ] if ; inline
+
+GENERIC: dispose ( disposable -- )
+
+M: object dispose
+    dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
+
+: dispose-each ( seq -- )
+    [
+        [ [ dispose ] curry [ , ] recover ] each
+    ] { } make dup empty? [ drop ] [ peek rethrow ] if ;
+
+: with-disposal ( object quot -- )
+    over [ dispose ] curry [ ] cleanup ; inline
+
+<PRIVATE
+
+SYMBOL: always-destructors
+
+SYMBOL: error-destructors
+
+: do-always-destructors ( -- )
+    always-destructors get <reversed> dispose-each ;
+
+: do-error-destructors ( -- )
+    error-destructors get <reversed> dispose-each ;
+
+PRIVATE>
+
+: &dispose ( disposable -- disposable )
+    dup always-destructors get push ; inline
+
+: |dispose ( disposable -- disposable )
+    dup error-destructors get push ; inline
+
+: with-destructors ( quot -- )
+    [
+        V{ } clone always-destructors set
+        V{ } clone error-destructors set
+        [ do-always-destructors ]
+        [ do-error-destructors ]
+        cleanup
+    ] with-scope ; inline

core/dlists/dlists-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax kernel quotations ;
+USING: help.markup help.syntax kernel quotations dlists.private ;
 IN: dlists
 
 ARTICLE: "dlists" "Doubly-linked lists"
@@ -51,38 +51,52 @@ HELP: dlist-empty?
 HELP: push-front
 { $values { "obj" "an object" } { "dlist" dlist } }
 { $description "Push the object onto the front of the " { $link dlist } "." } 
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-back pop-front pop-front* pop-back pop-back* } ;
+
+HELP: push-front*
+{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
+{ $description "Push the object onto the front of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." } 
+{ $notes "This operation is O(1)." } ;
 
 HELP: push-back
 { $values { "obj" "an object" } { "dlist" dlist } }
 { $description "Push the object onto the back of the " { $link dlist } "." } 
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-front pop-front pop-front* pop-back pop-back* } ;
+
+HELP: push-back*
+{ $values { "obj" "an object" } { "dlist" dlist } { "dlist-node" dlist-node } }
+{ $description "Push the object onto the back of the " { $link dlist } " and return the newly created " { $snippet "dlist-node" } "." } 
+{ $notes "This operation is O(1)." } ;
+
+HELP: peek-front
+{ $values { "dlist" dlist } { "obj" "an object" } }
+{ $description "Returns the object at the front of the " { $link dlist } "." } ;
 
 HELP: pop-front
 { $values { "dlist" dlist } { "obj" "an object" } }
 { $description "Pop the object off the front of the " { $link dlist } " and return the object." }
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-front push-back pop-front* pop-back pop-back* } ;
 
 HELP: pop-front*
 { $values { "dlist" dlist } }
 { $description "Pop the object off the front of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-front push-back pop-front pop-back pop-back* } ;
+
+HELP: peek-back
+{ $values { "dlist" dlist } { "obj" "an object" } }
+{ $description "Returns the object at the back of the " { $link dlist } "." } ;
 
 HELP: pop-back
 { $values { "dlist" dlist } { "obj" "an object" } }
 { $description "Pop the object off the back of the " { $link dlist } " and return the object." }
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-front push-back pop-front pop-front* pop-back* } ;
 
 HELP: pop-back*
 { $values { "dlist" dlist } }
 { $description "Pop the object off the back of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." }
+{ $notes "This operation is O(1)." } ;
-{ $see-also push-front push-back pop-front pop-front* pop-back } ;
+
+{ push-front push-front* push-back push-back* peek-front pop-front pop-front* peek-back pop-back pop-back* } related-words
 
 HELP: dlist-find
 { $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }

core/dlists/dlists-tests.factor

@@ -1,6 +1,6 @@
 USING: dlists dlists.private kernel tools.test random assocs
 sets sequences namespaces sorting debugger io prettyprint
-math ;
+math accessors classes ;
 IN: dlists.tests
 
 [ t ] [ <dlist> dlist-empty? ] unit-test
@@ -65,21 +65,18 @@ IN: dlists.tests
 : assert-same-elements
     [ prune natural-sort ] bi@ assert= ;
 
-: dlist-push-all [ push-front ] curry each ;
-
 : dlist-delete-all [ dlist-delete drop ] curry each ;
 
 : dlist>array [ [ , ] dlist-slurp ] { } make ;
 
 [ ] [
     5 [ drop 30 random >fixnum ] map prune
-    6 [ drop 30 random >fixnum ] map prune 2dup nl . . nl
+    6 [ drop 30 random >fixnum ] map prune [
-    [
         <dlist>
-        [ dlist-push-all ] keep
+        [ push-all-front ]
-        [ dlist-delete-all ] keep
+        [ dlist-delete-all ]
-        dlist>array
+        [ dlist>array ] tri
-    ] 2keep diff assert-same-elements
+    ] 2keep swap diff assert-same-elements
 ] unit-test
 
 [ ] [
@@ -95,3 +92,13 @@ IN: dlists.tests
 
 [ 1 ] [ "d" get dlist-length ] unit-test
 [ 1 ] [ "d" get dlist>array length ] unit-test
+
+[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test
+[ t ] [ <dlist> 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test
+[ t ] [ <dlist> 4 over push-back 5 over push-back* [ = ] curry dlist-find-node drop class dlist-node = ] unit-test
+[ ] [ <dlist> 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test
+
+[ <dlist> peek-front ] must-fail
+[ <dlist> peek-back ] must-fail
+[ <dlist> pop-front ] [ empty-dlist? ] must-fail-with
+[ <dlist> pop-back ] [ empty-dlist? ] must-fail-with

core/dlists/dlists.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math sequences accessors ;
+USING: combinators kernel math sequences accessors inspector ;
 IN: dlists
 
 TUPLE: dlist front back length ;
@@ -47,7 +47,7 @@ C: <dlist-node> dlist-node
 
 : (dlist-find-node) ( dlist-node quot -- node/f ? )
     over [
-        [ >r obj>> r> call ] 2keep rot
+        [ call ] 2keep rot
         [ drop t ] [ >r next>> r> (dlist-find-node) ] if
     ] [ 2drop f f ] if ; inline
 
@@ -55,7 +55,7 @@ C: <dlist-node> dlist-node
     >r front>> r> (dlist-find-node) ; inline
 
 : dlist-each-node ( dlist quot -- )
-    [ t ] compose dlist-find-node 2drop ; inline
+    [ f ] compose dlist-find-node 2drop ; inline
 
 PRIVATE>
 
@@ -84,11 +84,17 @@ PRIVATE>
 : push-all-back ( seq dlist -- )
     [ push-back ] curry each ;
 
+ERROR: empty-dlist ;
+
+M: empty-dlist summary ( dlist -- )
+    drop "Emtpy dlist" ;
+
 : peek-front ( dlist -- obj )
-    front>> obj>> ;
+    front>> [ empty-dlist ] unless* obj>> ;
 
 : pop-front ( dlist -- obj )
-    dup front>> [
+    dup front>> [ empty-dlist ] unless*
+    [
         dup next>>
         f rot (>>next)
         f over set-prev-when
@@ -96,13 +102,15 @@ PRIVATE>
     ] 2keep obj>>
     swap [ normalize-back ] keep dec-length ;
 
-: pop-front* ( dlist -- ) pop-front drop ;
+: pop-front* ( dlist -- )
+    pop-front drop ;
 
 : peek-back ( dlist -- obj )
-    back>> obj>> ;
+    back>> [ empty-dlist ] unless* obj>> ;
 
 : pop-back ( dlist -- obj )
-    dup back>> [
+    dup back>> [ empty-dlist ] unless*
+    [
         dup prev>>
         f rot (>>prev)
         f over set-next-when
@@ -110,9 +118,11 @@ PRIVATE>
     ] 2keep obj>>
     swap [ normalize-front ] keep dec-length ;
 
-: pop-back* ( dlist -- ) pop-back drop ;
+: pop-back* ( dlist -- )
+    pop-back drop ;
 
 : dlist-find ( dlist quot -- obj/f ? )
+    [ obj>> ] prepose
     dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
 
 : dlist-contains? ( dlist quot -- ? )
@@ -141,6 +151,7 @@ PRIVATE>
     ] if ; inline
 
 : delete-node-if ( dlist quot -- obj/f )
+    [ obj>> ] prepose
     delete-node-if* drop ; inline
 
 : dlist-delete ( obj dlist -- obj/f )
@@ -153,7 +164,7 @@ PRIVATE>
     drop ;
 
 : dlist-each ( dlist quot -- )
-    [ obj>> ] swap compose dlist-each-node ; inline
+    [ obj>> ] prepose dlist-each-node ; inline
 
 : dlist-slurp ( dlist quot -- )
     over dlist-empty?

core/effects/effects-docs.factor

@@ -2,7 +2,9 @@ USING: help.markup help.syntax math strings words ;
 IN: effects
 
 ARTICLE: "effect-declaration" "Stack effect declaration"
-"It is good practice to declare the stack effects of words using the following syntax:"
+"Stack effects of words must be declared, with the exception of words which only push literals on the stack."
+$nl
+"Stack effects are declared with the following syntax:"
 { $code ": sq ( x -- y ) dup * ;" }
 "A stack effect declaration is written in parentheses and lists word inputs and outputs, separated by " { $snippet "--" } ". Stack effect declarations are read in using a parsing word:"
 { $subsection POSTPONE: ( }
@@ -28,18 +30,21 @@ $nl
 ARTICLE: "effects" "Stack effects"
 "A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output."
 $nl
+"Stack effects of words can be declared."
+{ $subsection "effect-declaration" }
 "Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary."
 { $subsection effect }
 { $subsection effect? }
-"Stack effects of words can be declared."
+"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } "."
-{ $subsection "effect-declaration" }
+{ $subsection POSTPONE: (( }
 "Getting a word's declared stack effect:"
 { $subsection stack-effect }
 "Converting a stack effect to a string form:"
 { $subsection effect>string }
 "Comparing effects:"
 { $subsection effect-height }
-{ $subsection effect<= } ;
+{ $subsection effect<= }
+{ $see-also "inference" } ;
 
 ABOUT: "effects"
 

core/effects/effects-tests.factor

@@ -1,9 +1,17 @@
 IN: effects.tests
-USING: effects tools.test ;
+USING: effects tools.test prettyprint accessors sequences ;
 
 [ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
 [ f ] [ 1 0 <effect> 2 2 <effect> effect<= ] unit-test
 [ t ] [ 2 2 <effect> 2 2 <effect> effect<= ] unit-test
 [ f ] [ 3 3 <effect> 2 2 <effect> effect<= ] unit-test
 [ f ] [ 2 3 <effect> 2 2 <effect> effect<= ] unit-test
-[ t ] [ 2 3 <effect> f effect<= ] unit-test
+[ 2 ] [ (( a b -- c )) in>> length ] unit-test
+[ 1 ] [ (( a b -- c )) out>> length ] unit-test
+
+
+[ "(( a b -- c d ))" ] [ { "a" "b" } { "c" "d" } <effect> unparse ] unit-test
+[ "(( -- c d ))" ] [ { } { "c" "d" } <effect> unparse ] unit-test
+[ "(( a b -- ))" ] [ { "a" "b" } { } <effect> unparse ] unit-test
+[ "(( -- ))" ] [ { } { } <effect> unparse ] unit-test
+[ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test

core/effects/effects.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math namespaces sequences strings words assocs
-combinators ;
+combinators accessors ;
 IN: effects
 
 TUPLE: effect in out terminated? ;
@@ -11,14 +11,13 @@ TUPLE: effect in out terminated? ;
     effect boa ;
 
 : effect-height ( effect -- n )
-    dup effect-out length swap effect-in length - ;
+    [ out>> length ] [ in>> length ] bi - ;
 
 : effect<= ( eff1 eff2 -- ? )
     {
-        { [ dup not ] [ t ] }
+        { [ over terminated?>> ] [ t ] }
-        { [ over effect-terminated? ] [ t ] }
+        { [ dup terminated?>> ] [ f ] }
-        { [ dup effect-terminated? ] [ f ] }
+        { [ 2dup [ in>> length ] bi@ > ] [ f ] }
-        { [ 2dup [ effect-in length ] bi@ > ] [ f ] }
         { [ 2dup [ effect-height ] bi@ = not ] [ f ] }
         [ t ]
     } cond 2nip ;
@@ -34,10 +33,10 @@ M: integer (stack-picture) drop "object" ;
 : effect>string ( effect -- string )
     [
         "( " %
-        dup effect-in stack-picture %
+        [ in>> stack-picture % "-- " % ]
-        "-- " %
+        [ out>> stack-picture % ]
-        dup effect-out stack-picture %
+        [ terminated?>> [ "* " % ] when ]
-        effect-terminated? [ "* " % ] when
+        tri
         ")" %
     ] "" make ;
 
@@ -50,16 +49,16 @@ M: word stack-effect
     swap word-props [ at ] curry map [ ] find nip ;
 
 M: effect clone
-    [ effect-in clone ] keep effect-out clone <effect> ;
+    [ in>> clone ] keep effect-out clone <effect> ;
 
 : split-shuffle ( stack shuffle -- stack1 stack2 )
-    effect-in length cut* ;
+    in>> length cut* ;
 
 : load-shuffle ( stack shuffle -- )
-    effect-in [ set ] 2each ;
+    in>> [ set ] 2each ;
 
 : shuffled-values ( shuffle -- values )
-    effect-out [ get ] map ;
+    out>> [ get ] map ;
 
 : shuffle* ( stack shuffle -- newstack )
     [ [ load-shuffle ] keep shuffled-values ] with-scope ;