steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Joe Groff 2008-06-10 13:01:46 -07:00
parent dc148e89e2 bdf77814e2
commit 4cfe0c6f0a
1307 changed files with 267134 additions and 14109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Factor.app/Contents/Info.plist
View File

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

5
build-support/factor.sh
View File

@ -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
}

2
core/alien/alien-docs.factor
View File

@ -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? }

5
core/alien/c-types/c-types-docs.factor
View File

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

10
core/alien/c-types/c-types.factor
View File

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

30
core/alien/compiler/compiler-tests.factor
View File

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

21
core/alien/compiler/compiler.factor
View File

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

6
core/alien/remote-control/remote-control.factor
View File

@ -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 )

4
core/alien/strings/strings.factor Normal file → Executable file
View File

@ -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

2
core/alien/structs/structs-docs.factor
View File

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

4
core/alien/syntax/syntax.factor
View File

@ -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:

18
core/assocs/assocs-docs.factor
View File

@ -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" } }

32
core/assocs/assocs-tests.factor
View File

@ -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

25
core/assocs/assocs.factor
View File

@ -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 ;

23
core/bootstrap/compiler/compiler.factor
View File

@ -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

19
core/bootstrap/image/image-tests.factor
View File

@ -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

115
core/bootstrap/image/image.factor
View File

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

34
core/bootstrap/primitives.factor
View File

