diff --git a/Factor.app/Contents/Info.plist b/Factor.app/Contents/Info.plist
index ca0e6d5f8a..a8943d0d32 100644
--- a/Factor.app/Contents/Info.plist
+++ b/Factor.app/Contents/Info.plist
@@ -32,7 +32,7 @@
CFBundlePackageType
APPL
NSHumanReadableCopyright
- Copyright © 2003-2007, Slava Pestov and friends
+ Copyright © 2003-2008, Slava Pestov and friends
NSServices
diff --git a/build-support/factor.sh b/build-support/factor.sh
index 70c522f6cd..c60ab46671 100755
--- a/build-support/factor.sh
+++ b/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
}
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 7d13080e3c..0caf0e9a9f 100755
--- a/core/alien/alien-docs.factor
+++ b/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? }
diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor
index 3cd5afef33..8da030c7d1 100755
--- a/core/alien/c-types/c-types-docs.factor
+++ b/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:
{ $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:"
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index f67fc78259..87fa553dc3 100755
--- a/core/alien/c-types/c-types.factor
+++ b/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:
@@ -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
diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor
index 5d847e364f..eb7652aefd 100755
--- a/core/alien/compiler/compiler-tests.factor
+++ b/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 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 ;
diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor
index 3de4c61291..ac1895e37e 100755
--- a/core/alien/compiler/compiler.factor
+++ b/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 ] curry
- f infer-quot ;
+ xt>> [ [ register-callback ] [ word-xt drop ] bi ] curry
+ 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
diff --git a/core/alien/remote-control/remote-control.factor b/core/alien/remote-control/remote-control.factor
index 1d713f6edd..027663a645 100755
--- a/core/alien/remote-control/remote-control.factor
+++ b/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 )
diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor
old mode 100644
new mode 100755
index d69d8e9e8e..827d478d06
--- a/core/alien/strings/strings.factor
+++ b/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
diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor
index e7e576293f..baf0b40707 100755
--- a/core/alien/structs/structs-docs.factor
+++ b/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 } " or " { $link malloc-object } "."
+"C union objects can be allocated by calling " { $link } " or " { $link malloc-object } "."
$nl
"Arrays of C unions can be created by calling " { $link } " 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: } "." ;
diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor
index f0f495cac9..def5b02ba0 100755
--- a/core/alien/syntax/syntax.factor
+++ b/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:
diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index 863fdaecb3..b33773cf9e 100755
--- a/core/assocs/assocs-docs.factor
+++ b/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." }
-{ $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." } ;
+{ $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." } ;
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" } }
diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index 76f484006d..43a1bac82d 100755
--- a/core/assocs/assocs-tests.factor
+++ b/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
-[ f ] [ H{ { 1 3 } } H{ } subassoc? ] unit-test
-[ t ] [ H{ } H{ { 1 3 } } subassoc? ] unit-test
-[ t ] [ H{ { 1 3 } } H{ { 1 3 } } subassoc? ] unit-test
-[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } subassoc? ] unit-test
-[ f ] [ H{ { 1 f } } H{ } subassoc? ] unit-test
-[ t ] [ H{ { 1 f } } H{ { 1 f } } subassoc? ] unit-test
+[ t ] [ H{ } dup assoc-subset? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
+[ t ] [ H{ } H{ { 1 3 } } assoc-subset? ] unit-test
+[ t ] [ H{ { 1 3 } } H{ { 1 3 } } assoc-subset? ] unit-test
+[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } assoc-subset? ] unit-test
+[ f ] [ H{ { 1 f } } H{ } assoc-subset? ] 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
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 4a6ecae4fe..15afce3e93 100755
--- a/core/assocs/assocs.factor
+++ b/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
-
-M: assoc assoc-find
- >r >alist [ first2 ] r> compose find swap
- [ first2 t ] [ drop f f f ] if ;
+: assoc-find ( assoc quot -- key value ? )
+ >r >alist r> [ first2 ] prepose find swap
+ [ first2 t ] [ drop f f f ] if ; inline
: 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 ;
diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor
index da3c634ebd..5480bac4f5 100755
--- a/core/bootstrap/compiler/compiler.factor
+++ b/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
-} compile
+ + 1+ 1- 2/ < <= > >= shift
+} 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
diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor
index ae5c66a45c..c432a47ea4 100755
--- a/core/bootstrap/image/image-tests.factor
+++ b/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
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index 05d48af2e8..0187a6ce52 100755
--- a/core/bootstrap/image/image.factor
+++ b/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
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) 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
- ] emit-object ;
+ [
+ float tag-number dup [
+ 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 ;
-: 1, 1 >bignum ' 1-offset fixup ;
-: -1, -1 >bignum ' -1-offset fixup ;
+: 0, ( -- ) 0 >bignum ' 0-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
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
- classes-intersect-cache class-and-cache
+ update-map class<=-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 [ (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
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index dd3a4adf8b..6a3c1c35d5 100755
--- a/core/bootstrap/primitives.factor
+++ b/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
-bootstrap.image.private io.files accessors combinators ;
+slots.deprecated classes.union classes.intersection
+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 builtins set
+bootstrapping? on
+
! Create some empty vocabs where the below primitives and
! classes will go
{
@@ -59,6 +63,7 @@ num-types get f builtins set
"arrays"
"bit-arrays"
"byte-arrays"
+ "byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
@@ -124,7 +129,7 @@ num-types get f 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 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
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index f99c8eb82f..64402ca2e1 100755
--- a/core/bootstrap/stage1.factor
+++ b/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
[
[
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index dfd2e4be6f..f94cc0ed37 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -22,13 +22,13 @@ SYMBOL: bootstrap-time
xref-sources ;
: load-components ( -- )
- "exclude" "include"
- [ get-global " " split [ empty? not ] subset ] bi@
+ "include" "exclude"
+ [ 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
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index 4b74804749..f3d7707878 100755
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -10,12 +10,14 @@ IN: bootstrap.syntax
"\""
"#!"
"("
+ "(("
":"
";"
"
{ $values { "box" box } }
@@ -27,12 +27,11 @@ ARTICLE: "boxes" "Boxes"
{ $subsection box }
"Creating an empty box:"
{ $subsection }
-"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"
diff --git a/core/boxes/boxes-tests.factor b/core/boxes/boxes-tests.factor
index 76a6cfd8b1..71fc1c9a7b 100755
--- a/core/boxes/boxes-tests.factor
+++ b/core/boxes/boxes-tests.factor
@@ -1,17 +1,17 @@
IN: boxes.tests
-USING: boxes namespaces tools.test ;
+USING: boxes namespaces tools.test accessors ;
[ ] [ "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
diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor
index b56a46b6b3..9e2e8a4673 100755
--- a/core/boxes/boxes.factor
+++ b/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 new ;
+ERROR: box-full box ;
+
: >box ( value box -- )
- dup box-full? [ "Box already has a value" throw ] when
- t over set-box-full?
- set-box-value ;
+ dup occupied>>
+ [ box-full ] [ t >>occupied (>>value) ] if ;
+
+ERROR: box-empty box ;
: box> ( box -- value )
- dup box-full? [ "Box empty" throw ] unless
- dup box-value f pick set-box-value
- f rot set-box-full? ;
+ dup occupied>>
+ [ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;
: ?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
diff --git a/core/byte-arrays/byte-arrays-docs.factor b/core/byte-arrays/byte-arrays-docs.factor
index 27df8771c3..8a51f4c663 100755
--- a/core/byte-arrays/byte-arrays-docs.factor
+++ b/core/byte-arrays/byte-arrays-docs.factor
@@ -26,5 +26,6 @@ HELP: ( 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." } ;
diff --git a/extra/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor
similarity index 100%
rename from extra/byte-vectors/byte-vectors-docs.factor
rename to core/byte-vectors/byte-vectors-docs.factor
diff --git a/extra/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor
similarity index 100%
rename from extra/byte-vectors/byte-vectors-tests.factor
rename to core/byte-vectors/byte-vectors-tests.factor
diff --git a/extra/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor
similarity index 61%
rename from extra/byte-vectors/byte-vectors.factor
rename to core/byte-vectors/byte-vectors.factor
index a8351dc781..e80b797a8d 100755
--- a/extra/byte-vectors/byte-vectors.factor
+++ b/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
-parser accessors ;
+sequences.private growable byte-arrays ;
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) ;
-
vector ( byte-array length -- byte-vector )
@@ -43,9 +32,3 @@ M: byte-vector equal?
M: byte-array new-resizable drop ;
INSTANCE: byte-vector growable
-
-: BV{ \ } [ >byte-vector ] parse-literal ; parsing
-
-M: byte-vector >pprint-sequence ;
-
-M: byte-vector pprint-delims drop \ BV{ \ } ;
diff --git a/extra/byte-vectors/summary.txt b/core/byte-vectors/summary.txt
similarity index 100%
rename from extra/byte-vectors/summary.txt
rename to core/byte-vectors/summary.txt
diff --git a/extra/byte-vectors/tags.txt b/core/byte-vectors/tags.txt
similarity index 100%
rename from extra/byte-vectors/tags.txt
rename to core/byte-vectors/tags.txt
diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor
new file mode 100644
index 0000000000..6ef0e85025
--- /dev/null
+++ b/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"
diff --git a/core/checksums/checksums-tests.factor b/core/checksums/checksums-tests.factor
new file mode 100644
index 0000000000..1ec675b0cf
--- /dev/null
+++ b/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
diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor
new file mode 100644
index 0000000000..08a13297d1
--- /dev/null
+++ b/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 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 r> checksum-stream ;
+
+: hex-string ( seq -- str )
+ [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;
diff --git a/core/io/crc32/authors.txt b/core/checksums/crc32/authors.txt
similarity index 100%
rename from core/io/crc32/authors.txt
rename to core/checksums/crc32/authors.txt
diff --git a/core/checksums/crc32/crc32-docs.factor b/core/checksums/crc32/crc32-docs.factor
new file mode 100644
index 0000000000..0f277bcd16
--- /dev/null
+++ b/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"
diff --git a/core/checksums/crc32/crc32-tests.factor b/core/checksums/crc32/crc32-tests.factor
new file mode 100644
index 0000000000..6fe4b995ee
--- /dev/null
+++ b/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
+
diff --git a/core/io/crc32/crc32.factor b/core/checksums/crc32/crc32.factor
similarity index 59%
rename from core/io/crc32/crc32.factor
rename to core/checksums/crc32/crc32.factor
index afe7e4bfb7..e1f0b9417b 100755
--- a/core/io/crc32/crc32.factor
+++ b/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 ;
-IN: io.crc32
+definitions checksums ;
+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 )
- >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
+SINGLETON: crc32
-: lines-crc32 ( seq -- n )
- HEX: ffffffff tuck [
- [ (crc32) ] each CHAR: \n (crc32)
- ] reduce bitxor ;
+INSTANCE: crc32 checksum
+
+: init-crc32 drop >r HEX: ffffffff dup r> ; inline
+
+: 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 ;
diff --git a/core/io/crc32/summary.txt b/core/checksums/crc32/summary.txt
similarity index 100%
rename from core/io/crc32/summary.txt
rename to core/checksums/crc32/summary.txt
diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor
index 87c72048f4..810bdbe10f 100755
--- a/core/classes/algebra/algebra-docs.factor
+++ b/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 } }
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index dba97c16f5..28e899d08b 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/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 \ fixnum class< ] unit-test
-[ f ] [ \ integer \ fixnum class< ] unit-test
-[ t ] [ \ integer \ object class< ] unit-test
-[ f ] [ \ integer \ null class< ] unit-test
-[ t ] [ \ null \ object class< ] unit-test
+[ t ] [ \ fixnum \ integer class<= ] unit-test
+[ t ] [ \ fixnum \ fixnum class<= ] unit-test
+[ f ] [ \ integer \ fixnum class<= ] unit-test
+[ t ] [ \ integer \ object class<= ] unit-test
+[ f ] [ \ integer \ null class<= ] unit-test
+[ t ] [ \ null \ object class<= ] unit-test
-[ t ] [ \ generic \ word class< ] unit-test
-[ f ] [ \ word \ generic class< ] unit-test
+[ t ] [ \ generic \ word class<= ] unit-test
+[ f ] [ \ word \ generic class<= ] unit-test
-[ f ] [ \ reversed \ slice class< ] unit-test
-[ f ] [ \ slice \ reversed class< ] unit-test
+[ f ] [ \ reversed \ slice 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
-[ f ] [ no-docs-union no-docs class< ] unit-test
+[ t ] [ no-docs no-docs-union 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
-[ f ] [ \ tuple \ c class< ] unit-test
+[ t ] [ \ c \ tuple class<= ] unit-test
+[ f ] [ \ tuple \ c class<= ] unit-test
-[ t ] [ \ tuple-class \ class class< ] unit-test
-[ f ] [ \ class \ tuple-class class< ] unit-test
+[ t ] [ \ tuple-class \ class class<= ] unit-test
+[ f ] [ \ class \ tuple-class class<= ] unit-test
TUPLE: tuple-example ;
-[ t ] [ \ null \ 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
-[ f ] [ \ tuple \ 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
+[ t ] [ \ tuple-example \ tuple 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
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index f2941e3cef..a9c1520fc6 100755
--- a/core/classes/algebra/algebra.factor
+++ b/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<-cache get [ (class<) ] 2cache ;
+: class<= ( first second -- ? )
+ class<=-cache get [ (class<=) ] 2cache ;
DEFER: (class-not)
@@ -37,7 +37,7 @@ TUPLE: anonymous-union members ;
C: anonymous-union
-TUPLE: anonymous-intersection members ;
+TUPLE: anonymous-intersection participants ;
C: anonymous-intersection
@@ -45,65 +45,91 @@ TUPLE: anonymous-complement class ;
C: anonymous-complement
-: superclass< ( first second -- ? )
- >r superclass r> class< ;
+: superclass<= ( first second -- ? )
+ >r superclass r> class<= ;
-: left-union-class< ( first second -- ? )
- >r members r> [ class< ] curry all? ;
+: left-anonymous-union<= ( first second -- ? )
+ >r members>> r> [ class<= ] curry all? ;
-: right-union-class< ( first second -- ? )
- members [ class< ] with contains? ;
+: right-anonymous-union<= ( first second -- ? )
+ members>> [ class<= ] with contains? ;
-: left-anonymous-union< ( first second -- ? )
- >r members>> r> [ class< ] curry all? ;
+: left-anonymous-intersection<= ( first second -- ? )
+ >r participants>> r> [ class<= ] curry contains? ;
-: right-anonymous-union< ( first second -- ? )
- members>> [ class< ] with contains? ;
+: right-anonymous-intersection<= ( first second -- ? )
+ participants>> [ class<= ] with all? ;
-: left-anonymous-intersection< ( first second -- ? )
- >r members>> r> [ class< ] curry contains? ;
+: anonymous-complement<= ( first second -- ? )
+ [ class>> ] bi@ swap class<= ;
-: right-anonymous-intersection< ( first second -- ? )
- members>> [ class< ] with all? ;
-
-: anonymous-complement< ( first second -- ? )
- [ class>> ] bi@ swap class< ;
-
-: (class<) ( first second -- -1/0/1 )
+: normalize-class ( class -- class' )
{
- { [ 2dup eq? ] [ 2drop t ] }
- { [ dup object eq? ] [ 2drop t ] }
- { [ 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 ]
+ { [ dup members ] [ members ] }
+ { [ dup participants ] [ participants ] }
+ [ ]
} cond ;
+: normalize-complement ( class -- class' )
+ class>> normalize-class {
+ { [ dup anonymous-union? ] [
+ members>>
+ [ class-not normalize-class ] map
+
+ ] }
+ { [ dup anonymous-intersection? ] [
+ participants>>
+ [ class-not normalize-class ] map
+
+ ] }
+ } 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 ;
-
-: union-class-intersect? ( first second -- ? )
- members [ classes-intersect? ] with contains? ;
+ class>> class<= not ;
: 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
} 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 )
- >r members r> [ class-and ] curry map ;
-
-: right-union-and ( first second -- class )
- members [ class-and ] with map ;
-
-: left-anonymous-union-and ( first second -- class )
- >r members>> r> [ class-and ] curry map ;
-
-: right-anonymous-union-and ( first second -- class )
+: anonymous-union-and ( first second -- class )
members>> [ class-and ] with map ;
-: left-anonymous-intersection-and ( first second -- class )
- >r members>> r> suffix ;
-
-: right-anonymous-intersection-and ( first second -- class )
- members>> swap suffix ;
+: anonymous-intersection-and ( first second -- class )
+ participants>> swap suffix ;
: (class-and) ( first second -- class )
{
- { [ 2dup class< ] [ drop ] }
- { [ 2dup swap class< ] [ nip ] }
+ { [ 2dup class<= ] [ drop ] }
+ { [ 2dup swap class<= ] [ nip ] }
{ [ 2dup classes-intersect? not ] [ 2drop null ] }
- { [ dup members ] [ right-union-and ] }
- { [ dup anonymous-union? ] [ right-anonymous-union-and ] }
- { [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] }
- { [ over members ] [ left-union-and ] }
- { [ over anonymous-union? ] [ left-anonymous-union-and ] }
- { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
- [ 2array ]
+ [
+ [ normalize-class ] bi@ {
+ { [ dup anonymous-union? ] [ anonymous-union-and ] }
+ { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
+ { [ over anonymous-union? ] [ swap anonymous-union-and ] }
+ { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
+ [ 2array ]
+ } cond
+ ]
} cond ;
-: left-anonymous-union-or ( first second -- class )
- >r members>> r> suffix ;
-
-: right-anonymous-union-or ( first second -- class )
+: anonymous-union-or ( first second -- class )
members>> swap suffix ;
+: ((class-or)) ( first second -- class )
+ [ normalize-class ] bi@ {
+ { [ dup anonymous-union? ] [ anonymous-union-or ] }
+ { [ over anonymous-union? ] [ swap anonymous-union-or ] }
+ [ 2array ]
+ } 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 swap class< ] [ drop ] }
- { [ dup anonymous-union? ] [ right-anonymous-union-or ] }
- { [ over anonymous-union? ] [ left-anonymous-union-or ] }
- [ 2array ]
+ { [ 2dup class<= ] [ nip ] }
+ { [ 2dup swap class<= ] [ drop ] }
+ { [ dup anonymous-complement? ] [ anonymous-complement-or ] }
+ { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
+ [ ((class-or)) ]
} cond ;
: (class-not) ( class -- complement )
@@ -180,22 +202,38 @@ C: 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 [
- [ 2dup class< >r swap class< not r> and ]
- with subset empty?
- ] curry find [ "Topological sort failed" throw ] unless* ;
+ dup [ [ class< ] with contains? not ] curry find-last
+ [ "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
{ [ 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
: 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 )
diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor
index 1c2871b031..8e992b852e 100644
--- a/core/classes/builtin/builtin.factor
+++ b/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 ;
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index dd3782e877..9fc4f6c4e7 100755
--- a/core/classes/classes-docs.factor
+++ b/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 ;
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index ae19f38d14..a03fed7fcb 100755
--- a/core/classes/classes-tests.factor
+++ b/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
-[ t ] [ union-1 number class< ] unit-test
+[ f ] [ bignum union-1 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
-[ f ] [ union-1 number class< ] unit-test
+[ t ] [ bignum union-1 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 ] [ mx1 integer class< ] unit-test
-[ t ] [ mx1 number class< ] unit-test
+[ t ] [ integer mx1 class<= ] unit-test
+[ t ] [ mx1 integer class<= ] unit-test
+[ t ] [ mx1 number class<= ] unit-test
"IN: classes.tests USE: arrays INSTANCE: array mx1" eval
-[ t ] [ array mx1 class< ] unit-test
-[ f ] [ mx1 number class< ] unit-test
+[ t ] [ array mx1 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 ] [ quotation redefine-bug-2 class< ] unit-test
+[ t ] [ fixnum 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
-[ f ] [ fixnum redefine-bug-2 class< ] unit-test
-[ t ] [ bignum redefine-bug-2 class< ] unit-test
+[ t ] [ bignum redefine-bug-1 class<= ] unit-test
+[ f ] [ fixnum 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
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 4f43b86f64..593213c5c6 100755
--- a/core/classes/classes.factor
+++ b/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 { "?" } ;
+: 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 ;
-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
- [ [ drop update-class ] assoc-each ]
+ dup class-usages
+ [ 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
diff --git a/core/classes/intersection/intersection-docs.factor b/core/classes/intersection/intersection-docs.factor
new file mode 100644
index 0000000000..e9ca706d63
--- /dev/null
+++ b/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." } ;
diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor
new file mode 100644
index 0000000000..7ea8e24f0a
--- /dev/null
+++ b/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 ;
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index 33b0fc32fa..9ffcd952e3 100755
--- a/core/classes/mixin/mixin.factor
+++ b/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
- t "mixin" set-word-prop ;
+ [ (define-union-class) ]
+ [ 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.
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index 4729a6dd5e..c8de36582e 100755
--- a/core/classes/predicate/predicate.factor
+++ b/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 ;
diff --git a/core/classes/singleton/singleton-docs.factor b/core/classes/singleton/singleton-docs.factor
index a8dae809ec..f647b006d9 100644
--- a/core/classes/singleton/singleton-docs.factor
+++ b/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
diff --git a/core/classes/singleton/singleton-tests.factor b/core/classes/singleton/singleton-tests.factor
index 2ed51abb93..10ddde75ae 100644
--- a/core/classes/singleton/singleton-tests.factor
+++ b/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
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index cdfdee9717..9f8ce83240 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/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 }"
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 2932187152..dc99734ce5 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/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 boa ;
+: ( x y w h -- rect ) rect boa ;
: move ( x rect -- rect )
[ + ] change-x ;
@@ -69,7 +69,7 @@ C: 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
[ t length ] [ object>> t eq? ] must-fail-with
[ "" ]
-[ "TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test
+[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test
TUPLE: size-test a b c d ;
@@ -164,7 +164,7 @@ C: t4
[ 1 ] [ 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
! We want to make sure constructors are recompiled when
! tuples are reshaped
-: cons-test-1 \ erg's-reshape-problem new ;
-: cons-test-2 \ erg's-reshape-problem boa ;
+: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
+: 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
[ t ] [ laptop tuple-class? ] unit-test
-[ t ] [ laptop tuple class< ] unit-test
-[ t ] [ laptop computer class< ] unit-test
+[ t ] [ laptop tuple class<= ] unit-test
+[ t ] [ laptop computer class<= ] unit-test
[ t ] [ laptop computer classes-intersect? ] unit-test
[ ] [ "Pentium" 128 3 hours "laptop" set ] unit-test
@@ -242,7 +242,7 @@ C: 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
[ t ] [ server tuple-class? ] unit-test
-[ t ] [ server tuple class< ] unit-test
-[ t ] [ server computer class< ] unit-test
+[ t ] [ server tuple class<= ] unit-test
+[ t ] [ server computer class<= ] unit-test
[ t ] [ server computer classes-intersect? ] unit-test
[ ] [ "PowerPC" 64 "1U" "server" set ] unit-test
@@ -275,7 +275,7 @@ C: 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 ] [ laptop server class< ] unit-test
+[ f ] [ server laptop class<= ] unit-test
+[ f ] [ laptop server class<= ] unit-test
[ f ] [ laptop server classes-intersect? ] unit-test
[ f ] [ 1 2 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
-[ t ] [ server electronic-device class< ] unit-test
-[ t ] [ laptop server class-or electronic-device class< ] unit-test
+[ f ] [ electronic-device laptop class<= ] unit-test
+[ t ] [ server 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
"a" "b" "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
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index c14205e1d9..0b54d7d69f 100755
--- a/core/classes/tuple/tuple.factor
+++ b/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 ;
diff --git a/core/classes/union/union-docs.factor b/core/classes/union/union-docs.factor
index 91726b6697..3d7312a889 100755
--- a/core/classes/union/union-docs.factor
+++ b/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"
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 09f8f88ced..74e29cfb01 100755
--- a/core/classes/union/union.factor
+++ b/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 ]
- [ drop update-classes ]
- 2bi ;
+ [ (define-union-class) ] [ drop update-classes ] 2bi ;
M: union-class reset-class
{ "class" "metaclass" "members" } reset-props ;
+
+M: union-class rank-class drop 2 ;
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
index 54c62c44fa..c65c01d2ab 100755
--- a/core/combinators/combinators-docs.factor
+++ b/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
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index da98a78736..f6873429fe 100755
--- a/core/combinators/combinators.factor
+++ b/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 ;
diff --git a/core/command-line/command-line.factor b/core/command-line/command-line.factor
index 246bf2dabe..fb4fd374a7 100644
--- a/core/command-line/command-line.factor
+++ b/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* ;
diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index 806ea914bb..8c653b866e 100755
--- a/core/compiler/compiler.factor
+++ b/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
- ] computing-dependencies ;
+ over "compiled-effect" word-prop = [
+ 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 ]
- [ dupd compile-failed f save-effect ]
- recover ;
+ [
+ H{ } clone dependencies set
+
+ {
+ [ compile-begins ]
+ [
+ [ word-dataflow ] [ compile-failed return ] recover
+ optimize
+ ]
+ [ dup generate ]
+ [ compile-succeeded ]
+ } cleave
+ ] curry with-return ;
: compile-loop ( assoc -- )
dup assoc-empty? [ drop ] [
diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor
index 11f64c9373..622c63d7f0 100755
--- a/core/compiler/constants/constants.factor
+++ b/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-mark HEX: 40 HEX: 80 bitor ;
+: card-bits 8 ;
+: deck-bits 18 ;
+: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
! These constants must match vm/layouts.h
-: header-offset object tag-number neg ;
-: float-offset 8 float tag-number - ;
-: string-offset 4 bootstrap-cells object tag-number - ;
-: profile-count-offset 7 bootstrap-cells object tag-number - ;
-: byte-array-offset 2 bootstrap-cells object tag-number - ;
-: alien-offset 3 bootstrap-cells object tag-number - ;
-: underlying-alien-offset bootstrap-cell object tag-number - ;
-: tuple-class-offset bootstrap-cell tuple tag-number - ;
-: class-hash-offset bootstrap-cell object tag-number - ;
-: word-xt-offset 8 bootstrap-cells object tag-number - ;
-: word-code-offset 9 bootstrap-cells object tag-number - ;
-: compiled-header-size 4 bootstrap-cells ;
+: header-offset ( -- n ) object tag-number neg ;
+: float-offset ( -- n ) 8 float tag-number - ;
+: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
+: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
+: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
+: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
+: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
+: word-xt-offset ( -- n ) 8 bootstrap-cells object tag-number - ;
+: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: 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 ;
diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor
index dd71eb704f..d86587662b 100755
--- a/core/compiler/errors/errors-docs.factor
+++ b/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
diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor
index b7b599e5a9..2bea6ad974 100755
--- a/core/compiler/errors/errors.factor
+++ b/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 ] [
diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor
index 7d473871fe..0e5c96eca0 100755
--- a/core/compiler/tests/intrinsics.factor
+++ b/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 [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 [ { byte-array } declare *uchar ] compile-call ] unit-test
diff --git a/core/compiler/tests/redefine.factor b/core/compiler/tests/redefine.factor
new file mode 100644
index 0000000000..b87898c649
--- /dev/null
+++ b/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
diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor
index bc9c56864c..68c85d6d97 100755
--- a/core/compiler/tests/simple.factor
+++ b/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 ;
diff --git a/core/compiler/tests/stack-trace.factor b/core/compiler/tests/stack-trace.factor
index f54ac62204..3b1a5c6c85 100755
--- a/core/compiler/tests/stack-trace.factor
+++ b/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 ;
-: bar foo 4 ;
-: baz bar 5 ;
+: foo ( -- * ) 3 throw 7 ;
+: bar ( -- * ) foo 4 ;
+: 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
diff --git a/core/compiler/tests/templates.factor b/core/compiler/tests/templates.factor
index 14d75cdc03..65ef68deb8 100755
--- a/core/compiler/tests/templates.factor
+++ b/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+ ]
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 65e57a8912..658a64315e 100755
--- a/core/compiler/units/units.factor
+++ b/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
- updated-definitions notify-definition-observers ;
+ dup [ drop crossref? ] assoc-contains? modify-code-heap ;
+
+: 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
new-definitions set
old-definitions set
- [ finish-compilation-unit ]
- [ ] cleanup
+ [
+ finish-compilation-unit
+ updated-definitions
+ notify-definition-observers
+ ] [ ] cleanup
] with-scope ; inline
: compile-call ( quot -- )
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index b1db09b6bc..3cb7d8a71e 100755
--- a/core/continuations/continuations-docs.factor
+++ b/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."
-{ $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
- " ... 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." ;
+"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." ;
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." } ;
diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor
index 8b396763e1..27e1f02b91 100755
--- a/core/continuations/continuations-tests.factor
+++ b/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
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index cf67280cca..087661dff4 100755
--- a/core/continuations/continuations.factor
+++ b/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 )
r compose [ dip rethrow ] curry
recover r> call ; inline
+ERROR: attempt-all-error ;
+
: attempt-all ( seq quot -- obj )
- [
- [ [ , f ] compose [ , drop t ] recover ] curry all?
- ] { } make peek swap [ rethrow ] when ; inline
-
-GENERIC: dispose ( object -- )
-
-: with-disposal ( object quot -- )
- over [ dispose ] curry [ ] cleanup ; inline
+ over empty? [
+ attempt-all-error
+ ] [
+ [
+ [ [ , f ] compose [ , drop t ] recover ] curry all?
+ ] { } make peek swap [ rethrow ] when
+ ] if ; inline
TUPLE: condition error restarts continuation ;
diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor
index 338c5341bc..42bf37d17f 100755
--- a/core/cpu/architecture/architecture.factor
+++ b/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
diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor
index 1799411021..70345b1e96 100755
--- a/core/cpu/ppc/architecture/architecture.factor
+++ b/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
diff --git a/core/cpu/ppc/assembler/assembler.factor b/core/cpu/ppc/assembler/assembler.factor
index 628022698f..b1d7016eff 100755
--- a/core/cpu/ppc/assembler/assembler.factor
+++ b/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
diff --git a/core/cpu/ppc/bootstrap.factor b/core/cpu/ppc/bootstrap.factor
index 18c7e8b92e..cf380d69f1 100755
--- a/core/cpu/ppc/bootstrap.factor
+++ b/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
diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor
index 34e9900893..1b28f7262e 100755
--- a/core/cpu/ppc/intrinsics/intrinsics.factor
+++ b/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
- "val" operand "scratch" operand "n" get cells ;
+ "obj" operand "scratch1" operand %untag
+ "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
- "val" operand "scratch" operand 0 LBZ
- "val" operand dup card-mark ORI
- "val" operand "scratch" operand 0 STB
+ "obj" operand "scratch2" operand card-bits SRWI
+ "scratch2" operand "scratch1" operand "val" operand STBX
+
+ ! 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" } }
}
}
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index 50e38f2082..3c6e4963e1 100755
--- a/core/cpu/x86/32/32.factor
+++ b/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 -- )
- (CALL) rel-dlsym ;
+M: x86.32 %alien-global 0 [] MOV rc-absolute-cell 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
diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor
index d79ce58d88..ebaa6056ff 100755
--- a/core/cpu/x86/64/64.factor
+++ b/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
diff --git a/core/cpu/x86/allot/allot.factor b/core/cpu/x86/allot/allot.factor
index 63870f94cd..144a9560d7 100755
--- a/core/cpu/x86/allot/allot.factor
+++ b/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.
diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor
index 7e7ff8a334..2a3d16694e 100755
--- a/core/cpu/x86/architecture/architecture.factor
+++ b/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
-memory namespaces sequences words generator generator.registers
-generator.fixup system layouts combinators compiler.constants ;
+cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
+kernel kernel.private math memory namespaces sequences words
+generator generator.registers generator.fixup system layouts
+combinators compiler.constants math.order ;
IN: cpu.x86.architecture
-HOOK: ds-reg cpu
-HOOK: rs-reg cpu
-HOOK: stack-reg cpu
-HOOK: stack-save-reg cpu
+HOOK: ds-reg cpu ( -- reg )
+HOOK: rs-reg cpu ( -- reg )
+HOOK: stack-reg cpu ( -- reg )
+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-2 cpu
+HOOK: temp-reg-1 cpu ( -- reg )
+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 -- )
- [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
+HOOK: %alien-global cpu ( symbol dll register -- )
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 )
[
diff --git a/core/cpu/x86/assembler/assembler-tests.factor b/core/cpu/x86/assembler/assembler-tests.factor
index caa00bd618..4c0f04fcc2 100644
--- a/core/cpu/x86/assembler/assembler-tests.factor
+++ b/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 OR ] { } make ] unit-test
+[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 MOV ] { } make ] unit-test
diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor
index 3ad7d4f7b5..452a102341 100755
--- a/core/cpu/x86/assembler/assembler.factor
+++ b/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
+
;
! 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 indirect-displacement [
- drop
- ] [
- 0 swap set-indirect-displacement
- ] if
- ] [
- drop
- ] if ;
+ dup base>> { EBP RBP R13 } member? [
+ dup displacement>> [ 0 >>displacement ] unless
+ ] when ;
-: canonicalize-ESP
+: canonicalize-ESP ( indirect -- indirect )
#! { ESP } ==> { ESP ESP }
- dup indirect-base { ESP RSP R12 } memq? [
- ESP swap set-indirect-index
- ] [
- drop
- ] if ;
+ dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
-: canonicalize ( indirect -- )
+: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
- dup canonicalize-EBP
- canonicalize-ESP ;
+ canonicalize-EBP canonicalize-ESP ;
: ( 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?
- over indirect-index rot indirect-scale or or ;
+ [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri 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 [
- indirect-displacement {
- { [ dup not ] [ BIN: 00 ] }
- { [ dup byte? ] [ BIN: 01 ] }
- { [ dup integer? ] [ BIN: 10 ] }
+ dup base>> [
+ displacement>> {
+ { [ dup not ] [ BIN: 00 ] }
+ { [ dup fits-in-byte? ] [ BIN: 01 ] }
+ { [ 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*
- over indirect-index* 3 shift bitor
- swap indirect-scale* 6 shift bitor ,
+ [ indirect-base* ]
+ [ indirect-index* 3 shift ]
+ [ 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 [
- swap indirect-base
- [ dup byte? [ , ] [ 4, ] if ] [ 4, ] if
+ dup displacement>> dup [
+ swap base>>
+ [ 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 -- ? )
- dup indirect? [
- dup indirect-base register-64?
- swap indirect-index register-64? or
- ] [
- register-64?
- ] if ;
+GENERIC: operand-64? ( operand -- ? )
+
+M: indirect operand-64?
+ [ base>> ] [ index>> ] bi [ operand-64? ] either? ;
+
+M: register-64 operand-64? drop t ;
+
+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?
- [ BIN: 00000010 bitor ] when
+ index>> extended? [ 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 -- )
- 1-operand , ;
+: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+ 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? [
- r> r> BIN: 10 opcode-or immediate-1
+ pick fits-in-byte? [
+ 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: operand PUSH BIN: 110 f HEX: ff 1-operand ;
+M: immediate PUSH HEX: 68 , 4, ;
+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 ;
-: JNO HEX: 81 JUMPcc ;
-: JB HEX: 82 JUMPcc ;
-: JAE HEX: 83 JUMPcc ;
-: JE HEX: 84 JUMPcc ; ! aka JZ
-: JNE HEX: 85 JUMPcc ;
-: JBE HEX: 86 JUMPcc ;
-: JA HEX: 87 JUMPcc ;
-: JS HEX: 88 JUMPcc ;
-: JNS HEX: 89 JUMPcc ;
-: JP HEX: 8a JUMPcc ;
-: JNP HEX: 8b JUMPcc ;
-: JL HEX: 8c JUMPcc ;
-: JGE HEX: 8d JUMPcc ;
-: JLE HEX: 8e JUMPcc ;
-: JG HEX: 8f JUMPcc ;
+: JO ( dst -- ) HEX: 80 JUMPcc ;
+: JNO ( dst -- ) HEX: 81 JUMPcc ;
+: JB ( dst -- ) HEX: 82 JUMPcc ;
+: JAE ( dst -- ) HEX: 83 JUMPcc ;
+: JE ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
+: JNE ( dst -- ) HEX: 85 JUMPcc ;
+: JBE ( dst -- ) HEX: 86 JUMPcc ;
+: JA ( dst -- ) HEX: 87 JUMPcc ;
+: JS ( dst -- ) HEX: 88 JUMPcc ;
+: JNS ( dst -- ) HEX: 89 JUMPcc ;
+: JP ( dst -- ) HEX: 8a JUMPcc ;
+: JNP ( dst -- ) HEX: 8b JUMPcc ;
+: JL ( dst -- ) HEX: 8c JUMPcc ;
+: JGE ( dst -- ) HEX: 8d JUMPcc ;
+: JLE ( dst -- ) HEX: 8e 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 ;
-: NEG ( dst -- ) BIN: 011 t HEX: f7 1-operand ;
-: MUL ( dst -- ) BIN: 100 t HEX: f7 1-operand ;
-: IMUL ( src -- ) BIN: 101 t HEX: f7 1-operand ;
-: DIV ( dst -- ) BIN: 110 t HEX: f7 1-operand ;
-: IDIV ( src -- ) BIN: 111 t HEX: f7 1-operand ;
+: NOT ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
+: NEG ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
+: MUL ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
+: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
+: DIV ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
+: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
-: CDQ HEX: 99 , ;
-: CQO HEX: 48 , CDQ ;
+: CDQ ( -- ) HEX: 99 , ;
+: CQO ( -- ) HEX: 48 , CDQ ;
-: ROL ( dst n -- ) swap BIN: 000 t HEX: c1 immediate-1 ;
-: ROR ( dst n -- ) swap BIN: 001 t HEX: c1 immediate-1 ;
-: RCL ( dst n -- ) swap BIN: 010 t HEX: c1 immediate-1 ;
-: RCR ( dst n -- ) swap BIN: 011 t HEX: c1 immediate-1 ;
-: SHL ( dst n -- ) swap BIN: 100 t HEX: c1 immediate-1 ;
-: SHR ( dst n -- ) swap BIN: 101 t HEX: c1 immediate-1 ;
-: SAR ( dst n -- ) swap BIN: 111 t HEX: c1 immediate-1 ;
+: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
+: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
+: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
+: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
+: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
+: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } 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 ;
-: CMOVNO HEX: 41 MOVcc ;
-: CMOVB HEX: 42 MOVcc ;
-: CMOVAE HEX: 43 MOVcc ;
-: CMOVE HEX: 44 MOVcc ; ! aka CMOVZ
-: CMOVNE HEX: 45 MOVcc ;
-: CMOVBE HEX: 46 MOVcc ;
-: CMOVA HEX: 47 MOVcc ;
-: CMOVS HEX: 48 MOVcc ;
-: CMOVNS HEX: 49 MOVcc ;
-: CMOVP HEX: 4a MOVcc ;
-: CMOVNP HEX: 4b MOVcc ;
-: CMOVL HEX: 4c MOVcc ;
-: CMOVGE HEX: 4d MOVcc ;
-: CMOVLE HEX: 4e MOVcc ;
-: CMOVG HEX: 4f MOVcc ;
+: CMOVO ( dst src -- ) HEX: 40 MOVcc ;
+: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
+: CMOVB ( dst src -- ) HEX: 42 MOVcc ;
+: CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
+: CMOVE ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
+: CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
+: CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
+: CMOVA ( dst src -- ) HEX: 47 MOVcc ;
+: CMOVS ( dst src -- ) HEX: 48 MOVcc ;
+: CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
+: CMOVP ( dst src -- ) HEX: 4a MOVcc ;
+: CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
+: CMOVL ( dst src -- ) HEX: 4c MOVcc ;
+: CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
+: CMOVLE ( dst src -- ) HEX: 4e 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 ;
-: FSTPL ( operand -- ) BIN: 011 f HEX: dd 1-operand ;
+: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
+: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
-: FLDS ( operand -- ) BIN: 000 f HEX: d9 1-operand ;
-: FLDL ( operand -- ) BIN: 000 f HEX: dd 1-operand ;
+: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
+: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
! SSE multimedia instructions
diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor
index ea4cadd51b..bd1b0f2871 100755
--- a/core/cpu/x86/bootstrap.factor
+++ b/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 quot-xt@ [+] JMP ! execute branch
+ arg0 arg0 array-start-offset [+] MOV ! load quotation
+ arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
[
diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor
index c48f33b765..0ee8a0a1d9 100755
--- a/core/cpu/x86/intrinsics/intrinsics.factor
+++ b/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 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 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
diff --git a/core/debugger/debugger-docs.factor b/core/debugger/debugger-docs.factor
index ca6aa59cc4..9dd23c6011 100755
--- a/core/debugger/debugger-docs.factor
+++ b/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." } ;
-
-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." } ;
+{ $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
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
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index f2740a63a9..cfad144737 100755
--- a/core/debugger/debugger.factor
+++ b/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
-strings io.styles vectors words system splitting math.parser
-classes.tuple continuations continuations.private combinators
-generic.math io.streams.duplex classes.builtin classes
-compiler.units generic.standard vocabs threads threads.private
-init kernel.private libc io.encodings mirrors accessors ;
+math namespaces prettyprint prettyprint.config sequences assocs
+sequences.private strings io.styles vectors words system
+splitting math.parser classes.tuple continuations
+continuations.private combinators generic.math
+classes.builtin classes compiler.units generic.standard vocabs
+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 ;
-: :2 2 :res ;
-: :3 3 :res ;
+: :1 ( -- * ) 1 :res ;
+: :2 ( -- * ) 2 :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
-] error-hook set-global
+ "Type :help for debugging help." print flush ;
: 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>
- 2dup [ length ] compare sgn {
- { -1 [ trim-datastacks nip relative-underflow ] }
- { 0 [ 2drop ] }
- { 1 [ trim-datastacks drop relative-overflow ] }
+ >r datastack r> dip >r datastack r>
+ 2dup [ length ] compare {
+ { +lt+ [ trim-datastacks nip relative-underflow ] }
+ { +eq+ [ 2drop ] }
+ { +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-overflow. "Data" stack-overflow. ;
-: retainstack-underflow. "Retain" stack-underflow. ;
-: retainstack-overflow. "Retain" stack-overflow. ;
+: datastack-underflow. ( obj -- ) "Data" stack-underflow. ;
+: datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
+: retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
+: 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-thread get-global
+: error-in-thread. ( thread -- )
"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" ;
+
... 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"
diff --git a/extra/destructors/destructors-tests.factor b/core/destructors/destructors-tests.factor
similarity index 62%
rename from extra/destructors/destructors-tests.factor
rename to core/destructors/destructors-tests.factor
index 59c325c490..f442e27a04 100755
--- a/extra/destructors/destructors-tests.factor
+++ b/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 new ;
@@ -13,10 +31,10 @@ M: dummy-destructor dispose ( obj -- )
dummy-destructor-obj t swap set-dummy-obj-destroyed? ;
: destroy-always
- add-always-destructor ;
+ &dispose drop ;
: destroy-later
- add-error-destructor ;
+ |dispose drop ;
[ t ] [
[
diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor
new file mode 100755
index 0000000000..bed1c16bcf
--- /dev/null
+++ b/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
+
+ dispose-each ;
+
+: do-error-destructors ( -- )
+ error-destructors get 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
diff --git a/extra/destructors/summary.txt b/core/destructors/summary.txt
similarity index 100%
rename from extra/destructors/summary.txt
rename to core/destructors/summary.txt
diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor
index c957c04453..8616d1f253 100755
--- a/core/dlists/dlists-docs.factor
+++ b/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)." }
-{ $see-also push-back pop-front pop-front* pop-back pop-back* } ;
+{ $notes "This operation is O(1)." } ;
+
+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)." }
-{ $see-also push-front pop-front pop-front* pop-back pop-back* } ;
+{ $notes "This operation is O(1)." } ;
+
+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)." }
-{ $see-also push-front push-back pop-front* pop-back pop-back* } ;
+{ $notes "This operation is O(1)." } ;
HELP: pop-front*
{ $values { "dlist" dlist } }
{ $description "Pop the object off the front of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." }
-{ $see-also push-front push-back pop-front pop-back pop-back* } ;
+{ $notes "This operation is O(1)." } ;
+
+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)." }
-{ $see-also push-front push-back pop-front pop-front* pop-back* } ;
+{ $notes "This operation is O(1)." } ;
HELP: pop-back*
{ $values { "dlist" dlist } }
{ $description "Pop the object off the back of the " { $link dlist } "." }
-{ $notes "This operation is O(1)." }
-{ $see-also push-front push-back pop-front pop-front* pop-back } ;
+{ $notes "This operation is O(1)." } ;
+
+{ 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" } }
diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor
index b0fe2a1157..886572c867 100755
--- a/core/dlists/dlists-tests.factor
+++ b/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-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-push-all ] keep
- [ dlist-delete-all ] keep
- dlist>array
- ] 2keep diff assert-same-elements
+ [ push-all-front ]
+ [ dlist-delete-all ]
+ [ dlist>array ] tri
+ ] 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 ] [ 4 over push-back 5 over push-back [ obj>> 4 = ] dlist-find-node drop class dlist-node = ] unit-test
+[ t ] [ 4 over push-back 5 over push-back [ obj>> 5 = ] dlist-find-node drop class dlist-node = ] unit-test
+[ t ] [ 4 over push-back 5 over push-back* [ = ] curry dlist-find-node drop class dlist-node = ] unit-test
+[ ] [ 4 over push-back 5 over push-back [ drop ] dlist-each ] unit-test
+
+[ peek-front ] must-fail
+[ peek-back ] must-fail
+[ pop-front ] [ empty-dlist? ] must-fail-with
+[ pop-back ] [ empty-dlist? ] must-fail-with
diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor
index e79907f11f..e07bfcdabe 100755
--- a/core/dlists/dlists.factor
+++ b/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-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
>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?
diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor
index 9e37ba4c85..66beae443f 100644
--- a/core/effects/effects-docs.factor
+++ b/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."
-{ $subsection "effect-declaration" }
+"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } "."
+{ $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"
diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor
index 234f567f25..c592ef6c92 100644
--- a/core/effects/effects-tests.factor
+++ b/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 2 2 effect<= ] unit-test
[ f ] [ 1 0 2 2 effect<= ] unit-test
[ t ] [ 2 2 2 2 effect<= ] unit-test
[ f ] [ 3 3 2 2 effect<= ] unit-test
[ f ] [ 2 3 2 2 effect<= ] unit-test
-[ t ] [ 2 3 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" } unparse ] unit-test
+[ "(( -- c d ))" ] [ { } { "c" "d" } unparse ] unit-test
+[ "(( a b -- ))" ] [ { "a" "b" } { } unparse ] unit-test
+[ "(( -- ))" ] [ { } { } unparse ] unit-test
+[ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test
diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index 80a4f679c0..099260f111 100755
--- a/core/effects/effects.factor
+++ b/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 effect-terminated? ] [ t ] }
- { [ dup effect-terminated? ] [ f ] }
- { [ 2dup [ effect-in length ] bi@ > ] [ f ] }
+ { [ over terminated?>> ] [ t ] }
+ { [ dup terminated?>> ] [ f ] }
+ { [ 2dup [ 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 %
- "-- " %
- dup effect-out stack-picture %
- effect-terminated? [ "* " % ] when
+ [ in>> stack-picture % "-- " % ]
+ [ out>> stack-picture % ]
+ [ 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 ;
+ [ in>> clone ] keep effect-out clone ;
: 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 ;
diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor
index f5d530dccb..64d733ef8c 100644
--- a/core/generator/fixup/fixup-docs.factor
+++ b/core/generator/fixup/fixup-docs.factor
@@ -1,14 +1,11 @@
-USING: help.syntax help.markup generator.fixup math kernel
+USING: help.syntax help.markup math kernel
words strings alien ;
+IN: generator.fixup
HELP: frame-required
{ $values { "n" "a non-negative integer" } }
{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
-HELP: (rel-fixup)
-{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "pair" "a pair of integers" } }
-{ $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ;
-
HELP: add-literal
{ $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor
index ad6cd3051c..a0961984ed 100755
--- a/core/generator/fixup/fixup.factor
+++ b/core/generator/fixup/fixup.factor
@@ -1,9 +1,10 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs hashtables
+USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces sequences words
-quotations strings alien.strings layouts system combinators
-math.bitfields words.private cpu.architecture ;
+quotations strings alien.accessors alien.strings layouts system
+combinators math.bitfields words.private cpu.architecture
+math.order accessors growable ;
IN: generator.fixup
: no-stack-frame -1 ; inline
@@ -77,38 +78,35 @@ TUPLE: label-fixup label class ;
: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
- dup label-fixup-class rc-absolute?
+ dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
- dup label-fixup-label swap label-fixup-class
- compiled-offset 4 - rot 3array label-table get push ;
+ dup label>> swap class>> compiled-offset 4 - rot
+ 3array label-table get push ;
TUPLE: rel-fixup arg class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
-: (rel-fixup) ( arg class type offset -- pair )
- pick rc-absolute-cell = cell 4 ? -
- >r { 0 8 16 } bitfield r>
- 2array ;
+: push-4 ( value vector -- )
+ [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri
+ swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
- dup rel-fixup-arg
- over rel-fixup-class
- rot rel-fixup-type
- compiled-offset (rel-fixup)
- relocation-table get push-all ;
+ [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
+ [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
+ [ relocation-table get push-4 ] bi@ ;
M: frame-required fixup* drop ;
M: integer fixup* , ;
-: push-new* ( obj table -- n )
+: adjoin* ( obj table -- n )
2dup swap [ eq? ] curry find drop
[ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table
-: add-literal ( obj -- n ) literal-table get push-new* ;
+: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;
@@ -134,7 +132,7 @@ SYMBOL: literal-table
0 swap rt-here rel-fixup ;
: init-fixup ( -- )
- V{ } clone relocation-table set
+ BV{ } clone relocation-table set
V{ } clone label-table set ;
: resolve-labels ( labels -- labels' )
@@ -150,6 +148,6 @@ SYMBOL: literal-table
dup stack-frame-size swap [ fixup* ] each drop
literal-table get >array
- relocation-table get >array
+ relocation-table get >byte-array
label-table get resolve-labels
] { } make ;
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index b8de9c3517..684c058913 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -72,8 +72,8 @@ GENERIC: generate-node ( node -- next )
: word-dataflow ( word -- effect dataflow )
[
- dup "no-effect" word-prop [ no-effect ] when
- dup "no-compile" word-prop [ no-effect ] when
+ dup "cannot-infer" word-prop [ cannot-infer-effect ] when
+ dup "no-compile" word-prop [ cannot-infer-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] with-infer ;
diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
index 6a1d9ec0f4..ded1c82ee4 100755
--- a/core/generator/registers/registers.factor
+++ b/core/generator/registers/registers.factor
@@ -4,7 +4,7 @@ USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays
-accessors sets ;
+accessors sets math.order ;
IN: generator.registers
SYMBOL: +input+
@@ -67,7 +67,7 @@ INSTANCE: temp-reg value
! A data stack location.
TUPLE: ds-loc n class ;
-: f ds-loc boa ;
+: ( n -- loc ) f ds-loc boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
@@ -78,7 +78,7 @@ M: ds-loc live-loc?
! A retain stack location.
TUPLE: rs-loc n class ;
-: f rs-loc boa ;
+: ( n -- loc ) f rs-loc boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
@@ -177,15 +177,15 @@ INSTANCE: constant value
r 0 V{ } clone r> boa ; inline
-: (loc)
+: (loc) ( m stack -- n )
#! Utility for methods on
height>> - ;
@@ -314,7 +314,7 @@ M: phantom-retainstack finalize-height
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
[ phantom-locs* ] [ stack>> ] bi zip
- [ live-loc? ] assoc-subset
+ [ live-loc? ] assoc-filter
values ;
: live-locs ( -- seq )
@@ -372,7 +372,7 @@ M: value (lazy-load)
: (compute-free-vregs) ( used class -- vector )
#! Find all vregs in 'class' which are not in 'used'.
[ vregs length reverse ] keep
- [ ] curry map diff
+ [ ] curry map swap diff
>vector ;
: compute-free-vregs ( -- )
@@ -484,7 +484,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
- [ substitute-vreg? ] assoc-subset >hashtable
+ [ substitute-vreg? ] assoc-filter >hashtable
[ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- )
@@ -569,7 +569,7 @@ M: loc lazy-store
{
{ f [ drop t ] }
{ known-tag [ class-tag >boolean ] }
- [ class< ]
+ [ class<= ]
} case ;
: spec-matches? ( value spec -- ? )
@@ -644,7 +644,7 @@ PRIVATE>
UNION: immediate fixnum POSTPONE: f ;
: operand-immediate? ( operand -- ? )
- operand-class immediate class< ;
+ operand-class immediate class<= ;
: phantom-push ( obj -- )
1 phantom-datastack get adjust-phantom
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 1024c377a8..39293bfec9 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -4,22 +4,22 @@ generic.standard generic.math combinators ;
IN: generic
ARTICLE: "method-order" "Method precedence"
-"Consider the case where a generic word has methods on two classes, say A and B, which share a non-empty intersection. If the generic word is called on an object which is an instance of both A and B, a choice of method must be made. If A is a subclass of B, the method for A to be called; this makes sense, because we're defining general behavior for instances of B, and refining it for instances of A. Conversely, if B is a subclass of A, then we expect B's method to be called. However, if neither is a subclass of the other, we have an ambiguous situation and undefined behavior will result. Either the method for A or B will be called, and there is no way to predict ahead of time."
-$nl
-"The generic word system linearly orders all the methods on a generic word by their class. Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in order. If methods are defined on overlapping classes, this order will fail to be unique and the problem described above can occur."
+"Conceptually, method dispatch is implemented by testing the object against the predicate word for every class, in linear order (" { $link "class-linearization" } ")."
$nl
"Here is an example:"
{ $code
"GENERIC: explain"
- "M: number explain drop \"an integer\" print ;"
- "M: sequence explain drop \"a sequence\" print ;"
"M: object explain drop \"an object\" print ;"
+ "M: number explain drop \"a number\" print ;"
+ "M: sequence explain drop \"a sequence\" print ;"
}
-"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. As a result, the outcome of calling " { $snippet "bar" } " with an " { $link integer } " on the stack is undefined - either one of the two methods may be called. This situation can lead to subtle bugs. To avoid it, explicitly disambiguate the method order by defining a method on the intersection. If in this case we want integers to behave like numbers, we would also define:"
-{ $code "M: integer explain drop \"an integer\" print ;" }
-"On the other hand, if we want integers to behave like sequences here, we could define:"
+"The linear order is the following, from least-specific to most-specific:"
+{ $code "{ object sequence number }" }
+"Neither " { $link number } " nor " { $link sequence } " are subclasses of each other, yet their intersection is the non-empty " { $link integer } " class. Calling " { $snippet "explain" } " with an integer on the stack will print " { $snippet "a number" } " because " { $link number } " precedes " { $link sequence } " in the class linearization order. If this was not the desired outcome, define a method on the intersection:"
{ $code "M: integer explain drop \"a sequence\" print ;" }
-"The " { $link order } " word can be useful to clarify method dispatch order."
+"Now, the linear order is the following, from least-specific to most-specific:"
+{ $code "{ object sequence number integer }" }
+"The " { $link order } " word can be useful to clarify method dispatch order:"
{ $subsection order } ;
ARTICLE: "generic-introspection" "Generic word introspection"
diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index bbd7186a11..9d968a3a98 100755
--- a/core/generic/generic-tests.factor
+++ b/core/generic/generic-tests.factor
@@ -143,7 +143,7 @@ GENERIC: generic-forget-test-1
M: integer generic-forget-test-1 / ;
[ t ] [
- \ / usage [ word? ] subset
+ \ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
@@ -152,16 +152,16 @@ M: integer generic-forget-test-1 / ;
] unit-test
[ f ] [
- \ / usage [ word? ] subset
+ \ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
-GENERIC: generic-forget-test-2
+GENERIC: generic-forget-test-2 ( a b -- c )
M: sequence generic-forget-test-2 = ;
[ t ] [
- \ = usage [ word? ] subset
+ \ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
@@ -170,11 +170,11 @@ M: sequence generic-forget-test-2 = ;
] unit-test
[ f ] [
- \ = usage [ word? ] subset
+ \ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
-GENERIC: generic-forget-test-3
+GENERIC: generic-forget-test-3 ( a -- b )
M: f generic-forget-test-3 ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 6c59d76d07..fb9820008a 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private
-classes.algebra quotations arrays vocabs effects ;
+classes.algebra quotations arrays vocabs effects combinators ;
IN: generic
! Method combination protocol
@@ -35,7 +35,7 @@ PREDICATE: method-spec < pair
GENERIC: effective-method ( ... generic -- method )
: next-method-class ( class generic -- class/f )
- order [ class< ] with subset reverse dup length 1 =
+ order [ class<= ] with filter reverse dup length 1 =
[ drop f ] [ second ] if ;
: next-method ( class generic -- class/f )
@@ -56,8 +56,19 @@ TUPLE: check-method class generic ;
\ check-method boa throw
] unless ; inline
-: with-methods ( generic quot -- )
- swap [ "methods" word-prop swap call ] keep make-generic ;
+: affected-methods ( class generic -- seq )
+ "methods" word-prop swap
+ [ nip classes-intersect? ] curry assoc-filter
+ values ;
+
+: update-generic ( class generic -- )
+ [ affected-methods [ +called+ changed-definition ] each ]
+ [ make-generic ]
+ bi ;
+
+: with-methods ( class generic quot -- )
+ [ [ "methods" word-prop ] dip call ]
+ [ drop update-generic ] 3bi ;
inline
: method-word-name ( class word -- string )
@@ -117,42 +128,57 @@ M: method-spec definition
M: method-spec forget*
first2 method forget* ;
+M: method-spec smart-usage
+ second smart-usage ;
+
M: method-body definer
drop \ M: \ ; ;
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
[
- [ "method-class" word-prop ]
- [ "method-generic" word-prop ] bi
- dup generic? [
- [ delete-at* ] with-methods
- [ call-next-method ] [ drop ] if
- ] [ 2drop ] if
+ [ ]
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] tri
+ 3dup method eq? [
+ [ delete-at ] with-methods
+ call-next-method
+ ] [ 3drop ] if
]
[ t "forgotten" set-word-prop ] bi
] if ;
-: implementors* ( classes -- words )
- all-words [
- "methods" word-prop keys
- swap [ key? ] curry contains?
- ] with subset ;
+M: method-body smart-usage
+ "method-generic" word-prop smart-usage ;
-: implementors ( class -- seq )
- dup associate implementors* ;
+GENERIC: implementors ( class/classes -- seq )
+
+M: class implementors
+ all-words [ "methods" word-prop key? ] with filter ;
+
+M: assoc implementors
+ all-words [
+ "methods" word-prop keys
+ swap [ key? ] curry contains?
+ ] with filter ;
: forget-methods ( class -- )
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
- [ forget-methods ]
- [ update-map- ]
- [ call-next-method ]
- tri ;
+ [
+ class-usages [
+ drop
+ [ forget-methods ]
+ [ update-map- ]
+ [ reset-class ]
+ tri
+ ] assoc-each
+ ]
+ [ call-next-method ] bi ;
-M: assoc update-methods ( assoc -- )
- implementors* [ make-generic ] each ;
+M: assoc update-methods ( class assoc -- )
+ implementors [ update-generic ] with each ;
: define-generic ( word combination -- )
over "combination" word-prop over = [
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 884ab8027e..1c1368a6c2 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -3,27 +3,27 @@
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
sequences.private classes classes.builtin classes.algebra
-definitions ;
+definitions math.order ;
IN: generic.math
PREDICATE: math-class < class
dup null bootstrap-word eq? [
drop f
] [
- number bootstrap-word class<
+ number bootstrap-word class<=
] if ;
: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
: math-precedence ( class -- pair )
{
- { [ dup null class< ] [ drop { -1 -1 } ] }
+ { [ dup null class<= ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
[ drop { 100 100 } ]
} cond ;
: math-class-max ( class class -- class )
- [ [ math-precedence ] compare 0 > ] most ;
+ [ [ math-precedence ] compare +gt+ eq? ] most ;
: (math-upgrade) ( max class -- quot )
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor
index 1f0b80e016..20e22fde82 100644
--- a/core/generic/standard/engines/engines.factor
+++ b/core/generic/standard/engines/engines.factor
@@ -26,8 +26,8 @@ M: method-body engine>quot 1quotation ;
alist>quot ;
: split-methods ( assoc class -- first second )
- [ [ nip class< not ] curry assoc-subset ]
- [ [ nip class< ] curry assoc-subset ] 2bi ;
+ [ [ nip class<= not ] curry assoc-filter ]
+ [ [ nip class<= ] curry assoc-filter ] 2bi ;
: convert-methods ( assoc class word -- assoc' )
over >r >r split-methods dup assoc-empty? [
diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor
index 5335074dea..9c810592a0 100644
--- a/core/generic/standard/engines/predicate/predicate.factor
+++ b/core/generic/standard/engines/predicate/predicate.factor
@@ -11,19 +11,18 @@ C: predicate-dispatch-engine
[ >r "predicate" word-prop picker prepend r> ] assoc-map ;
: keep-going? ( assoc -- ? )
- assumed get swap second first class< ;
+ assumed get swap second first class<= ;
: prune-redundant-predicates ( assoc -- default assoc' )
{
{ [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
- { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
- [ [ first second ] [ 1 tail-slice ] bi ]
+ { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
+ [ [ first second ] [ rest-slice ] bi ]
} cond ;
: sort-methods ( assoc -- assoc' )
- [ keys sort-classes ]
- [ [ dupd at ] curry ] bi { } map>assoc ;
+ >alist [ keys sort-classes ] keep extract-keys ;
M: predicate-dispatch-engine engine>quot
methods>> clone
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index 6344bec536..c1e72a65de 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -38,7 +38,7 @@ C: hi-tag-dispatch-engine
\ hi-tag bootstrap-word
\ convert-methods ;
-: num-hi-tags num-types get num-tags get - ;
+: num-hi-tags ( -- n ) num-types get num-tags get - ;
: hi-tag-number ( class -- n )
"type" word-prop num-tags get - ;
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 7639d1d499..9a780383b5 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -4,7 +4,7 @@ USING: kernel classes.tuple.private hashtables assocs sorting
accessors combinators sequences slots.private math.parser words
effects namespaces generic generic.standard.engines
classes.algebra math math.private kernel.private
-quotations arrays ;
+quotations arrays definitions ;
IN: generic.standard.engines.tuple
TUPLE: echelon-dispatch-engine n methods ;
@@ -44,7 +44,7 @@ M: trivial-tuple-dispatch-engine engine>quot
>alist V{ } clone [ hashcode 1array ] distribute-buckets
[ ] map ;
-: word-hashcode% [ 1 slot ] % ;
+: word-hashcode% ( -- ) [ 1 slot ] % ;
: class-hash-dispatch-quot ( methods -- quot )
[
@@ -64,8 +64,9 @@ M: engine-word stack-effect
[ extra-values ] [ stack-effect ] bi
dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
-M: engine-word compiled-crossref?
- drop t ;
+M: engine-word crossref? drop t ;
+
+M: engine-word irrelevant? drop t ;
: remember-engine ( word -- )
generic get "engines" word-prop push ;
@@ -77,7 +78,7 @@ M: engine-word compiled-crossref?
: define-engine-word ( quot -- word )
>r dup r> define ;
-: array-nth% 2 + , [ slot { word } declare ] % ;
+: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses ( obj -- array )
{ tuple } declare
@@ -127,8 +128,6 @@ M: echelon-dispatch-engine engine>quot
1 slot { tuple-layout } declare
5 slot ; inline
-: unclip-last [ 1 head* ] [ peek ] bi ;
-
M: tuple-dispatch-engine engine>quot
[
picker %
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor
index 1bff9ae15d..93956fec00 100644
--- a/core/generic/standard/standard-tests.factor
+++ b/core/generic/standard/standard-tests.factor
@@ -3,9 +3,10 @@ USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces
quotations inference vectors growable hashtables sbufs
-prettyprint byte-vectors bit-vectors float-vectors ;
+prettyprint byte-vectors bit-vectors float-vectors definitions
+generic sets graphs assocs ;
-GENERIC: lo-tag-test
+GENERIC: lo-tag-test ( obj -- obj' )
M: integer lo-tag-test 3 + ;
@@ -20,7 +21,7 @@ M: complex lo-tag-test sq ;
[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
-GENERIC: hi-tag-test
+GENERIC: hi-tag-test ( obj -- obj' )
M: string hi-tag-test ", in bed" append ;
@@ -52,7 +53,7 @@ TUPLE: circle < shape radius ;
C: circle
-GENERIC: area
+GENERIC: area ( shape -- n )
M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
@@ -62,15 +63,15 @@ M: circle area radius>> sq pi * ;
[ 12 ] [ 4 3 2 area ] unit-test
[ t ] [ 2 area 4 pi * = ] unit-test
-GENERIC: perimiter
+GENERIC: perimiter ( shape -- n )
-: rectangle-perimiter + 2 * ;
+: rectangle-perimiter ( n -- n ) + 2 * ;
M: rectangle perimiter
[ width>> ] [ height>> ] bi
rectangle-perimiter ;
-: hypotenuse [ sq ] bi@ + sqrt ;
+: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
M: parallelogram perimiter
[ width>> ]
@@ -82,7 +83,7 @@ M: circle perimiter 2 * pi * ;
[ 14 ] [ 4 3 perimiter ] unit-test
[ 30 ] [ 10 4 3 perimiter ] unit-test
-GENERIC: big-mix-test
+GENERIC: big-mix-test ( obj -- obj' )
M: object big-mix-test drop "object" ;
@@ -124,7 +125,7 @@ M: circle big-mix-test drop "circle" ;
[ "tuple" ] [ H{ } big-mix-test ] unit-test
[ "object" ] [ \ + big-mix-test ] unit-test
-GENERIC: small-lo-tag
+GENERIC: small-lo-tag ( obj -- obj )
M: fixnum small-lo-tag drop "fixnum" ;
@@ -225,7 +226,7 @@ M: b funky* "b" , call-next-method ;
M: c funky* "c" , call-next-method ;
-: funky [ funky* ] { } make ;
+: funky ( obj -- seq ) [ funky* ] { } make ;
[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
@@ -287,3 +288,24 @@ M: sbuf no-stack-effect-decl ;
[ ] [ \ no-stack-effect-decl see ] unit-test
[ ] [ \ no-stack-effect-decl word-def . ] unit-test
+
+! Cross-referencing with generic words
+TUPLE: xref-tuple-1 ;
+TUPLE: xref-tuple-2 < xref-tuple-1 ;
+
+: (xref-test) ( obj -- ) drop ;
+
+GENERIC: xref-test ( obj -- )
+
+M: xref-tuple-1 xref-test (xref-test) ;
+M: xref-tuple-2 xref-test (xref-test) ;
+
+[ t ] [
+ \ xref-test
+ \ xref-tuple-1 \ xref-test method [ usage unique ] closure key?
+] unit-test
+
+[ t ] [
+ \ xref-test
+ \ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
+] unit-test
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 98194e7ef3..f58d016c22 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -81,14 +81,8 @@ ERROR: no-method object generic ;
"methods" word-prop
[ generic get mangle-method ] assoc-map
[ find-default default set ]
- [
- generic get "inline" word-prop [
-
- ] [
-
- ] if
- ] bi
- engine>quot
+ [ ]
+ bi engine>quot
]
} cleave
] with-scope ;
diff --git a/core/io/streams/duplex/authors.txt b/core/grouping/authors.txt
similarity index 100%
rename from core/io/streams/duplex/authors.txt
rename to core/grouping/authors.txt
diff --git a/core/grouping/grouping-docs.factor b/core/grouping/grouping-docs.factor
new file mode 100644
index 0000000000..894412d922
--- /dev/null
+++ b/core/grouping/grouping-docs.factor
@@ -0,0 +1,100 @@
+USING: help.markup help.syntax sequences strings ;
+IN: grouping
+
+ARTICLE: "grouping" "Groups and clumps"
+"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
+{ $subsection groups }
+{ $subsection }
+{ $subsection }
+"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsection clumps }
+{ $subsection }
+{ $subsection }
+"The difference can be summarized as the following:"
+{ $list
+ { "With groups, the subsequences form the original sequence when concatenated:"
+ { $unchecked-example "dup n groups concat sequence= ." "t" }
+ }
+ { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
+ { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
+ }
+} ;
+
+ABOUT: "grouping"
+
+HELP: groups
+{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New groups are created by calling " { $link } " and " { $link } "." }
+{ $see-also group } ;
+
+HELP: group
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
+{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
+{ $examples
+ { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
+} ;
+
+HELP:
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
+{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ { $example
+ "USING: arrays kernel prettyprint sequences splitting ;"
+ "9 >array 3 dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
+ }
+} ;
+
+HELP:
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ { $example
+ "USING: arrays kernel prettyprint sequences splitting ;"
+ "9 >array 3 "
+ "dup [ reverse-here ] each concat >array ."
+ "{ 2 1 0 5 4 3 8 7 6 }"
+ }
+} ;
+
+HELP: clumps
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New clumps are created by calling " { $link } " and " { $link } "." } ;
+
+HELP: clump
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
+{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
+{ $examples
+ { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
+} ;
+
+HELP:
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ "Running averages:"
+ { $example
+ "USING: splitting sequences math prettyprint kernel ;"
+ "IN: scratchpad"
+ ": share-price"
+ " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
+ ""
+ "share-price 4 [ [ sum ] [ length ] bi / ] map ."
+ "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
+ }
+} ;
+
+HELP:
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
+
+{ clumps groups } related-words
+
+{ clump group } related-words
+
+{ } related-words
+
+{ } related-words
diff --git a/core/grouping/grouping-tests.factor b/core/grouping/grouping-tests.factor
new file mode 100644
index 0000000000..dcf62e1117
--- /dev/null
+++ b/core/grouping/grouping-tests.factor
@@ -0,0 +1,12 @@
+USING: grouping tools.test kernel sequences arrays ;
+IN: grouping.tests
+
+[ { 1 2 3 } 0 group ] must-fail
+
+[ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
+
+[ { V{ "a" "b" } V{ f f } } ] [
+ V{ "a" "b" } clone 2
+ 2 over set-length
+ >array
+] unit-test
diff --git a/core/grouping/grouping.factor b/core/grouping/grouping.factor
new file mode 100644
index 0000000000..c12d43160c
--- /dev/null
+++ b/core/grouping/grouping.factor
@@ -0,0 +1,68 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.order strings arrays vectors sequences
+accessors ;
+IN: grouping
+
+TUPLE: abstract-groups seq n ;
+
+: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
+
+: new-groups ( seq n class -- groups )
+ >r check-groups r> boa ; inline
+
+GENERIC: group@ ( n groups -- from to seq )
+
+M: abstract-groups nth group@ subseq ;
+
+M: abstract-groups set-nth group@ 0 swap copy ;
+
+M: abstract-groups like drop { } like ;
+
+INSTANCE: abstract-groups sequence
+
+TUPLE: groups < abstract-groups ;
+
+: ( seq n -- groups )
+ groups new-groups ; inline
+
+M: groups length
+ [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
+
+M: groups set-length
+ [ n>> * ] [ seq>> ] bi set-length ;
+
+M: groups group@
+ [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
+
+TUPLE: sliced-groups < groups ;
+
+: ( seq n -- groups )
+ sliced-groups new-groups ; inline
+
+M: sliced-groups nth group@ ;
+
+TUPLE: clumps < abstract-groups ;
+
+: ( seq n -- clumps )
+ clumps new-groups ; inline
+
+M: clumps length
+ [ seq>> length ] [ n>> ] bi - 1+ ;
+
+M: clumps set-length
+ [ n>> + 1- ] [ seq>> ] bi set-length ;
+
+M: clumps group@
+ [ n>> over + ] [ seq>> ] bi ;
+
+TUPLE: sliced-clumps < groups ;
+
+: ( seq n -- clumps )
+ sliced-clumps new-groups ; inline
+
+M: sliced-clumps nth group@ ;
+
+: group ( seq n -- array ) { } like ;
+
+: clump ( seq n -- array ) { } like ;
diff --git a/core/grouping/summary.txt b/core/grouping/summary.txt
new file mode 100644
index 0000000000..3695129a07
--- /dev/null
+++ b/core/grouping/summary.txt
@@ -0,0 +1 @@
+Grouping sequence elements into subsequences
diff --git a/core/grouping/tags.txt b/core/grouping/tags.txt
new file mode 100644
index 0000000000..42d711b32b
--- /dev/null
+++ b/core/grouping/tags.txt
@@ -0,0 +1 @@
+collections
diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor
index aff59ee8a5..e3b21e629e 100755
--- a/core/hashtables/hashtables-docs.factor
+++ b/core/hashtables/hashtables-docs.factor
@@ -10,9 +10,7 @@ $nl
$nl
"The " { $link hash-count } " slot is the number of entries including deleted entries, and " { $link hash-deleted } " is the number of deleted entries."
{ $subsection }
-{ $subsection nth-pair }
{ $subsection set-nth-pair }
-{ $subsection find-pair }
"If a hashtable's keys are mutated, or if hashing algorithms change, hashtables can be rehashed:"
{ $subsection rehash } ;
@@ -74,24 +72,12 @@ HELP: new-key@
{ $values { "key" "a key" } { "hash" hashtable } { "array" "the underlying array of the hashtable" } { "n" "the index where the key would be stored" } { "empty?" "a boolean indicating whether the location is currently empty" } }
{ $description "Searches the hashtable for the key using a linear probing strategy. If the key is not present in the hashtable, outputs the index where it should be stored." } ;
-HELP: nth-pair
-{ $values { "n" "an index in the sequence" } { "seq" "a sequence" } { "key" "the first element of the pair" } { "value" "the second element of the pair" } }
-{ $description "Fetches the elements with index " { $snippet "n" } " and " { $snippet "n+1" } ", respectively." }
-{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because it does not perform bounds checks." } ;
-
-{ nth-pair set-nth-pair } related-words
-
HELP: set-nth-pair
{ $values { "value" "the second element of the pair" } { "key" "the first element of the pair" } { "seq" "a sequence" } { "n" "an index in the sequence" } }
{ $description "Stores a pair of values into the elements with index " { $snippet "n" } " and " { $snippet "n+1" } ", respectively." }
{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because it does not perform bounds checks." }
{ $side-effects "seq" } ;
-HELP: find-pair
-{ $values { "array" "an array of pairs" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key" } { "value" "the successful value" } { "?" "a boolean of whether there was success" } }
-{ $description "Applies a quotation to successive pairs in the array, yielding the first successful pair." }
-{ $warning "This word is in the " { $vocab-link "hashtables.private" } " vocabulary because passing an array of odd length can lead to memory corruption." } ;
-
HELP: reset-hash
{ $values { "n" "a positive integer specifying hashtable capacity" } { "hash" hashtable } }
{ $description "Resets the underlying array of the hashtable to a new array with the given capacity. Removes all entries from the hashtable." }
diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor
index f4e76aa68e..4e80ed1f6e 100755
--- a/core/hashtables/hashtables-tests.factor
+++ b/core/hashtables/hashtables-tests.factor
@@ -10,7 +10,7 @@ continuations ;
[ ] [ 1000 [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
[ V{ } ]
-[ 1000 [ dup sq swap "testhash" get at = not ] subset ]
+[ 1000 [ dup sq swap "testhash" get at = not ] filter ]
unit-test
[ t ]
diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor
index ea2f67255c..a1dba07fb0 100755
--- a/core/hashtables/hashtables.factor
+++ b/core/hashtables/hashtables.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs
- math.private sequences sequences.private vectors ;
+math.private sequences sequences.private vectors grouping ;
IN: hashtables
r 2 fixnum+fast r> ; inline
-
-: (find-pair) ( quot i array -- key value ? )
- 2dup array-capacity eq? [
- 3drop f f f
- ] [
- 2dup array-nth tombstone? [
- find-pair-next (find-pair)
- ] [
- [ nth-pair rot call ] 3keep roll [
- nth-pair >r nip r> t
- ] [
- find-pair-next (find-pair)
- ] if
- ] if
- ] if ; inline
-
-: find-pair ( array quot -- key value ? )
- 0 rot (find-pair) ; inline
-
-: (rehash) ( hash array -- )
- [ swap pick (set-hash) drop f ] find-pair 2drop 2drop ;
+: (rehash) ( hash alist -- )
+ swap [ swapd (set-hash) drop ] curry assoc-each ;
: hash-large? ( hash -- ? )
[ hash-count 3 fixnum*fast ]
@@ -98,7 +74,7 @@ IN: hashtables
[ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ;
: grow-hash ( hash -- )
- [ dup hash-array swap assoc-size 1+ ] keep
+ [ dup >alist swap assoc-size 1+ ] keep
[ reset-hash ] keep
swap (rehash) ;
@@ -136,8 +112,8 @@ M: hashtable assoc-size ( hash -- n )
dup hash-count swap hash-deleted - ;
: rehash ( hash -- )
- dup hash-array
- dup length ((empty)) pick set-hash-array
+ dup >alist
+ over hash-array length ((empty)) pick set-hash-array
0 pick set-hash-count
0 pick set-hash-deleted
(rehash) ;
@@ -148,8 +124,8 @@ M: hashtable set-at ( value key hash -- )
: associate ( value key -- hash )
2 [ set-at ] keep ;
-M: hashtable assoc-find ( hash quot -- key value ? )
- >r hash-array r> find-pair ;
+M: hashtable >alist
+ hash-array 2 [ first tombstone? not ] filter ;
M: hashtable clone
(clone) dup hash-array clone over set-hash-array ;
diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor
index f9224eafeb..d1003ac2f8 100755
--- a/core/heaps/heaps-docs.factor
+++ b/core/heaps/heaps-docs.factor
@@ -1,4 +1,5 @@
-USING: heaps.private help.markup help.syntax kernel math assocs ;
+USING: heaps.private help.markup help.syntax kernel math assocs
+math.order ;
IN: heaps
ARTICLE: "heaps" "Heaps"
diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor
index b22d8818c1..d55b547b8f 100755
--- a/core/heaps/heaps-tests.factor
+++ b/core/heaps/heaps-tests.factor
@@ -3,7 +3,7 @@
USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting
-accessors ;
+accessors math.order ;
IN: heaps.tests
[ heap-pop ] must-fail
diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor
index 02a8b8d88b..57f0e0ac72 100755
--- a/core/heaps/heaps.factor
+++ b/core/heaps/heaps.factor
@@ -2,7 +2,7 @@
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs sequences.private
-growable accessors ;
+growable accessors math.order ;
IN: heaps
MIXIN: priority-queue
@@ -92,11 +92,11 @@ M: priority-queue heap-size ( heap -- n )
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
-: (heap-compare) drop [ entry-key ] compare 0 ; inline
+: (heap-compare) drop [ entry-key ] compare ; inline
-M: min-heap heap-compare (heap-compare) > ;
+M: min-heap heap-compare (heap-compare) +gt+ eq? ;
-M: max-heap heap-compare (heap-compare) < ;
+M: max-heap heap-compare (heap-compare) +lt+ eq? ;
: heap-bounds-check? ( m heap -- ? )
heap-size >= ; inline
diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor
index 91314d1312..2fd867f442 100755
--- a/core/inference/backend/backend-docs.factor
+++ b/core/inference/backend/backend-docs.factor
@@ -43,9 +43,9 @@ HELP: consume/produce
{ $values { "node" "a dataflow node" } { "effect" "an instance of " { $link effect } } }
{ $description "Adds a node to the dataflow graph that calls " { $snippet "word" } " with a stack effect of " { $snippet "effect" } "." } ;
-HELP: no-effect
+HELP: cannot-infer-effect
{ $values { "word" word } }
-{ $description "Throws a " { $link no-effect } " error." }
+{ $description "Throws a " { $link cannot-infer-effect } " error." }
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
HELP: inline-word
@@ -61,8 +61,8 @@ HELP: effect-error
{ $description "Throws an " { $link effect-error } "." }
{ $error-description "Thrown when a word's inferred stack effect does not match its declared stack effect." } ;
-HELP: recursive-declare-error
-{ $error-description "Thrown when inference encounters a recursive call to a word lacking a stack effect declaration. Recursive words must declare a stack effect in order to compile. Due to implementation detail, generic words are recursive, and thus the same restriction applies." } ;
+HELP: missing-effect
+{ $error-description "Thrown when inference encounters a word lacking a stack effect declaration. Stack effects of words must be declared, with the exception of words which only push literals on the stack." } ;
HELP: recursive-quotation-error
{ $error-description "Thrown when a quotation calls itself, directly or indirectly, within the same word. Stack effect inference becomes equivalent to the halting problem if quotation recursion has to be taken into account, hence it is not permitted." }
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index f60748a5ac..080e77af02 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors
-generic.standard.engines.tuple accessors ;
+generic.standard.engines.tuple accessors math.order definitions ;
IN: inference.backend
: recursive-label ( word -- label/f )
@@ -21,6 +21,28 @@ M: engine-word inline?
M: word inline?
"inline" word-prop ;
+SYMBOL: visited
+
+: reset-on-redefine { "inferred-effect" "cannot-infer" } ; inline
+
+: (redefined) ( word -- )
+ dup visited get key? [ drop ] [
+ [ reset-on-redefine reset-props ]
+ [ dup visited get set-at ]
+ [
+ crossref get at keys
+ [ word? ] filter
+ [
+ [ reset-on-redefine [ word-prop ] with contains? ]
+ [ inline? ]
+ bi or
+ ] filter
+ [ (redefined) ] each
+ ] tri
+ ] if ;
+
+M: word redefined H{ } clone visited [ (redefined) ] with-variable ;
+
: local-recursive-state ( -- assoc )
recursive-state get dup keys
[ dup word? [ inline? ] when not ] find drop
@@ -60,7 +82,7 @@ M: object value-literal \ literal-expected inference-warning ;
: value-vector ( n -- vector ) [ drop ] V{ } map-as ;
: add-inputs ( seq stack -- n stack )
- tuck [ length ] compare dup 0 >
+ tuck [ length ] bi@ - dup 0 >
[ dup value-vector [ swapd push-all ] keep ]
[ drop 0 swap ] if ;
@@ -68,8 +90,9 @@ M: object value-literal \ literal-expected inference-warning ;
meta-d [ add-inputs ] change d-in [ + ] change ;
: current-effect ( -- effect )
- d-in get meta-d get length
- terminated? get over set-effect-terminated? ;
+ d-in get
+ meta-d get length
+ terminated? get >>terminated? ;
: init-inference ( -- )
terminated? off
@@ -93,13 +116,13 @@ M: wrapper apply-object
terminated? on #terminate node, ;
: infer-quot ( quot rstate -- )
- recursive-state get >r
- recursive-state set
- [ apply-object terminated? get not ] all? drop
- r> recursive-state set ;
+ recursive-state get [
+ recursive-state set
+ [ apply-object terminated? get not ] all? drop
+ ] dip recursive-state set ;
: infer-quot-recursive ( quot word label -- )
- recursive-state get -rot 2array prefix infer-quot ;
+ 2array recursive-state get swap prefix infer-quot ;
: time-bomb ( error -- )
[ throw ] curry recursive-state get infer-quot ;
@@ -114,9 +137,9 @@ TUPLE: recursive-quotation-error quot ;
value-literal recursive-quotation-error inference-error
] [
dup value-literal callable? [
- dup value-literal
- over value-recursion
- rot f 2array prefix infer-quot
+ [ value-literal ]
+ [ [ value-recursion ] keep f 2array prefix ]
+ bi infer-quot
] [
drop bad-call
] if
@@ -169,26 +192,26 @@ TUPLE: too-many-r> ;
meta-d get push-all ;
: if-inline ( word true false -- )
- >r >r dup inline? r> r> if ; inline
+ [ dup inline? ] 2dip if ; inline
: consume/produce ( effect node -- )
- over effect-in over consume-values
- over effect-out over produce-values
- node,
- effect-terminated? [ terminate ] when ;
+ [ [ in>> ] dip consume-values ]
+ [ [ out>> ] dip produce-values ]
+ [ node, terminated?>> [ terminate ] when ]
+ 2tri ;
GENERIC: constructor ( value -- word/f )
GENERIC: infer-uncurry ( value -- )
M: curried infer-uncurry
- drop pop-d dup curried-obj push-d curried-quot push-d ;
+ drop pop-d [ obj>> push-d ] [ quot>> push-d ] bi ;
M: curried constructor
drop \ curry ;
M: composed infer-uncurry
- drop pop-d dup composed-quot1 push-d composed-quot2 push-d ;
+ drop pop-d [ quot1>> push-d ] [ quot2>> push-d ] bi ;
M: composed constructor
drop \ compose ;
@@ -233,13 +256,13 @@ M: object constructor drop f ;
DEFER: unify-values
: unify-curries ( seq -- value )
- dup [ curried-obj ] map unify-values
- swap [ curried-quot ] map unify-values
+ [ [ obj>> ] map unify-values ]
+ [ [ quot>> ] map unify-values ] bi
;
: unify-composed ( seq -- value )
- dup [ composed-quot1 ] map unify-values
- swap [ composed-quot2 ] map unify-values
+ [ [ quot1>> ] map unify-values ]
+ [ [ quot2>> ] map unify-values ] bi
;
TUPLE: cannot-unify-specials ;
@@ -261,7 +284,7 @@ TUPLE: cannot-unify-specials ;
: balanced? ( in out -- ? )
[ dup [ length - ] [ 2drop f ] if ] 2map
- [ ] subset all-equal? ;
+ sift all-equal? ;
TUPLE: unbalanced-branches-error quots in out ;
@@ -270,7 +293,7 @@ TUPLE: unbalanced-branches-error quots in out ;
: unify-inputs ( max-d-in d-in meta-d -- meta-d )
dup [
- [ >r - r> length + ] keep add-inputs nip
+ [ [ - ] dip length + ] keep add-inputs nip
] [
2nip
] if ;
@@ -281,7 +304,7 @@ TUPLE: unbalanced-branches-error quots in out ;
2dup balanced? [
over supremum -rot
[ >r dupd r> unify-inputs ] 2map
- [ ] subset unify-stacks
+ sift unify-stacks
rot drop
] [
unbalanced-branches-error
@@ -296,21 +319,24 @@ TUPLE: unbalanced-branches-error quots in out ;
[ swap at ] curry map ;
: datastack-effect ( seq -- )
- dup quotation branch-variable
- over d-in branch-variable
- rot meta-d active-variable
- unify-effect meta-d set d-in set ;
+ [ quotation branch-variable ]
+ [ d-in branch-variable ]
+ [ meta-d active-variable ] tri
+ unify-effect
+ [ d-in set ] [ meta-d set ] bi* ;
: retainstack-effect ( seq -- )
- dup quotation branch-variable
- over length 0
- rot meta-r active-variable
- unify-effect meta-r set drop ;
+ [ quotation branch-variable ]
+ [ length 0 ]
+ [ meta-r active-variable ] tri
+ unify-effect
+ [ drop ] [ meta-r set ] bi* ;
: unify-effects ( seq -- )
- dup datastack-effect
- dup retainstack-effect
- [ terminated? swap at ] all? terminated? set ;
+ [ datastack-effect ]
+ [ retainstack-effect ]
+ [ [ terminated? swap at ] all? terminated? set ]
+ tri ;
: unify-dataflow ( effects -- nodes )
dataflow-graph branch-variable ;
@@ -325,14 +351,17 @@ TUPLE: unbalanced-branches-error quots in out ;
: infer-branch ( last value -- namespace )
[
copy-inference
- dup value-literal quotation set
- infer-quot-value
+
+ [ value-literal quotation set ]
+ [ infer-quot-value ]
+ bi
+
terminated? get [ drop ] [ call node, ] if
] H{ } make-assoc ; inline
: (infer-branches) ( last branches -- list )
[ infer-branch ] with map
- dup unify-effects unify-dataflow ; inline
+ [ unify-effects ] [ unify-dataflow ] bi ; inline
: infer-branches ( last branches node -- )
#! last is a quotation which provides a #return or a #values
@@ -353,24 +382,43 @@ TUPLE: unbalanced-branches-error quots in out ;
#call consume/produce
] if ;
-TUPLE: no-effect word ;
+TUPLE: cannot-infer-effect word ;
-: no-effect ( word -- * ) \ no-effect inference-warning ;
+: cannot-infer-effect ( word -- * )
+ \ cannot-infer-effect inference-warning ;
-TUPLE: effect-error word effect ;
+TUPLE: effect-error word inferred declared ;
-: effect-error ( word effect -- * )
+: effect-error ( word inferred declared -- * )
\ effect-error inference-error ;
+TUPLE: missing-effect word ;
+
+: effect-required? ( word -- ? )
+ {
+ { [ dup inline? ] [ drop f ] }
+ { [ dup deferred? ] [ drop f ] }
+ { [ dup crossref? not ] [ drop f ] }
+ [ word-def [ [ word? ] [ primitive? not ] bi and ] contains? ]
+ } cond ;
+
+: ?missing-effect ( word -- )
+ dup effect-required?
+ [ missing-effect inference-error ] [ drop ] if ;
+
: check-effect ( word effect -- )
- dup pick stack-effect effect<=
- [ 2drop ] [ effect-error ] if ;
+ over stack-effect {
+ { [ dup not ] [ 2drop ?missing-effect ] }
+ { [ 2dup effect<= ] [ 3drop ] }
+ [ effect-error ]
+ } cond ;
: finish-word ( word -- )
current-effect
- 2dup check-effect
- over recorded get push
- "inferred-effect" set-word-prop ;
+ [ check-effect ]
+ [ drop recorded get push ]
+ [ "inferred-effect" set-word-prop ]
+ 2tri ;
: infer-word ( word -- effect )
[
@@ -382,12 +430,11 @@ TUPLE: effect-error word effect ;
finish-word
current-effect
] with-scope
- ] [ ] [ t "no-effect" set-word-prop ] cleanup ;
+ ] [ ] [ t "cannot-infer" set-word-prop ] cleanup ;
: custom-infer ( word -- )
#! Customized inference behavior
- dup +inlined+ depends-on
- "infer" word-prop call ;
+ [ +inlined+ depends-on ] [ "infer" word-prop call ] bi ;
: cached-infer ( word -- )
dup "inferred-effect" word-prop make-call-node ;
@@ -395,18 +442,16 @@ TUPLE: effect-error word effect ;
: apply-word ( word -- )
{
{ [ dup "infer" word-prop ] [ custom-infer ] }
- { [ dup "no-effect" word-prop ] [ no-effect ] }
+ { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
[ dup infer-word make-call-node ]
} cond ;
-TUPLE: recursive-declare-error word ;
-
-: declared-infer ( word -- )
+: declared-infer ( word -- )
dup stack-effect [
make-call-node
] [
- \ recursive-declare-error inference-error
+ \ missing-effect inference-error
] if* ;
GENERIC: collect-label-info* ( label node -- )
@@ -434,47 +479,67 @@ M: #return collect-label-info*
dup node-param #return node,
dataflow-graph get 1array over set-node-children ;
-: inlined-block? "inlined-block" word-prop ;
+: inlined-block? ( word -- ? )
+ "inlined-block" word-prop ;
-: gensym dup t "inlined-block" set-word-prop ;
+: ( -- word )
+ gensym dup t "inlined-block" set-word-prop ;
: inline-block ( word -- #label data )
[
copy-inference nest-node
- dup word-def swap
+ [ word-def ] [ ] bi
[ infer-quot-recursive ] 2keep
#label unnest-node
dup collect-label-info
] H{ } make-assoc ;
: join-values ( #label -- )
- calls>> [ node-in-d ] map meta-d get suffix
+ calls>> [ in-d>> ] map meta-d get suffix
unify-lengths unify-stacks
meta-d [ length tail* ] change ;
: splice-node ( node -- )
- dup node-successor [
- dup node, penultimate-node f over set-node-successor
- dup current-node set
- ] when drop ;
+ dup successor>> [
+ [ node, ] [ penultimate-node ] bi
+ f >>successor
+ current-node set
+ ] [ drop ] if ;
-: apply-infer ( hash -- )
- { meta-d meta-r d-in terminated? }
- [ swap [ at ] curry map ] keep
- [ set ] 2each ;
+: apply-infer ( data -- )
+ { meta-d meta-r d-in terminated? } swap extract-keys
+ namespace swap update ;
+
+: current-stack-height ( -- n )
+ d-in get meta-d get length - ;
+
+: word-stack-height ( word -- n )
+ stack-effect effect-height ;
+
+: bad-recursive-declaration ( word inferred -- )
+ dup 0 < [ 0 swap ] [ 0 ] if
+ over stack-effect
+ effect-error ;
+
+: check-stack-height ( word height -- )
+ over word-stack-height over =
+ [ 2drop ] [ bad-recursive-declaration ] if ;
+
+: inline-recursive-word ( word #label -- )
+ current-stack-height [
+ flatten-meta-d [ join-values inline-block apply-infer ] dip >>in-d
+ [ node, ]
+ [ calls>> [ [ flatten-curries ] modify-values ] each ]
+ [ word>> ]
+ tri
+ ] dip
+ current-stack-height -
+ check-stack-height ;
: inline-word ( word -- )
- dup inline-block over recursive-label? [
- flatten-meta-d >r
- drop join-values inline-block apply-infer
- r> over set-node-in-d
- dup node,
- calls>> [
- [ flatten-curries ] modify-values
- ] each
- ] [
- apply-infer node-child node-successor splice-node drop
- ] if ;
+ dup inline-block over recursive-label?
+ [ drop inline-recursive-word ]
+ [ apply-infer node-child successor>> splice-node drop ] if ;
M: word apply-object
[
diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor
index 0c4ff82798..770763bfb6 100755
--- a/core/inference/class/class-tests.factor
+++ b/core/inference/class/class-tests.factor
@@ -5,7 +5,7 @@ sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts vectors optimizer.math.partial accessors
-optimizer.inlining ;
+optimizer.inlining math.order ;
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
@@ -142,7 +142,7 @@ M: object xyz ;
[ f ] [ [ length ] \ slot inlined? ] unit-test
! We don't want to use = to compare literals
-: foo reverse ;
+: foo ( seq -- seq' ) reverse ;
\ foo [
[
diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index 6d5b708f34..2f7058ba96 100755
--- a/core/inference/class/class.factor
+++ b/core/inference/class/class.factor
@@ -41,11 +41,11 @@ C: interval-constraint
GENERIC: apply-constraint ( constraint -- )
GENERIC: constraint-satisfied? ( constraint -- ? )
-: `input node get in-d>> nth ;
-: `output node get out-d>> nth ;
-: class, , ;
-: literal, , ;
-: interval, , ;
+: `input ( n -- value ) node get in-d>> nth ;
+: `output ( n -- value ) node get out-d>> nth ;
+: class, ( class value -- ) , ;
+: literal, ( literal value -- ) , ;
+: interval, ( interval value -- ) , ;
M: f apply-constraint drop ;
@@ -143,7 +143,7 @@ M: literal-constraint constraint-satisfied?
[ swap literal>> eql? ] [ 2drop f ] if ;
M: class-constraint constraint-satisfied?
- [ value>> value-class* ] [ class>> ] bi class< ;
+ [ value>> value-class* ] [ class>> ] bi class<= ;
M: pair apply-constraint
first2 2dup constraints get set-at
@@ -152,16 +152,16 @@ M: pair apply-constraint
M: pair constraint-satisfied?
first constraint-satisfied? ;
-: extract-keys ( seq assoc -- newassoc )
- [ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
+: valid-keys ( seq assoc -- newassoc )
+ extract-keys [ nip ] assoc-filter f assoc-like ;
: annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of
#! value classes.
dup node-values {
- [ value-intervals get extract-keys >>intervals ]
- [ value-classes get extract-keys >>classes ]
- [ value-literals get extract-keys >>literals ]
+ [ value-intervals get valid-keys >>intervals ]
+ [ value-classes get valid-keys >>classes ]
+ [ value-literals get valid-keys >>literals ]
[ 2drop ]
} cleave ;
@@ -330,7 +330,7 @@ M: #return infer-classes-around
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
classes= not [
fixed-point? off
- [ in-d>> value-classes get extract-keys ] keep
+ [ in-d>> value-classes get valid-keys ] keep
set-node-classes
] [ drop ] if
] [ call-next-method ] if
diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor
index bb66a5386c..734c1c551c 100755
--- a/core/inference/dataflow/dataflow.factor
+++ b/core/inference/dataflow/dataflow.factor
@@ -6,7 +6,7 @@ inference.state accessors combinators ;
IN: inference.dataflow
! Computed value
-: \ counter ;
+: ( -- value ) \ counter ;
! Literal value
TUPLE: value < identity-tuple literal uid recursion ;
@@ -88,7 +88,7 @@ M: object flatten-curry , ;
: r-tail ( n -- seq )
dup zero? [ drop f ] [ meta-r get swap tail* ] if ;
-: node-child node-children first ;
+: node-child ( node -- child ) node-children first ;
TUPLE: #label < node word loop? returns calls ;
@@ -217,9 +217,9 @@ M: #call-label calls-label* param>> eq? ;
SYMBOL: node-stack
-: >node node-stack get push ;
-: node> node-stack get pop ;
-: node@ node-stack get peek ;
+: >node ( node -- ) node-stack get push ;
+: node> ( -- node ) node-stack get pop ;
+: node@ ( -- node ) node-stack get peek ;
: iterate-next ( -- node ) node@ successor>> ;
@@ -300,7 +300,7 @@ SYMBOL: node-stack
dup in-d>> first node-class ;
: active-children ( node -- seq )
- children>> [ last-node ] map [ #terminate? not ] subset ;
+ children>> [ last-node ] map [ #terminate? not ] filter ;
DEFER: #tail?
diff --git a/core/inference/errors/errors.factor b/core/inference/errors/errors.factor
index f565420cac..4a75040243 100644
--- a/core/inference/errors/errors.factor
+++ b/core/inference/errors/errors.factor
@@ -5,20 +5,18 @@ USING: inference.backend inference.dataflow kernel generic
sequences prettyprint io words arrays inspector effects debugger
assocs accessors ;
+M: inference-error error-help error>> error-help ;
+
M: inference-error error.
dup rstate>>
keys [ dup value? [ value-literal ] when ] map
dup empty? [ "Word: " write dup peek . ] unless
swap error>> error. "Nesting: " write . ;
-M: inference-error error-help drop f ;
-
M: unbalanced-branches-error error.
"Unbalanced branches:" print
- dup unbalanced-branches-error-quots
- over unbalanced-branches-error-in
- rot unbalanced-branches-error-out [ length ] map
- 3array flip [ [ bl ] [ pprint ] interleave nl ] each ;
+ [ quots>> ] [ in>> ] [ out>> [ length ] map ] tri 3array flip
+ [ [ bl ] [ pprint ] interleave nl ] each ;
M: literal-expected summary
drop "Literal value expected" ;
@@ -31,25 +29,23 @@ M: too-many-r> summary
drop
"Quotation pops retain stack elements which it did not push" ;
-M: no-effect error.
- "Unable to infer stack effect of " write no-effect-word . ;
+M: cannot-infer-effect error.
+ "Unable to infer stack effect of " write word>> . ;
-M: recursive-declare-error error.
- "The recursive word " write
- recursive-declare-error-word pprint
+M: missing-effect error.
+ "The word " write
+ word>> pprint
" must declare a stack effect" print ;
M: effect-error error.
"Stack effects of the word " write
- dup effect-error-word pprint
- " do not match." print
- "Declared: " write
- dup effect-error-word stack-effect effect>string .
- "Inferred: " write effect-error-effect effect>string . ;
+ [ word>> pprint " do not match." print ]
+ [ "Inferred: " write inferred>> effect>string . ]
+ [ "Declared: " write declared>> effect>string . ] tri ;
M: recursive-quotation-error error.
"The quotation " write
- recursive-quotation-error-quot pprint
+ quot>> pprint
" calls itself." print
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor
index e32c94ed37..5900e5a844 100755
--- a/core/inference/inference-docs.factor
+++ b/core/inference/inference-docs.factor
@@ -83,13 +83,13 @@ ARTICLE: "inference-errors" "Inference errors"
"Main wrapper for all inference errors:"
{ $subsection inference-error }
"Specific inference errors:"
-{ $subsection no-effect }
+{ $subsection cannot-infer-effect }
{ $subsection literal-expected }
{ $subsection too-many->r }
{ $subsection too-many-r> }
{ $subsection unbalanced-branches-error }
{ $subsection effect-error }
-{ $subsection recursive-declare-error } ;
+{ $subsection missing-effect } ;
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
@@ -108,7 +108,8 @@ $nl
{ $subsection "inference-limitations" }
{ $subsection "inference-errors" }
{ $subsection "dataflow-graphs" }
-{ $subsection "compiler-transforms" } ;
+{ $subsection "compiler-transforms" }
+{ $see-also "effects" } ;
ABOUT: "inference"
@@ -135,7 +136,7 @@ HELP: infer
HELP: infer.
{ $values { "quot" "a quotation" } }
-{ $description "Attempts to infer the quotation's stack effect, and prints this data to the " { $link stdio } " stream." }
+{ $description "Attempts to infer the quotation's stack effect, and prints this data to " { $link output-stream } "." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
{ infer infer. } related-words
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index f688f60e56..7f073bfad9 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -5,7 +5,7 @@ sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions
prettyprint io inspector classes.tuple classes.union
classes.predicate debugger threads.private io.streams.string
-io.timeouts io.thread sequences.private ;
+io.timeouts io.thread sequences.private destructors ;
IN: inference.tests
[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
@@ -48,20 +48,12 @@ IN: inference.tests
] must-fail
! Test inference of termination of control flow
-: termination-test-1
- "foo" throw ;
+: termination-test-1 ( -- * ) "foo" throw ;
-: termination-test-2 [ termination-test-1 ] [ 3 ] if ;
+: termination-test-2 ( ? -- x ) [ termination-test-1 ] [ 3 ] if ;
{ 1 1 } [ termination-test-2 ] must-infer-as
-: infinite-loop infinite-loop ;
-
-[ [ infinite-loop ] infer ] must-fail
-
-: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
-[ [ no-base-case-1 ] infer ] must-fail
-
: simple-recursion-1 ( obj -- obj )
dup [ simple-recursion-1 ] [ ] if ;
@@ -131,7 +123,7 @@ SYMBOL: sym-test
{ 0 1 } [ sym-test ] must-infer-as
-: terminator-branch
+: terminator-branch ( a -- b )
dup [
length
] [
@@ -198,11 +190,10 @@ DEFER: blah4
[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
! Regression
-: bad-input#
+{ 2 2 } [
dup string? [ 2array throw ] unless
- over string? [ 2array throw ] unless ;
-
-{ 2 2 } [ bad-input# ] must-infer-as
+ over string? [ 2array throw ] unless
+] must-infer-as
! Regression
@@ -224,7 +215,7 @@ DEFER: do-crap*
{ 2 1 } [ too-deep ] must-infer-as
! Error reporting is wrong
-MATH: xyz
+MATH: xyz ( a b -- c )
M: fixnum xyz 2array ;
M: float xyz
[ 3 ] bi@ swapd >r 2array swap r> 2array swap ;
@@ -448,7 +439,7 @@ DEFER: bar
! Incorrect stack declarations on inline recursive words should
! be caught
: fooxxx ( a b -- c ) over [ foo ] when ; inline
-: barxxx fooxxx ;
+: barxxx ( a b -- c ) fooxxx ;
[ [ barxxx ] infer ] must-fail
@@ -472,9 +463,7 @@ M: string my-hook "a string" ;
DEFER: deferred-word
-: calls-deferred-word [ deferred-word ] [ 3 ] if ;
-
-{ 1 1 } [ calls-deferred-word ] must-infer-as
+{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
USE: inference.dataflow
@@ -547,3 +536,36 @@ ERROR: custom-error ;
[ [ missing->r-check ] infer ] must-fail
{ 1 0 } [ [ ] map-children ] must-infer-as
+
+! Corner case
+[ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
+
+[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
+
+: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
+
+[ [ erg's-inference-bug ] infer ] must-fail
+
+! : inference-invalidation-a ( -- );
+! : inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
+! : inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ;
+!
+! [ 7 ] [ 4 3 inference-invalidation-c ] unit-test
+!
+! { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
+!
+! [ ] [ "IN: inference.tests : inference-invalidation-a 1 2 ;" eval ] unit-test
+!
+! [ 3 ] [ inference-invalidation-c ] unit-test
+!
+! { 0 1 } [ inference-invalidation-c ] must-infer-as
+!
+! GENERIC: inference-invalidation-d ( obj -- )
+!
+! M: object inference-invalidation-d inference-invalidation-c 2drop ;
+!
+! \ inference-invalidation-d must-infer
+!
+! [ ] [ "IN: inference.tests : inference-invalidation-a ;" eval ] unit-test
+!
+! [ [ inference-invalidation-d ] infer ] must-fail
diff --git a/core/inference/inference.factor b/core/inference/inference.factor
index 3f52eaadf4..d73e43cdfc 100755
--- a/core/inference/inference.factor
+++ b/core/inference/inference.factor
@@ -29,6 +29,6 @@ M: callable dataflow-with
: forget-errors ( -- )
all-words [
- dup subwords [ f "no-effect" set-word-prop ] each
- f "no-effect" set-word-prop
+ dup subwords [ f "cannot-infer" set-word-prop ] each
+ f "cannot-infer" set-word-prop
] each ;
diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor
index b68c98d25d..3282cbb5e2 100755
--- a/core/inference/known-words/known-words.factor
+++ b/core/inference/known-words/known-words.factor
@@ -356,13 +356,13 @@ M: object infer-call
\ setenv { object fixnum } { } set-primitive-effect
-\ exists? { string } { object } set-primitive-effect
+\ (exists?) { string } { object } set-primitive-effect
\ (directory) { string } { array } set-primitive-effect
\ gc { } { } set-primitive-effect
-\ gc-time { } { integer } set-primitive-effect
+\ gc-stats { } { array } set-primitive-effect
\ save-image { string } { } set-primitive-effect
@@ -372,7 +372,7 @@ M: object infer-call
t over set-effect-terminated?
set-primitive-effect
-\ data-room { } { integer array } set-primitive-effect
+\ data-room { } { integer integer array } set-primitive-effect
\ data-room make-flushable
\ code-room { } { integer integer integer integer } set-primitive-effect
@@ -583,7 +583,7 @@ set-primitive-effect
\ (set-os-envs) { array } { } set-primitive-effect
-\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
+\ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop
\ dll-valid? { object } { object } set-primitive-effect
diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor
index 84d72bdd9b..21f59bf020 100644
--- a/core/inference/state/state-tests.factor
+++ b/core/inference/state/state-tests.factor
@@ -1,5 +1,10 @@
IN: inference.state.tests
-USING: tools.test inference.state words ;
+USING: tools.test inference.state words kernel namespaces
+definitions ;
+
+: computing-dependencies ( quot -- dependencies )
+ H{ } clone [ dependencies rot with-variable ] keep ;
+ inline
SYMBOL: a
SYMBOL: b
diff --git a/core/inference/state/state.factor b/core/inference/state/state.factor
index a426f410e2..1d1ccaa2a9 100755
--- a/core/inference/state/state.factor
+++ b/core/inference/state/state.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel words ;
+USING: assocs namespaces sequences kernel definitions ;
IN: inference.state
! Nesting state to solve recursion
@@ -12,16 +12,16 @@ SYMBOL: d-in
! Compile-time data stack
SYMBOL: meta-d
-: push-d meta-d get push ;
-: pop-d meta-d get pop ;
-: peek-d meta-d get peek ;
+: push-d ( obj -- ) meta-d get push ;
+: pop-d ( -- obj ) meta-d get pop ;
+: peek-d ( -- obj ) meta-d get peek ;
! Compile-time retain stack
SYMBOL: meta-r
-: push-r meta-r get push ;
-: pop-r meta-r get pop ;
-: peek-r meta-r get peek ;
+: push-r ( obj -- ) meta-r get push ;
+: pop-r ( -- obj ) meta-r get pop ;
+: peek-r ( -- obj ) meta-r get peek ;
! Head of dataflow IR
SYMBOL: dataflow-graph
@@ -36,10 +36,6 @@ SYMBOL: dependencies
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
] [ 3drop ] if ;
-: computing-dependencies ( quot -- dependencies )
- H{ } clone [ dependencies rot with-variable ] keep ;
- inline
-
! Did the current control-flow path throw an error?
SYMBOL: terminated?
diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor
index a5b898315a..f90dd2350c 100755
--- a/core/inference/transforms/transforms-tests.factor
+++ b/core/inference/transforms/transforms-tests.factor
@@ -3,10 +3,10 @@ USING: sequences inference.transforms tools.test math kernel
quotations inference accessors combinators words arrays
classes ;
-: compose-n-quot >quotation ;
-: compose-n compose-n-quot call ;
+: compose-n-quot ( word -- quot' ) >quotation ;
+: compose-n ( quot -- ) compose-n-quot call ;
\ compose-n [ compose-n-quot ] 2 define-transform
-: compose-n-test 2 \ + compose-n ;
+: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
@@ -20,25 +20,12 @@ classes ;
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
-\ new must-infer
-
-TUPLE: a-tuple x y z ;
-
-: set-slots-test ( x y z -- )
- { set-a-tuple-x set-a-tuple-y } set-slots ;
-
-\ set-slots-test must-infer
-
-: set-slots-test-2
- { set-a-tuple-x set-a-tuple-x } set-slots ;
-
-[ [ set-slots-test-2 ] infer ] must-fail
-
TUPLE: color r g b ;
C: color
-: cleave-test { [ r>> ] [ g>> ] [ b>> ] } cleave ;
+: cleave-test ( color -- r g b )
+ { [ r>> ] [ g>> ] [ b>> ] } cleave ;
{ 1 3 } [ cleave-test ] must-infer-as
@@ -46,13 +33,13 @@ C: color
[ 1 2 3 ] [ 1 2 3 \ cleave-test word-def call ] unit-test
-: 2cleave-test { [ 2array ] [ + ] [ - ] } 2cleave ;
+: 2cleave-test ( a b -- c d e ) { [ 2array ] [ + ] [ - ] } 2cleave ;
[ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test
[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test word-def call ] unit-test
-: spread-test { [ sq ] [ neg ] [ recip ] } spread ;
+: spread-test ( a b c -- d e f ) { [ sq ] [ neg ] [ recip ] } spread ;
[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor
index 624dcbbf98..5ca10c7545 100755
--- a/core/inference/transforms/transforms.factor
+++ b/core/inference/transforms/transforms.factor
@@ -3,7 +3,7 @@
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state classes.tuple.private effects
-inspector hashtables classes generic sets ;
+inspector hashtables classes generic sets definitions ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
@@ -32,7 +32,7 @@ IN: inference.transforms
drop [ no-case ]
] [
dup peek quotation? [
- dup peek swap 1 head*
+ dup peek swap but-last
] [
[ no-case ] swap
] if case>quot
diff --git a/core/inspector/inspector-docs.factor b/core/inspector/inspector-docs.factor
index 84ae34480d..ab1c38b0b7 100644
--- a/core/inspector/inspector-docs.factor
+++ b/core/inspector/inspector-docs.factor
@@ -108,4 +108,4 @@ HELP: me
HELP: inspector-hook
{ $var-description "A quotation with stack effect " { $snippet "( obj -- )" } ", called by the inspector to display an overview of an object."
$nl
-"The default implementation calls " { $link describe } " which outputs on the " { $link stdio } " stream, but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ;
+"The default implementation calls " { $link describe } " which outputs on " { $link output-stream } ", but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ;
diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor
index c9bfbfad54..0ab016b0fa 100755
--- a/core/inspector/inspector.factor
+++ b/core/inspector/inspector.factor
@@ -96,7 +96,7 @@ SYMBOL: +editable+
: namestack. ( seq -- )
[
- [ global eq? not ] subset
+ [ global eq? not ] filter
[ keys ] map concat prune
] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
diff --git a/core/io/backend/backend-docs.factor b/core/io/backend/backend-docs.factor
index 8bf761e2a6..48b49ed32b 100644
--- a/core/io/backend/backend-docs.factor
+++ b/core/io/backend/backend-docs.factor
@@ -9,4 +9,4 @@ HELP: init-io
{ $contract "Initializes the I/O system. Called on startup." } ;
HELP: init-stdio
-{ $contract "Initializes the global " { $link stdio } " stream. Called on startup." } ;
+{ $contract "Initializes the global " { $link input-stream } " and " { $link output-stream } ". Called on startup." } ;
diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor
index 44b1eea349..0760063f0d 100755
--- a/core/io/backend/backend.factor
+++ b/core/io/backend/backend.factor
@@ -11,8 +11,10 @@ HOOK: init-io io-backend ( -- )
HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
: init-stdio ( -- )
- (init-stdio) utf8 stderr set-global
- utf8 stdio set-global ;
+ (init-stdio)
+ [ utf8 input-stream set-global ]
+ [ utf8 output-stream set-global ]
+ [ utf8 error-stream set-global ] tri* ;
HOOK: io-multiplex io-backend ( ms -- )
diff --git a/core/io/binary/binary-docs.factor b/core/io/binary/binary-docs.factor
index edf65491fe..ab82abe146 100644
--- a/core/io/binary/binary-docs.factor
+++ b/core/io/binary/binary-docs.factor
@@ -1,17 +1,17 @@
-USING: help.markup help.syntax io math ;
+USING: help.markup help.syntax io math byte-arrays ;
IN: io.binary
ARTICLE: "stream-binary" "Working with binary data"
-"The core stream words read and write strings. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")."
+"Stream words on binary streams only read and write byte arrays. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")."
$nl
"There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around."
$nl
-"Consider the hexadecimal integer "{ $snippet "HEX: cafebabe" } ". Big endian byte order yields the following sequence of bytes:"
+"Consider the hexadecimal integer "{ $snippet "HEX: cafebabe" } ". Little endian byte order yields the following sequence of bytes:"
{ $table
{ "Byte:" "1" "2" "3" "4" }
{ "Value:" { $snippet "be" } { $snippet "ba" } { $snippet "fe" } { $snippet "ca" } }
}
-"Compare this with little endian byte order:"
+"Compare this with big endian byte order:"
{ $table
{ "Byte:" "1" "2" "3" "4" }
{ "Value:" { $snippet "ca" } { $snippet "fe" } { $snippet "ba" } { $snippet "be" } }
@@ -42,11 +42,11 @@ HELP: nth-byte
{ $description "Outputs the " { $snippet "n" } "th least significant byte of the sign-extended 2's complement representation of " { $snippet "x" } "." } ;
HELP: >le
-{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } }
+{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in little endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
HELP: >be
-{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } }
+{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in big endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
HELP: mask-byte
diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor
index f2ede93fd5..f3d236433f 100755
--- a/core/io/binary/binary.factor
+++ b/core/io/binary/binary.factor
@@ -10,8 +10,8 @@ IN: io.binary
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
-: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ;
-: >be ( x n -- str ) >le dup reverse-here ;
+: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ;
+: >be ( x n -- byte-array ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 )
dup HEX: ffffffff bitand
diff --git a/core/io/crc32/crc32-docs.factor b/core/io/crc32/crc32-docs.factor
deleted file mode 100644
index 7f85ee2b4e..0000000000
--- a/core/io/crc32/crc32-docs.factor
+++ /dev/null
@@ -1,17 +0,0 @@
-USING: help.markup help.syntax math ;
-IN: io.crc32
-
-HELP: crc32
-{ $values { "seq" "a sequence of bytes" } { "n" integer } }
-{ $description "Computes the CRC32 checksum of a sequence of bytes." } ;
-
-HELP: lines-crc32
-{ $values { "seq" "a sequence of strings" } { "n" integer } }
-{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
-
-ARTICLE: "io.crc32" "CRC32 checksum calculation"
-"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
-{ $subsection crc32 }
-{ $subsection lines-crc32 } ;
-
-ABOUT: "io.crc32"
diff --git a/core/io/crc32/crc32-tests.factor b/core/io/crc32/crc32-tests.factor
deleted file mode 100644
index 5eafae23cb..0000000000
--- a/core/io/crc32/crc32-tests.factor
+++ /dev/null
@@ -1,5 +0,0 @@
-USING: io.crc32 kernel math tools.test namespaces ;
-
-[ 0 ] [ "" crc32 ] unit-test
-[ HEX: cbf43926 ] [ "123456789" crc32 ] unit-test
-
diff --git a/core/io/encodings/binary/binary.factor b/core/io/encodings/binary/binary.factor
old mode 100644
new mode 100755
index 5038628ed9..e54163f632
--- a/core/io/encodings/binary/binary.factor
+++ b/core/io/encodings/binary/binary.factor
@@ -3,6 +3,6 @@
USING: io.encodings kernel ;
IN: io.encodings.binary
-TUPLE: binary ;
+SINGLETON: binary
M: binary drop ;
M: binary drop ;
diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor
index 8a176ce4ec..92471acb5d 100644
--- a/core/io/encodings/encodings-docs.factor
+++ b/core/io/encodings/encodings-docs.factor
@@ -12,8 +12,7 @@ ARTICLE: "io.encodings" "I/O encodings"
ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
"The following words can be used to construct encoded streams. Note that they are usually not used directly, but rather by the stream constructors themselves. Most stream constructors take an encoding descriptor as a parameter and internally call these constructors."
{ $subsection }
-{ $subsection }
-{ $subsection } ;
+{ $subsection } ;
HELP:
{ $values { "stream" "an output stream" }
@@ -29,16 +28,6 @@ HELP:
{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
$low-level-note ;
-HELP:
-{ $values { "stream-in" "an input stream" }
- { "stream-out" "an output stream" }
- { "encoding" "an encoding descriptor" }
- { "duplex" "an encoded duplex stream" } }
-{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." }
-$low-level-note ;
-
-{ } related-words
-
ARTICLE: "encodings-descriptors" "Encoding descriptors"
"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
{ $subsection "io.encodings.binary" }
diff --git a/core/io/encodings/encodings-tests.factor b/core/io/encodings/encodings-tests.factor
index 397d1ea89c..ea74490858 100755
--- a/core/io/encodings/encodings-tests.factor
+++ b/core/io/encodings/encodings-tests.factor
@@ -1,36 +1,37 @@
-USING: io.files io.streams.string io
-tools.test kernel io.encodings.ascii ;
+USING: io.files io.streams.string io io.streams.byte-array
+tools.test kernel io.encodings.ascii io.encodings.utf8
+namespaces accessors io.encodings ;
IN: io.streams.encodings.tests
-: ( resource -- stream )
- resource-path ascii ;
-
[ { } ]
-[ "core/io/test/empty-file.txt" lines ]
+[ "resource:core/io/test/empty-file.txt" ascii lines ]
unit-test
: lines-test ( stream -- line1 line2 )
- [ readln readln ] with-stream ;
+ [ readln readln ] with-input-stream ;
[
"This is a line."
"This is another line."
] [
- "core/io/test/windows-eol.txt" lines-test
+ "resource:core/io/test/windows-eol.txt"
+ ascii lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
- "core/io/test/mac-os-eol.txt" lines-test
+ "resource:core/io/test/mac-os-eol.txt"
+ ascii lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
- "core/io/test/unix-eol.txt" lines-test
+ "resource:core/io/test/unix-eol.txt"
+ ascii lines-test
] unit-test
[
@@ -56,3 +57,19 @@ unit-test
dup stream-readln drop
stream-read1
] unit-test
+
+[ utf8 ascii ] [
+ "foo" utf8 [
+ input-stream get code>>
+ ascii decode-input
+ input-stream get code>>
+ ] with-byte-reader
+] unit-test
+
+[ utf8 ascii ] [
+ utf8 [
+ output-stream get code>>
+ ascii encode-output
+ output-stream get code>>
+ ] with-byte-writer drop
+] unit-test
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 4559cec666..3fe6f9d6aa 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces growable
-strings io classes continuations combinators io.styles
-io.streams.plain splitting io.streams.duplex byte-arrays
+strings io classes continuations destructors combinators
+io.styles io.streams.plain splitting byte-arrays
sequences.private accessors ;
IN: io.encodings
@@ -30,8 +30,7 @@ ERROR: encode-error ;
new ;
-M: tuple f decoder boa ;
+M: object f decoder boa ;
: >decoder< ( decoder -- stream encoding )
[ stream>> ] [ code>> ] bi ;
@@ -104,8 +103,7 @@ M: decoder stream-readln ( stream -- str )
M: decoder dispose decoder-stream dispose ;
! Encoding
-M: tuple-class new