@ -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 <array> builtins set
bootstrapping? on
! Create some empty vocabs where the below primitives and
! classes will go
{
@ -59,6 +63,7 @@ num-types get f <array> builtins set
"arrays"
"bit-arrays"
"byte-arrays"
"byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
@ -124,7 +129,7 @@ num-types get f <array> builtins set
: register-builtin ( class -- )
[ dup lookup-type-number "type" set-word-prop ]
[ dup "type" word-prop builtins get set-nth ]
[ f f builtin-class define-class ]
[ f f f builtin-class define-class ]
tri ;
: define-builtin-slots ( symbol slotspec -- )
@ -157,7 +162,7 @@ num-types get f <array> builtins set
! Catch-all class for providing a default method.
"object" "kernel" create
[ f builtins get [ ] subset union-class define-class ]
[ f f { } intersection-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]
bi
@ -169,7 +174,7 @@ builtins get num-tags get tail define-union-class
! Empty class with no instances
"null" "kernel" create
[ f { } union-class define-class ]
[ f { } f union-class define-class ]
[ [ drop f ] "predicate" set-word-prop ]
bi
@ -452,6 +457,22 @@ tuple
}
} define-tuple-class
"byte-vector" "byte-vectors" create
tuple
{
{
{ "byte-array" "byte-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"curry" "kernel" create
tuple
{
@ -590,7 +611,7 @@ tuple
{ "(exists?)" "io.files.private" }
{ "(directory)" "io.files.private" }
{ "gc" "memory" }
{ "gc-time" "memory" }
{ "gc-stats" "memory" }
{ "save-image" "memory" }
{ "save-image-and-exit" "memory" }
{ "datastack" "kernel" }
@ -685,6 +706,7 @@ tuple
{ "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }
}
dup length [ >r first2 r> make-primitive ] 2each

2
core/bootstrap/stage1.factor
View File

@ -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
[
[

12
core/bootstrap/stage2.factor
View File

@ -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

3
core/bootstrap/syntax.factor
View File

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

7
core/boxes/boxes-docs.factor
View File

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

8
core/boxes/boxes-tests.factor
View File

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

20
core/boxes/boxes.factor
View File

@ -1,24 +1,26 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ;
USING: kernel accessors ;
IN: boxes
TUPLE: box value full? ;
TUPLE: box value occupied ;
: <box> ( -- box ) box new ;
ERROR: box-full box ;
: >box ( value box -- )
dup box-full? [ "Box already has a value" throw ] when
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

3
core/byte-arrays/byte-arrays-docs.factor
View File

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

0
extra/byte-vectors/byte-vectors-docs.factor → core/byte-vectors/byte-vectors-docs.factor
View File

0
extra/byte-vectors/byte-vectors-tests.factor → core/byte-vectors/byte-vectors-tests.factor
View File

19
extra/byte-vectors/byte-vectors.factor → core/byte-vectors/byte-vectors.factor
View File

@ -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) ;
<PRIVATE
: byte-array>vector ( byte-array length -- byte-vector )
@ -43,9 +32,3 @@ M: byte-vector equal?
M: byte-array new-resizable drop <byte-vector> ;
INSTANCE: byte-vector growable
: BV{ \ } [ >byte-vector ] parse-literal ; parsing
M: byte-vector >pprint-sequence ;
M: byte-vector pprint-delims drop \ BV{ \ } ;

0
extra/byte-vectors/summary.txt → core/byte-vectors/summary.txt
View File

0
extra/byte-vectors/tags.txt → core/byte-vectors/tags.txt
View File

55
core/checksums/checksums-docs.factor Normal file
View File

@ -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"

7
core/checksums/checksums-tests.factor Normal file
View File

@ -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

25
core/checksums/checksums.factor Normal file
View File

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

0
core/io/crc32/authors.txt → core/checksums/crc32/authors.txt
View File

11
core/checksums/crc32/crc32-docs.factor Normal file
View File

@ -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"

6
core/checksums/crc32/crc32-tests.factor Normal file
View File

@ -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

26
core/io/crc32/crc32.factor → core/checksums/crc32/crc32.factor
View File

@ -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 ;

0
core/io/crc32/summary.txt → core/checksums/crc32/summary.txt
View File

33
core/classes/algebra/algebra-docs.factor
View File

@ -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 } }

162
core/classes/algebra/algebra-tests.factor
View File

@ -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

213
core/classes/algebra/algebra.factor
View File

@ -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> anonymous-union
TUPLE: anonymous-intersection members ;
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
@ -45,65 +45,91 @@ TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: superclass< ( first second -- ? )
>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 <anonymous-union> ] }
{ [ dup participants ] [ participants <anonymous-intersection> ] }
[ ]
} cond ;
: normalize-complement ( class -- class' )
class>> normalize-class {
{ [ dup anonymous-union? ] [
members>>
[ class-not normalize-class ] map
<anonymous-intersection>
] }
{ [ dup anonymous-intersection? ] [
participants>>
[ class-not normalize-class ] map
<anonymous-union>
] }
} cond ;
: left-anonymous-complement<= ( first second -- ? )
>r normalize-complement r> class<= ;
PREDICATE: nontrivial-anonymous-complement < anonymous-complement
class>> {
[ anonymous-union? ]
[ anonymous-intersection? ]
[ members ]
[ participants ]
} cleave or or or ;
PREDICATE: empty-union < anonymous-union members>> empty? ;
PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
: (class<=) ( first second -- -1/0/1 )
2dup eq? [ 2drop t ] [
[ normalize-class ] bi@ {
{ [ dup empty-intersection? ] [ 2drop t ] }
{ [ over empty-union? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
{ [ over anonymous-union? ] [ left-anonymous-union<= ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ over superclass ] [ superclass<= ] }
[ 2drop f ]
} cond
] if ;
: anonymous-union-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with contains? ;
: anonymous-intersection-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with all? ;
participants>> [ classes-intersect? ] with all? ;
: anonymous-complement-intersect? ( first second -- ? )
class>> class< not ;
: 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> 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 <anonymous-union> ;
: right-union-and ( first second -- class )
members [ class-and ] with map <anonymous-union> ;
: left-anonymous-union-and ( first second -- class )
>r members>> r> [ class-and ] curry map <anonymous-union> ;
: right-anonymous-union-and ( first second -- class )
: anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class )
>r members>> r> suffix <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class )
members>> swap suffix <anonymous-intersection> ;
: anonymous-intersection-and ( first second -- class )
participants>> swap suffix <anonymous-intersection> ;
: (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 <anonymous-intersection> ]
[
[ 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 <anonymous-intersection> ]
} cond
]
} cond ;
: left-anonymous-union-or ( first second -- class )
>r members>> r> suffix <anonymous-union> ;
: right-anonymous-union-or ( first second -- class )
: anonymous-union-or ( first second -- class )
members>> swap suffix <anonymous-union> ;
: ((class-or)) ( first second -- class )
[ normalize-class ] bi@ {
{ [ dup anonymous-union? ] [ anonymous-union-or ] }
{ [ over anonymous-union? ] [ swap anonymous-union-or ] }
[ 2array <anonymous-union> ]
} cond ;
: anonymous-complement-or ( first second -- class )
2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;
: (class-or) ( first second -- class )
{
{ [ 2dup class< ] [ nip ] }
{ [ 2dup swap class< ] [ drop ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }
[ 2array <anonymous-union> ]
{ [ 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> anonymous-complement
[ <anonymous-complement> ]
} cond ;
: class< ( first second -- ? )
{
{ [ 2dup class<= not ] [ 2drop f ] }
{ [ 2dup swap class<= not ] [ 2drop t ] }
[ [ rank-class ] bi@ < ]
} cond ;
: largest-class ( seq -- n elt )
dup [
[ 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> anonymous-complement
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup participants ] [ flatten-intersection-class ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
[ drop ]
} cond ;
@ -212,7 +251,7 @@ C: <anonymous-complement> anonymous-complement
: flatten-builtin-class ( class -- assoc )
flatten-class [
dup tuple class< [ 2drop tuple tuple ] when
dup tuple class<= [ 2drop tuple tuple ] when
] assoc-map ;
: class-types ( class -- seq )

2
core/classes/builtin/builtin.factor
View File

@ -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 ;

12
core/classes/classes-docs.factor
View File

@ -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 ;

41
core/classes/classes-tests.factor
View File

@ -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

50
core/classes/classes.factor
View File

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

28
core/classes/intersection/intersection-docs.factor Normal file
View File

@ -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." } ;

33
core/classes/intersection/intersection.factor Normal file
View File

@ -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 ;

35
core/classes/mixin/mixin.factor
View File

@ -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.

4
core/classes/predicate/predicate.factor
View File

@ -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 ;

2
core/classes/singleton/singleton-docs.factor
View File

@ -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

7
core/classes/singleton/singleton-tests.factor
View File

@ -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

1
core/classes/tuple/tuple-docs.factor
View File

@ -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 }"

65
core/classes/tuple/tuple-tests.factor
View File

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

10
core/classes/tuple/tuple.factor
View File

@ -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 ;

4
core/classes/union/union-docs.factor
View File

@ -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"

10
core/classes/union/union.factor
View File

@ -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 ;

6
core/combinators/combinators-docs.factor
View File

@ -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

8
core/combinators/combinators.factor
View File

@ -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 ;

6
core/command-line/command-line.factor
View File

@ -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* ;

59
core/compiler/compiler.factor
View File

@ -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 ] [

31
core/compiler/constants/constants.factor
View File

@ -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 ;

10
core/compiler/errors/errors-docs.factor
View File

@ -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

8
core/compiler/errors/errors.factor
View File

@ -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 ] [

12
core/compiler/tests/intrinsics.factor
View File

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

14
core/compiler/tests/redefine.factor Normal file
View File

@ -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

44
core/compiler/tests/simple.factor
View File

@ -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 ;

16
core/compiler/tests/stack-trace.factor
View File

@ -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

12
core/compiler/tests/templates.factor
View File

@ -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+ ]

28
core/compiler/units/units.factor
View File

@ -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
<definitions> new-definitions set
<definitions> old-definitions set
[ finish-compilation-unit ]
[ ] cleanup
[
finish-compilation-unit
updated-definitions
notify-definition-observers
] [ ] cleanup
] with-scope ; inline
: compile-call ( quot -- )

23
core/continuations/continuations-docs.factor
View File

@ -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
"<external-resource> ... do stuff ... dispose"
}
"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ;
"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." } ;

8
core/continuations/continuations-tests.factor
View File

@ -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

27
core/continuations/continuations.factor
View File

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

6
core/cpu/architecture/architecture.factor
View File

@ -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

2
core/cpu/ppc/architecture/architecture.factor
View File

@ -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

4
core/cpu/ppc/assembler/assembler.factor
View File

@ -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

4
core/cpu/ppc/bootstrap.factor
View File

@ -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

36
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -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" } }
}
}

21
core/cpu/x86/32/32.factor
View File

@ -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

7
core/cpu/x86/64/64.factor
View File

@ -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

2
core/cpu/x86/allot/allot.factor
View File

@ -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.

34
core/cpu/x86/architecture/architecture.factor
View File

@ -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 )
[

3
core/cpu/x86/assembler/assembler-tests.factor
View File

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

296
core/cpu/x86/assembler/assembler.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator.fixup io.binary kernel
combinators kernel.private math namespaces parser sequences
words system layouts ;
words system layouts math.order accessors ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.
@ -11,11 +11,6 @@ IN: cpu.x86.assembler
! In 64-bit mode, { 1234 } is RIP-relative.
! Beware!
: n, >le % ; inline
: 4, 4 n, ; inline
: 2, 2 n, ; inline
: cell, bootstrap-cell n, ; inline
! Register operands -- eg, ECX
<<
@ -27,7 +22,7 @@ IN: cpu.x86.assembler
: define-registers ( names size -- )
>r dup length r> [ define-register ] curry 2each ;
: REGISTERS:
: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing
>>
@ -45,6 +40,10 @@ REGISTERS: 128
XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
TUPLE: byte value ;
C: <byte> byte
<PRIVATE
#! Extended AMD64 registers (R8-R15) return true.
@ -75,50 +74,38 @@ M: register extended? "register" word-prop 7 > ;
! Addressing modes
TUPLE: indirect base index scale displacement ;
M: indirect extended? indirect-base extended? ;
M: indirect extended? base>> extended? ;
: canonicalize-EBP
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup indirect-base { EBP RBP R13 } memq? [
dup 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 ;
: <indirect> ( base index scale displacement -- indirect )
indirect boa dup canonicalize ;
indirect boa canonicalize ;
: reg-code "register" word-prop 7 bitand ;
: reg-code ( reg -- n ) "register" word-prop 7 bitand ;
: indirect-base* indirect-base EBP or reg-code ;
: indirect-base* ( op -- n ) base>> EBP or reg-code ;
: indirect-index* indirect-index ESP or reg-code ;
: indirect-index* ( op -- n ) index>> ESP or reg-code ;
: indirect-scale* indirect-scale 0 or ;
: indirect-scale* ( op -- n ) scale>> 0 or ;
GENERIC: sib-present? ( op -- ? )
M: indirect sib-present?
dup indirect-base { ESP RSP } memq?
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

6
core/cpu/x86/bootstrap.factor
View File

@ -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
[

22
core/cpu/x86/intrinsics/intrinsics.factor
View File

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

14
core/debugger/debugger-docs.factor
View File

@ -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

77
core/debugger/debugger.factor
View File

@ -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" ;
<PRIVATE
: init-debugger ( -- )

2
core/definitions/definitions-tests.factor
View File

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

31
core/definitions/definitions.factor
View File

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

0
extra/crypto/md5/authors.txt → core/destructors/authors.txt Executable file → Normal file
View File

71
core/destructors/destructors-docs.factor Executable file
View File

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

24
extra/destructors/destructors-tests.factor → core/destructors/destructors-tests.factor
View File

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

56
core/destructors/destructors.factor Executable file
View File

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

0
extra/destructors/summary.txt → core/destructors/summary.txt
View File

40
core/dlists/dlists-docs.factor
View File

@ -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" } }

25
core/dlists/dlists-tests.factor
View File

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

31
core/dlists/dlists.factor
View File

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

13
core/effects/effects-docs.factor
View File

@ -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"

12
core/effects/effects-tests.factor
View File

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

27
core/effects/effects.factor
View File

@ -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 <effect> ;
[ in>> clone ] keep effect-out clone <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
effect-in length cut* ;
in>> length cut* ;
: load-shuffle ( stack shuffle -- )
effect-in [ set ] 2each ;
in>> [ set ] 2each ;
: shuffled-values ( shuffle -- values )
effect-out [ get ] map ;
out>> [ get ] map ;
: shuffle* ( stack shuffle -- newstack )
[ [ load-shuffle ] keep shuffled-values ] with-scope ;

Some files were not shown because too many files have changed in this diff Show More