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-07-07 14:21:51 -07:00
parent a2d49242ba 5ba6a0c56d
commit b82c844cf5
756 changed files with 119366 additions and 6784 deletions
core
alien
arrays
assocs
bit-arrays
bootstrap
byte-vectors
classes
combinators
compiler
continuations
cpu
debugger
dlists
effects
float-arrays
generator
generic
grouping
growable
hashtables
inference
Show More

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

@ -1,6 +1,6 @@
USING: byte-arrays arrays help.syntax help.markup
alien.syntax compiler definitions math libc
debugger parser io io.backend system bit-arrays float-arrays
debugger parser io io.backend system
alien.accessors ;
IN: alien
@ -10,7 +10,7 @@ HELP: alien
HELP: dll
{ $class-description "The class of native library handles. See " { $link "syntax-aliens" } " for syntax and " { $link "dll.private" } " for general information." } ;
HELP: expired? ( c-ptr -- ? )
HELP: expired?
{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } }
{ $description "Tests if the alien is a relic from an earlier session. When an image is loaded, any alien objects which persisted in the image are marked as being expired."
$nl
@ -154,7 +154,11 @@ ARTICLE: "aliens" "Alien addresses"
{ $subsection expired? }
"Anywhere that a " { $link alien } " instance is accepted, the " { $link f } " singleton may be passed in to denote a null pointer."
$nl
"Usually alien objects do not have to created and dereferenced directly; instead declaring C function parameters and return values as having a pointer type such as " { $snippet "void*" } " takes care of the details. See " { $link "c-types-specs" } "." ;
"Usually alien objects do not have to created and dereferenced directly; instead declaring C function parameters and return values as having a pointer type such as " { $snippet "void*" } " takes care of the details."
{ $subsection "syntax-aliens" }
"When higher-level abstractions won't do:"
{ $subsection "reading-writing-memory" }
{ $see-also "c-data" "c-types-specs" } ;
ARTICLE: "reading-writing-memory" "Reading and writing memory directly"
"Numerical values can be read from memory addresses and converted to Factor objects using the various typed memory accessor words:"
@ -293,6 +297,7 @@ $nl
"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
{ $subsection "loading-libs" }
{ $subsection "aliens" }
{ $subsection "alien-invoke" }
{ $subsection "alien-callback" }
{ $subsection "c-data" }

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

@ -1,5 +1,5 @@
IN: alien.tests
USING: alien alien.accessors alien.syntax byte-arrays arrays
USING: accessors alien alien.accessors alien.syntax byte-arrays arrays
kernel kernel.private namespaces tools.test sequences libc math
system prettyprint layouts ;
@ -58,8 +58,6 @@ cell 8 = [
[ "ALIEN: 1234" ] [ 1234 <alien> unparse ] unit-test
[ ] [ 0 B{ 1 2 3 } <displaced-alien> drop ] unit-test
[ ] [ 0 F{ 1 2 3 } <displaced-alien> drop ] unit-test
[ ] [ 0 ?{ t f t } <displaced-alien> drop ] unit-test
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] must-fail
@ -67,6 +65,10 @@ cell 8 = [
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
[ t ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> underlying>> byte-array? ] unit-test
[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test

22
core/alien/alien.factor
View File

@ -1,33 +1,35 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math namespaces sequences system
kernel.private bit-arrays byte-arrays float-arrays arrays ;
USING: accessors assocs kernel math namespaces sequences system
kernel.private byte-arrays arrays ;
IN: alien
! Some predicate classes used by the compiler for optimization
! purposes
PREDICATE: simple-alien < alien
underlying-alien not ;
PREDICATE: simple-alien < alien underlying>> not ;
UNION: simple-c-ptr
simple-alien POSTPONE: f byte-array bit-array float-array ;
UNION: c-ptr
alien POSTPONE: f byte-array bit-array float-array ;
simple-alien POSTPONE: f byte-array ;
DEFER: pinned-c-ptr?
PREDICATE: pinned-alien < alien
underlying-alien pinned-c-ptr? ;
PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
UNION: pinned-c-ptr
pinned-alien POSTPONE: f ;
GENERIC: expired? ( c-ptr -- ? ) flushable
M: alien expired? expired>> ;
M: f expired? drop t ;
: <alien> ( address -- alien )
f <displaced-alien> { simple-c-ptr } declare ; inline
: <bad-alien> ( -- alien )
-1 <alien> t >>expired ; inline
M: alien equal?
over alien? [
2dup [ expired? ] either? [

6
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 destructors ;
debugger destructors ;
HELP: <c-type>
{ $values { "type" hashtable } }
@ -200,7 +200,7 @@ $nl
"Structure and union types are specified by the name of the structure or union." ;
ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
"Instances of the " { $link byte-array } ", " { $link bit-array } " and " { $link float-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
"Instances of the " { $link byte-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
$nl
"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
{ $subsection <c-object> }
@ -253,4 +253,4 @@ $nl
"New C types can be defined:"
{ $subsection "c-structs" }
{ $subsection "c-unions" }
{ $subsection "reading-writing-memory" } ;
{ $see-also "aliens" } ;

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

@ -1,7 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bit-arrays byte-arrays float-arrays arrays
assocs kernel kernel.private libc math
USING: byte-arrays arrays 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
@ -118,12 +117,8 @@ M: c-type stack-size c-type-size ;
GENERIC: byte-length ( seq -- n ) flushable
M: bit-array byte-length length 7 + -3 shift ;
M: byte-array byte-length length ;
M: float-array byte-length length "double" heap-size * ;
: c-getter ( name -- quot )
c-type c-type-getter [
[ "Cannot read struct fields with type" throw ]
@ -242,11 +237,10 @@ M: long-long-type box-return ( type -- )
} 2cleave ;
: expand-constants ( c-type -- c-type' )
#! We use word-def call instead of execute to get around
#! We use def>> call instead of execute to get around
#! staging violations
dup array? [
unclip >r [ dup word? [ word-def call ] when ] map
r> prefix
unclip >r [ dup word? [ def>> call ] when ] map r> prefix
] when ;
: malloc-file-contents ( path -- alien len )

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

@ -4,7 +4,7 @@ USING: arrays generator generator.registers generator.fixup
hashtables kernel math namespaces sequences words
inference.state inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.strings
alien.structs alien.syntax cpu.architecture alien inspector
alien.structs alien.syntax cpu.architecture alien summary
quotations assocs kernel.private threads continuations.private
libc combinators compiler.errors continuations layouts accessors
init sets ;
@ -161,16 +161,8 @@ M: long-long-type flatten-value-type ( type -- )
dup return>> "void" = 0 1 ?
swap produce-values ;
: (param-prep-quot) ( parameters -- )
dup empty? [
drop
] [
unclip c-type c-type-unboxer-quot %
\ >r , (param-prep-quot) \ r> ,
] if ;
: param-prep-quot ( node -- quot )
parameters>> [ <reversed> (param-prep-quot) ] [ ] make ;
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
: unbox-parameters ( offset node -- )
parameters>> [
@ -198,19 +190,11 @@ M: long-long-type flatten-value-type ( type -- )
: box-return* ( node -- )
return>> [ ] [ box-return ] if-void ;
: (return-prep-quot) ( parameters -- )
dup empty? [
drop
] [
unclip c-type c-type-boxer-quot %
\ >r , (return-prep-quot) \ r> ,
] if ;
: callback-prep-quot ( node -- quot )
parameters>> [ <reversed> (return-prep-quot) ] [ ] make ;
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
: return-prep-quot ( node -- quot )
[ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ;
return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
M: alien-invoke-error summary
drop

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

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings parser threads words
kernel.private kernel io.encodings.utf8 ;
USING: accessors alien alien.c-types alien.strings parser
threads words kernel.private kernel io.encodings.utf8 ;
IN: alien.remote-control
: eval-callback ( -- callback )
@ -15,7 +15,7 @@ IN: alien.remote-control
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
dup compiled? [ execute ] [ drop f ] if ; inline
dup compiled>> [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
\ eval-callback ?callback 16 setenv

2
core/alien/strings/strings.factor
View File

@ -100,7 +100,7 @@ M: utf16n <encoder> drop utf16n <encoder> ;
os windows? [ utf16n ] [ utf8 ] if alien>string ;
: dll-path ( dll -- string )
(dll-path) alien>native-string ;
path>> alien>native-string ;
: string>symbol ( str -- alien )
[ os wince? [ utf16n ] [ utf8 ] if string>alien ]

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

@ -7,7 +7,7 @@ kernel words slots assocs namespaces ;
: ($spec-reader-values) ( slot-spec class -- element )
dup ?word-name swap 2array
over slot-spec-name
rot slot-spec-type 2array 2array
rot slot-spec-class 2array 2array
[ { $instance } swap suffix ] assoc-map ;
: $spec-reader-values ( slot-spec class -- )
@ -22,6 +22,9 @@ kernel words slots assocs namespaces ;
" instance." ,
] { } make $description ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;
: $spec-reader ( reader slot-specs class -- )
>r slot-of-reader r>
over [
@ -49,6 +52,9 @@ M: word slot-specs "slots" word-prop ;
" instance." ,
] { } make $description ;
: slot-of-writer ( writer specs -- spec/f )
[ slot-spec-writer eq? ] with find nip ;
: $spec-writer ( writer slot-specs class -- )
>r slot-of-writer r>
over [

28
core/alien/structs/structs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces parser sequences strings words libc slots
USING: accessors arrays generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc slots
slots.deprecated alien.c-types cpu.architecture ;
IN: alien.structs
@ -10,9 +10,9 @@ IN: alien.structs
: struct-offsets ( specs -- size )
0 [
[ slot-spec-type align-offset ] keep
[ class>> align-offset ] keep
[ set-slot-spec-offset ] 2keep
slot-spec-type heap-size +
class>> heap-size +
] reduce ;
: define-struct-slot-word ( spec word quot -- )
@ -23,7 +23,7 @@ IN: alien.structs
[ ]
[ slot-spec-reader ]
[
slot-spec-type
class>>
[ c-getter ] [ c-type c-type-boxer-quot ] bi append
] tri
define-struct-slot-word ;
@ -32,7 +32,7 @@ IN: alien.structs
[ set-writer-props ] keep
[ ]
[ slot-spec-writer ]
[ slot-spec-type c-setter ] tri
[ class>> c-setter ] tri
define-struct-slot-word ;
: define-field ( type spec -- )
@ -77,13 +77,13 @@ M: struct-type stack-size
-rot define-c-type ;
: make-field ( struct-name vocab type field-name -- spec )
[
-rot expand-constants ,
over ,
3dup reader-word ,
writer-word ,
] { } make
first4 0 -rot <slot-spec> ;
<slot-spec>
0 >>offset
swap >>name
swap expand-constants >>class
3dup name>> swap reader-word >>reader
3dup name>> swap writer-word >>writer
2nip ;
: define-struct-early ( name vocab fields -- fields )
-rot [ rot first2 make-field ] 2curry map ;
@ -94,7 +94,7 @@ M: struct-type stack-size
: define-struct ( name vocab fields -- )
pick >r
[ struct-offsets ] keep
[ [ slot-spec-type ] map compute-struct-align ] keep
[ [ class>> ] map compute-struct-align ] keep
[ (define-struct) ] keep
r> [ swap define-field ] curry each ;

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

@ -1,9 +1,10 @@
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays
alien.strings kernel math namespaces parser sequences words
quotations math.parser splitting grouping effects prettyprint
prettyprint.sections prettyprint.backend assocs combinators ;
USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects prettyprint prettyprint.sections prettyprint.backend
assocs combinators lexer strings.parser ;
IN: alien.syntax
<PRIVATE
@ -36,6 +37,8 @@ PRIVATE>
: ALIEN: scan string>number <alien> parsed ; parsing
: BAD-ALIEN <bad-alien> parsed ; parsing
: LIBRARY: scan "c-library" set ; parsing
: FUNCTION:
@ -66,7 +69,7 @@ PRIVATE>
M: alien pprint*
{
{ [ dup expired? ] [ drop "( alien expired )" text ] }
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
} cond ;

4
core/arrays/arrays-tests.factor
View File

@ -1,4 +1,4 @@
USING: arrays kernel sequences sequences.private growable
USING: accessors arrays kernel sequences sequences.private growable
tools.test vectors layouts system math vectors.private ;
IN: arrays.tests
@ -11,7 +11,7 @@ IN: arrays.tests
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test
[ f ] [ { "a" "b" "c" } dup >array eq? ] unit-test
[ t ] [ { "a" "b" "c" } dup { } like eq? ] unit-test
[ t ] [ { "a" "b" "c" } dup dup length array>vector underlying eq? ] unit-test
[ t ] [ { "a" "b" "c" } dup dup length vector boa underlying>> eq? ] unit-test
[ V{ "a" "b" "c" } ] [ { "a" "b" "c" } V{ } like ] unit-test
[ { "a" "b" "c" } ] [ { "a" } { "b" "c" } append ] unit-test
[ { "a" "b" "c" "d" "e" } ]

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

@ -1,7 +1,7 @@
IN: assocs.tests
USING: kernel math namespaces tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
continuations ;
continuations float-arrays ;
[ t ] [ H{ } dup assoc-subset? ] unit-test
[ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test

24
core/assocs/assocs.factor
View File

@ -20,26 +20,25 @@ GENERIC: assoc-clone-like ( assoc exemplar -- newassoc )
GENERIC: >alist ( assoc -- newassoc )
: (assoc-each) ( assoc quot -- seq quot' )
>r >alist r> [ first2 ] prepose ; inline
: assoc-find ( assoc quot -- key value ? )
>r >alist r> [ first2 ] prepose find swap
[ first2 t ] [ drop f f f ] if ; inline
(assoc-each) find swap [ first2 t ] [ drop f f f ] if ; inline
: key? ( key assoc -- ? ) at* nip ; inline
: assoc-each ( assoc quot -- )
[ f ] compose assoc-find 3drop ; inline
: (assoc>map) ( quot accum -- quot' )
[ push ] curry compose ; inline
(assoc-each) each ; inline
: assoc>map ( assoc quot exemplar -- seq )
>r over assoc-size
<vector> [ (assoc>map) assoc-each ] keep
r> like ; inline
>r accumulator >r assoc-each r> r> like ; inline
: assoc-map-as ( assoc quot exemplar -- newassoc )
>r [ 2array ] compose V{ } assoc>map r> assoc-like ; inline
: assoc-map ( assoc quot -- newassoc )
over >r [ 2array ] compose V{ } assoc>map r> assoc-like ;
inline
over assoc-map-as ; inline
: assoc-push-if ( key value quot accum -- )
>r 2keep r> roll
@ -150,6 +149,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ;
: push-at ( value key assoc -- )
[ ?push ] change-at ;
: zip ( keys values -- alist )
2array flip ; inline

67
core/bit-arrays/bit-arrays.factor
View File

@ -1,67 +0,0 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math alien.accessors kernel kernel.private sequences
sequences.private ;
IN: bit-arrays
<PRIVATE
: n>byte -3 shift ; inline
: byte/bit ( n alien -- byte bit )
over n>byte alien-unsigned-1 swap 7 bitand ; inline
: set-bit ( ? byte bit -- byte )
2^ rot [ bitor ] [ bitnot bitand ] if ; inline
: bits>cells 31 + -5 shift ; inline
: (set-bits) ( bit-array n -- )
over length bits>cells -rot [
spin 4 * set-alien-unsigned-4
] 2curry each ; inline
PRIVATE>
M: bit-array length array-capacity ;
M: bit-array nth-unsafe
>r >fixnum r> byte/bit bit? ;
M: bit-array set-nth-unsafe
>r >fixnum r>
[ byte/bit set-bit ] 2keep
swap n>byte set-alien-unsigned-1 ;
: clear-bits ( bit-array -- ) 0 (set-bits) ;
: set-bits ( bit-array -- ) -1 (set-bits) ;
M: bit-array clone (clone) ;
: >bit-array ( seq -- bit-array ) ?{ } clone-like ; inline
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
M: bit-array new-sequence drop <bit-array> ;
M: bit-array equal?
over bit-array? [ sequence= ] [ 2drop f ] if ;
M: bit-array resize
resize-bit-array ;
: integer>bit-array ( int -- bit-array )
[ log2 1+ <bit-array> 0 ] keep
[ dup zero? not ] [
[ -8 shift ] [ 255 bitand ] bi
-roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip
] [ ] while
2drop ;
: bit-array>integer ( bit-array -- int )
dup >r length 7 + n>byte 0 r> [
swap alien-unsigned-1 swap 8 shift bitor
] curry reduce ;
INSTANCE: bit-array sequence

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

@ -1,11 +1,12 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler cpu.architecture vocabs.loader system sequences
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 math.order ;
USING: accessors compiler cpu.architecture vocabs.loader system
sequences 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
math.order ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
@ -14,12 +15,12 @@ IN: bootstrap.compiler
"alien.remote-control" require
] unless
"cpu." cpu word-name append require
"cpu." cpu name>> append require
enable-compiler
: compile-uncompiled ( words -- )
[ compiled? not ] filter compile ;
[ compiled>> not ] filter compile ;
nl
"Compiling..." write flush
@ -40,10 +41,12 @@ nl
wrap probe
underlying
namestack*
} compile-uncompiled
"." write flush
{
bitand bitor bitxor bitnot
} compile-uncompiled

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

@ -1,19 +1,19 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 grouping growable classes classes.builtin classes.tuple
USING: alien 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
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
vocabs.loader source-files definitions debugger
quotations.private sequences.private combinators
io.encodings.binary math.order accessors ;
io.encodings.binary math.order math.private accessors slots.private ;
IN: bootstrap.image
: my-arch ( -- arch )
cpu word-name
dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
cpu name>>
dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
@ -75,7 +75,7 @@ SYMBOL: objects
: data-base 1024 ; inline
: userenv-size 64 ; inline
: userenv-size 70 ; inline
: header-size 10 ; inline
@ -118,6 +118,29 @@ SYMBOL: jit-dispatch
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-tag
SYMBOL: jit-tag-word
SYMBOL: jit-eq?
SYMBOL: jit-eq?-word
SYMBOL: jit-slot
SYMBOL: jit-slot-word
SYMBOL: jit-declare-word
SYMBOL: jit-drop
SYMBOL: jit-drop-word
SYMBOL: jit-dup
SYMBOL: jit-dup-word
SYMBOL: jit->r
SYMBOL: jit->r-word
SYMBOL: jit-r>
SYMBOL: jit-r>-word
SYMBOL: jit-swap
SYMBOL: jit-swap-word
SYMBOL: jit-over
SYMBOL: jit-over-word
SYMBOL: jit-fixnum-fast
SYMBOL: jit-fixnum-fast-word
SYMBOL: jit-fixnum>=
SYMBOL: jit-fixnum>=-word
! Default definition for undefined words
SYMBOL: undefined-quot
@ -140,7 +163,30 @@ SYMBOL: undefined-quot
{ jit-epilog 33 }
{ jit-return 34 }
{ jit-profiling 35 }
{ undefined-quot 37 }
{ jit-tag 36 }
{ jit-tag-word 37 }
{ jit-eq? 38 }
{ jit-eq?-word 39 }
{ jit-slot 40 }
{ jit-slot-word 41 }
{ jit-declare-word 42 }
{ jit-drop 43 }
{ jit-drop-word 44 }
{ jit-dup 45 }
{ jit-dup-word 46 }
{ jit->r 47 }
{ jit->r-word 48 }
{ jit-r> 49 }
{ jit-r>-word 50 }
{ jit-swap 51 }
{ jit-swap-word 52 }
{ jit-over 53 }
{ jit-over-word 54 }
{ jit-fixnum-fast 55 }
{ jit-fixnum-fast-word 56 }
{ jit-fixnum>= 57 }
{ jit-fixnum>=-word 58 }
{ undefined-quot 60 }
} at header-size + ;
: emit ( cell -- ) image get push ;
@ -228,6 +274,12 @@ M: fixnum '
bootstrap-most-positive-fixnum between?
[ tag-fixnum ] [ >bignum ' ] if ;
TUPLE: fake-bignum n ;
C: <fake-bignum> fake-bignum
M: fake-bignum ' n>> tag-fixnum ;
! Floats
M: float '
@ -260,10 +312,10 @@ M: f '
[
{
[ hashcode , ]
[ word-name , ]
[ word-vocabulary , ]
[ word-def , ]
[ word-props , ]
[ name>> , ]
[ vocabulary>> , ]
[ def>> , ]
[ props>> , ]
} cleave
f ,
0 , ! count
@ -277,7 +329,7 @@ M: f '
] keep put-object ;
: word-error ( word msg -- * )
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
[ % dup vocabulary>> % " " % name>> % ] "" make throw ;
: transfer-word ( word -- word )
[ target-word ] keep or ;
@ -294,7 +346,7 @@ M: word ' ;
! Wrappers
M: wrapper '
wrapped ' wrapper type-number object tag-number
wrapped>> ' wrapper type-number object tag-number
[ emit ] emit-object ;
! Strings
@ -334,10 +386,6 @@ M: byte-array '
pad-bytes emit-bytes
] emit-object ;
M: bit-array ' bit-array emit-dummy-array ;
M: float-array ' float-array emit-dummy-array ;
! Tuples
: (emit-tuple) ( tuple -- pointer )
[ tuple>array rest-slice ]
@ -345,7 +393,7 @@ M: float-array ' float-array emit-dummy-array ;
tuple type-number dup [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer )
dup class word-name "tombstone" =
dup class name>> "tombstone" =
[ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
M: tuple ' emit-tuple ;
@ -354,11 +402,11 @@ M: tuple-layout '
[
[
{
[ layout-hashcode , ]
[ layout-class , ]
[ layout-size , ]
[ layout-superclasses , ]
[ layout-echelon , ]
[ hashcode>> , ]
[ class>> , ]
[ size>> , ]
[ superclasses>> , ]
[ echelon>> , ]
} cleave
] { } make [ ' ] map
\ tuple-layout type-number
@ -368,7 +416,7 @@ M: tuple-layout '
M: tombstone '
delegate
"((tombstone))" "((empty))" ? "hashtables.private" lookup
word-def first [ emit-tuple ] cache-object ;
def>> first [ emit-tuple ] cache-object ;
! Arrays
M: array '
@ -379,10 +427,10 @@ M: array '
M: quotation '
[
quotation-array '
array>> '
quotation type-number object tag-number [
emit ! array
f ' emit ! compiled?
f ' emit ! compiled>>
0 emit ! xt
0 emit ! code
] emit-object
@ -412,6 +460,18 @@ M: quotation '
\ if jit-if-word set
\ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
\ tag jit-tag-word set
\ eq? jit-eq?-word set
\ slot jit-slot-word set
\ declare jit-declare-word set
\ drop jit-drop-word set
\ dup jit-dup-word set
\ >r jit->r-word set
\ r> jit-r>-word set
\ swap jit-swap-word set
\ over jit-over-word set
\ fixnum-fast jit-fixnum-fast-word set
\ fixnum>= jit-fixnum>=-word set
[ undefined ] undefined-quot set
{
jit-code-format
@ -428,6 +488,27 @@ M: quotation '
jit-epilog
jit-return
jit-profiling
jit-tag
jit-tag-word
jit-eq?
jit-eq?-word
jit-slot
jit-slot-word
jit-declare-word
jit-drop
jit-drop-word
jit-dup
jit-dup-word
jit->r
jit->r-word
jit-r>
jit-r>-word
jit-swap
jit-swap-word
jit-fixnum-fast
jit-fixnum-fast-word
jit-fixnum>=
jit-fixnum>=-word
undefined-quot
} [ emit-userenv ] each ;

12
core/bootstrap/layouts/layouts.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays
float-arrays quotations assocs layouts classes.tuple.private
hashtables vectors strings sbufs arrays
quotations assocs layouts classes.tuple.private
kernel.private ;
BIN: 111 tag-mask set
8 num-tags set
3 tag-bits set
20 num-types set
18 num-types set
H{
{ fixnum BIN: 000 }
@ -26,14 +26,12 @@ H{
tag-numbers get H{
{ array 8 }
{ wrapper 9 }
{ float-array 10 }
{ byte-array 10 }
{ callstack 11 }
{ string 12 }
{ bit-array 13 }
{ tuple-layout 13 }
{ quotation 14 }
{ dll 15 }
{ alien 16 }
{ word 17 }
{ byte-array 18 }
{ tuple-layout 19 }
} assoc-union type-numbers set

373
core/bootstrap/primitives.factor
View File

@ -1,13 +1,12 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes
classes.builtin classes.tuple classes.tuple.private
hashtables.private io kernel math math.order 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 classes.intersection
compiler.units bootstrap.image.private io.files accessors
combinators ;
slots classes.union classes.intersection classes.predicate
compiler.units bootstrap.image.private io.files accessors combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@ -62,15 +61,14 @@ bootstrapping? on
"alien"
"alien.accessors"
"arrays"
"bit-arrays"
"byte-arrays"
"byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
"classes.predicate"
"compiler.units"
"continuations.private"
"float-arrays"
"generator"
"growable"
"hashtables"
@ -105,24 +103,8 @@ bootstrapping? on
} [ create-vocab drop ] each
! Builtin classes
: lo-tag-eq-quot ( n -- quot )
[ \ tag , , \ eq? , ] [ ] make ;
: hi-tag-eq-quot ( n -- quot )
[
[ dup tag ] % \ hi-tag tag-number , \ eq? ,
[ [ hi-tag ] % , \ eq? , ] [ ] make ,
[ drop f ] ,
\ if ,
] [ ] make ;
: builtin-predicate-quot ( class -- quot )
"type" word-prop
dup tag-mask get <
[ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
: define-builtin-predicate ( class -- )
dup builtin-predicate-quot define-predicate ;
dup class>type [ builtin-instance? ] curry define-predicate ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
@ -133,9 +115,12 @@ bootstrapping? on
[ f f f builtin-class define-class ]
tri ;
: define-builtin-slots ( symbol slotspec -- )
[ drop ] [ 1 simple-slots ] 2bi
[ "slots" set-word-prop ] [ define-slots ] 2bi ;
: prepare-slots ( slots -- slots' )
[ [ dup pair? [ first2 create ] when ] map ] map ;
: define-builtin-slots ( class slots -- )
prepare-slots 1 make-slots
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
: define-builtin ( symbol slotspec -- )
>r [ define-builtin-predicate ] keep
@ -150,10 +135,8 @@ bootstrapping? on
"f" "syntax" lookup register-builtin
"array" "arrays" create register-builtin
"wrapper" "kernel" create register-builtin
"float-array" "float-arrays" create register-builtin
"callstack" "kernel" create register-builtin
"string" "strings" create register-builtin
"bit-array" "bit-arrays" create register-builtin
"quotation" "quotations" create register-builtin
"dll" "alien" create register-builtin
"alien" "alien" create register-builtin
@ -161,6 +144,46 @@ bootstrapping? on
"byte-array" "byte-arrays" create register-builtin
"tuple-layout" "classes.tuple.private" create register-builtin
! For predicate classes
"predicate-instance?" "classes.predicate" create drop
! We need this before defining c-ptr below
"f" "syntax" lookup { } define-builtin
"f" "syntax" create [ not ] "predicate" set-word-prop
"f?" "syntax" vocab-words delete-at
! Some unions
"integer" "math" create
"fixnum" "math" lookup
"bignum" "math" lookup
2array
define-union-class
"rational" "math" create
"integer" "math" lookup
"ratio" "math" lookup
2array
define-union-class
"real" "math" create
"rational" "math" lookup
"float" "math" lookup
2array
define-union-class
"c-ptr" "alien" create [
"alien" "alien" lookup ,
"f" "syntax" lookup ,
"byte-array" "byte-arrays" lookup ,
] { } make define-union-class
! A predicate class used for declarations
"array-capacity" "sequences.private" create
"fixnum" "math" lookup
0 bootstrap-max-array-capacity <fake-bignum> [ between? ] 2curry
define-predicate-class
! Catch-all class for providing a default method.
"object" "kernel" create
[ f f { } intersection-class define-class ]
@ -188,184 +211,63 @@ bi
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
"ratio" "math" create {
{
{ "integer" "math" }
"numerator"
{ "numerator" "math" }
f
}
{
{ "integer" "math" }
"denominator"
{ "denominator" "math" }
f
}
{ "numerator" { "integer" "math" } read-only }
{ "denominator" { "integer" "math" } read-only }
} define-builtin
"float" "math" create { } define-builtin
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
"complex" "math" create {
{
{ "real" "math" }
"real-part"
{ "real-part" "math" }
f
}
{
{ "real" "math" }
"imaginary-part"
{ "imaginary-part" "math" }
f
}
{ "real" { "real" "math" } read-only }
{ "imaginary" { "real" "math" } read-only }
} define-builtin
"f" "syntax" lookup { } define-builtin
"array" "arrays" create { } define-builtin
"wrapper" "kernel" create {
{
{ "object" "kernel" }
"wrapped"
{ "wrapped" "kernel" }
f
}
{ "wrapped" read-only }
} define-builtin
"string" "strings" create {
{
{ "array-capacity" "sequences.private" }
"length"
{ "length" "sequences" }
f
} {
{ "object" "kernel" }
"aux"
{ "string-aux" "strings.private" }
{ "set-string-aux" "strings.private" }
}
{ "length" { "array-capacity" "sequences.private" } read-only }
"aux"
} define-builtin
"quotation" "quotations" create {
{
{ "object" "kernel" }
"array"
{ "quotation-array" "quotations.private" }
f
}
{
{ "object" "kernel" }
"compiled?"
{ "quotation-compiled?" "quotations" }
f
}
{ "array" { "array" "arrays" } read-only }
{ "compiled" read-only }
} define-builtin
"dll" "alien" create {
{
{ "byte-array" "byte-arrays" }
"path"
{ "(dll-path)" "alien" }
f
}
}
define-builtin
{ "path" { "byte-array" "byte-arrays" } read-only }
} define-builtin
"alien" "alien" create {
{
{ "c-ptr" "alien" }
"alien"
{ "underlying-alien" "alien" }
f
} {
{ "object" "kernel" }
"expired?"
{ "expired?" "alien" }
f
}
}
define-builtin
{ "underlying" { "c-ptr" "alien" } read-only }
"expired"
} define-builtin
"word" "words" create {
f
{
{ "object" "kernel" }
"name"
{ "word-name" "words" }
{ "set-word-name" "words" }
}
{
{ "object" "kernel" }
"vocabulary"
{ "word-vocabulary" "words" }
{ "set-word-vocabulary" "words" }
}
{
{ "quotation" "quotations" }
"def"
{ "word-def" "words" }
{ "set-word-def" "words.private" }
}
{
{ "object" "kernel" }
"props"
{ "word-props" "words" }
{ "set-word-props" "words" }
}
{
{ "object" "kernel" }
"compiled?"
{ "compiled?" "words" }
f
}
{
{ "fixnum" "math" }
"counter"
{ "profile-counter" "tools.profiler.private" }
{ "set-profile-counter" "tools.profiler.private" }
}
{ "hashcode" { "fixnum" "math" } }
"name"
"vocabulary"
{ "def" { "quotation" "quotations" } initial: [ ] }
"props"
{ "compiled" read-only }
{ "counter" { "fixnum" "math" } }
} define-builtin
"byte-array" "byte-arrays" create { } define-builtin
"bit-array" "bit-arrays" create { } define-builtin
"float-array" "float-arrays" create { } define-builtin
"callstack" "kernel" create { } define-builtin
"tuple-layout" "classes.tuple.private" create {
{
{ "fixnum" "math" }
"hashcode"
{ "layout-hashcode" "classes.tuple.private" }
f
}
{
{ "word" "words" }
"class"
{ "layout-class" "classes.tuple.private" }
f
}
{
{ "fixnum" "math" }
"size"
{ "layout-size" "classes.tuple.private" }
f
}
{
{ "array" "arrays" }
"superclasses"
{ "layout-superclasses" "classes.tuple.private" }
f
}
{
{ "fixnum" "math" }
"echelon"
{ "layout-echelon" "classes.tuple.private" }
f
}
{ "hashcode" { "fixnum" "math" } read-only }
{ "class" { "word" "words" } initial: t read-only }
{ "size" { "fixnum" "math" } read-only }
{ "superclasses" { "array" "arrays" } initial: { } read-only }
{ "echelon" { "fixnum" "math" } read-only }
} define-builtin
"tuple" "kernel" create {
@ -373,24 +275,14 @@ define-builtin
[ { "delegate" } "slot-names" set-word-prop ]
[ define-tuple-layout ]
[
{
{
{ "object" "kernel" }
"delegate"
{ "delegate" "kernel" }
{ "set-delegate" "kernel" }
}
}
{ "delegate" }
[ drop ] [ generate-tuple-slots ] 2bi
[ "slots" set-word-prop ]
[ define-slots ]
[ define-accessors ]
2bi
]
} cleave
"f" "syntax" create [ not ] "predicate" set-word-prop
"f?" "syntax" vocab-words delete-at
! Create special tombstone values
"tombstone" "hashtables.private" create
tuple
@ -405,90 +297,12 @@ tuple
2array >tuple 1quotation define-inline
! Some tuple classes
"hashtable" "hashtables" create
tuple
{
{
{ "array-capacity" "sequences.private" }
"count"
{ "hash-count" "hashtables.private" }
{ "set-hash-count" "hashtables.private" }
} {
{ "array-capacity" "sequences.private" }
"deleted"
{ "hash-deleted" "hashtables.private" }
{ "set-hash-deleted" "hashtables.private" }
} {
{ "array" "arrays" }
"array"
{ "hash-array" "hashtables.private" }
{ "set-hash-array" "hashtables.private" }
}
} define-tuple-class
"sbuf" "sbufs" create
tuple
{
{
{ "string" "strings" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"length"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"vector" "vectors" create
tuple
{
{
{ "array" "arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} 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
{
{
{ "object" "kernel" }
"obj"
{ "curry-obj" "kernel" }
f
} {
{ "object" "kernel" }
"quot"
{ "curry-quot" "kernel" }
f
}
} define-tuple-class
{ "obj" read-only }
{ "quot" read-only }
} prepare-slots define-tuple-class
"curry" "kernel" lookup
[ f "inline" set-word-prop ]
@ -499,18 +313,9 @@ tuple
"compose" "kernel" create
tuple
{
{
{ "object" "kernel" }
"first"
{ "compose-first" "kernel" }
f
} {
{ "object" "kernel" }
"second"
{ "compose-second" "kernel" }
f
}
} define-tuple-class
{ "first" read-only }
{ "second" read-only }
} prepare-slots define-tuple-class
"compose" "kernel" lookup
[ f "inline" set-word-prop ]
@ -634,7 +439,6 @@ tuple
{ "dlsym" "alien" }
{ "dlclose" "alien" }
{ "<byte-array>" "byte-arrays" }
{ "<bit-array>" "bit-arrays" }
{ "<displaced-alien>" "alien" }
{ "alien-signed-cell" "alien.accessors" }
{ "set-alien-signed-cell" "alien.accessors" }
@ -693,7 +497,6 @@ tuple
{ "profiling" "tools.profiler.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" }
{ "<tuple-boa>" "classes.tuple.private" }
{ "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" }
@ -705,8 +508,6 @@ tuple
{ "unset-os-env" "system" }
{ "(set-os-envs)" "system.private" }
{ "resize-byte-array" "byte-arrays" }
{ "resize-bit-array" "bit-arrays" }
{ "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" }
{ "unimplemented" "kernel.private" }
{ "gc-reset" "memory" }

6
core/bootstrap/stage2.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init command-line namespaces words debugger io
USING: accessors init command-line namespaces words debugger io
kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
@ -28,7 +28,7 @@ SYMBOL: bootstrap-time
[ "bootstrap." prepend require ] each ;
: count-words ( pred -- )
all-words swap filter length number>string write ;
all-words swap count number>string write ;
: print-report ( time -- )
1000 /i
@ -36,7 +36,7 @@ SYMBOL: bootstrap-time
"Bootstrap completed in " write number>string write
" minutes and " write number>string write " seconds." print
[ compiled? ] count-words " compiled words" print
[ compiled>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print

5
core/bootstrap/syntax.factor
View File

@ -14,7 +14,6 @@ IN: bootstrap.syntax
":"
";"
"<PRIVATE"
"?{"
"BIN:"
"B{"
"BV{"
@ -22,7 +21,6 @@ IN: bootstrap.syntax
"CHAR:"
"DEFER:"
"ERROR:"
"F{"
"FORGET:"
"GENERIC#"
"GENERIC:"
@ -45,6 +43,7 @@ IN: bootstrap.syntax
"SINGLETON:"
"SYMBOL:"
"TUPLE:"
"SLOT:"
"T{"
"UNION:"
"INTERSECTION:"
@ -68,6 +67,8 @@ IN: bootstrap.syntax
"<<"
">>"
"call-next-method"
"initial:"
"read-only"
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol

5
core/byte-vectors/byte-vectors-docs.factor
View File

@ -30,11 +30,6 @@ HELP: >byte-vector
{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than integers." } ;
HELP: byte-array>vector
{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }
{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }
{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;
HELP: BV{
{ $syntax "BV{ elements... }" }
{ $values { "elements" "a list of bytes" } }

15
core/byte-vectors/byte-vectors.factor
View File

@ -4,15 +4,12 @@ USING: arrays kernel kernel.private math sequences
sequences.private growable byte-arrays ;
IN: byte-vectors
<PRIVATE
: byte-array>vector ( byte-array length -- byte-vector )
byte-vector boa ; inline
PRIVATE>
TUPLE: byte-vector
{ underlying byte-array }
{ length array-capacity } ;
: <byte-vector> ( n -- byte-vector )
<byte-array> 0 byte-array>vector ; inline
<byte-array> 0 byte-vector boa ; inline
: >byte-vector ( seq -- byte-vector )
T{ byte-vector f B{ } 0 } clone-like ;
@ -20,11 +17,11 @@ PRIVATE>
M: byte-vector like
drop dup byte-vector? [
dup byte-array?
[ dup length byte-array>vector ] [ >byte-vector ] if
[ dup length byte-vector boa ] [ >byte-vector ] if
] unless ;
M: byte-vector new-sequence
drop [ <byte-array> ] keep >fixnum byte-array>vector ;
drop [ <byte-array> ] [ >fixnum ] bi byte-vector boa ;
M: byte-vector equal?
over byte-vector? [ sequence= ] [ 2drop f ] if ;

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

@ -3,7 +3,8 @@ 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 math.order ;
random inference effects kernel.private sbufs math.order
classes.tuple ;
IN: classes.algebra.tests
\ class< must-infer
@ -204,7 +205,7 @@ UNION: z1 b1 c1 ;
10 [
[ ] [
20 [ drop random-op ] map >quotation
20 [ random-op ] [ ] replicate-as
[ infer effect-in [ random-class ] times ] keep
call
drop
@ -238,8 +239,8 @@ UNION: z1 b1 c1 ;
20 [
[ t ] [
20 [ drop random-boolean-op ] [ ] map-as dup .
[ infer effect-in [ drop random-boolean ] map dup . ] keep
20 [ random-boolean-op ] [ ] replicate-as dup .
[ infer effect-in [ random-boolean ] replicate dup . ] keep
[ >r [ ] each r> call ] 2keep
@ -287,6 +288,8 @@ INTERSECTION: generic-class generic class ;
generic-class flatten-class
] unit-test
[ \ + flatten-class ] must-fail
INTERSECTION: empty-intersection ;
[ t ] [ object empty-intersection class<= ] unit-test

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

@ -1,10 +1,22 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! 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.order ;
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
kernel.private sets math.order ;
IN: classes.algebra
TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
@ -18,10 +30,19 @@ DEFER: (class-not)
: class-not ( class -- complement )
class-not-cache get [ (class-not) ] cache ;
DEFER: (classes-intersect?) ( first second -- ? )
GENERIC: (classes-intersect?) ( first second -- ? )
: normalize-class ( class -- class' )
{
{ [ dup members ] [ members <anonymous-union> ] }
{ [ dup participants ] [ participants <anonymous-intersection> ] }
[ ]
} cond ;
: classes-intersect? ( first second -- ? )
classes-intersect-cache get [ (classes-intersect?) ] 2cache ;
classes-intersect-cache get [
normalize-class (classes-intersect?)
] 2cache ;
DEFER: (class-and)
@ -33,18 +54,6 @@ DEFER: (class-or)
: class-or ( first second -- class )
class-or-cache get [ (class-or) ] 2cache ;
TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
TUPLE: anonymous-complement class ;
C: <anonymous-complement> anonymous-complement
: superclass<= ( first second -- ? )
>r superclass r> class<= ;
@ -63,13 +72,6 @@ C: <anonymous-complement> anonymous-complement
: anonymous-complement<= ( first second -- ? )
[ class>> ] bi@ swap class<= ;
: normalize-class ( class -- class' )
{
{ [ dup members ] [ members <anonymous-union> ] }
{ [ dup participants ] [ participants <anonymous-intersection> ] }
[ ]
} cond ;
: normalize-complement ( class -- class' )
class>> normalize-class {
{ [ dup anonymous-union? ] [
@ -116,40 +118,15 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
} cond
] if ;
: anonymous-union-intersect? ( first second -- ? )
M: anonymous-union (classes-intersect?)
members>> [ classes-intersect? ] with contains? ;
: anonymous-intersection-intersect? ( first second -- ? )
M: anonymous-intersection (classes-intersect?)
participants>> [ classes-intersect? ] with all? ;
: anonymous-complement-intersect? ( first second -- ? )
M: anonymous-complement (classes-intersect?)
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 ] }
[ swap classes-intersect? ]
} cond ;
: builtin-class-intersect? ( first second -- ? )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
[ swap classes-intersect? ]
} 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? ] }
} cond ;
: anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ;
@ -214,7 +191,7 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
[ "Topological sort failed" throw ] unless* ;
: sort-classes ( seq -- newseq )
[ [ word-name ] compare ] sort >vector
[ [ name>> ] compare ] sort >vector
[ dup empty? not ]
[ dup largest-class >r over delete-nth r> ]
[ ] unfold nip ;
@ -225,26 +202,10 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
tuck [ class<= ] with all? [ peek ] [ drop f ] if
] if ;
DEFER: (flatten-class)
DEFER: flatten-builtin-class
GENERIC: (flatten-class) ( 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 -- )
{
{ [ 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 ;
M: anonymous-union (flatten-class)
members>> [ (flatten-class) ] each ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
@ -258,8 +219,11 @@ DEFER: flatten-builtin-class
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
: class-tags ( class -- tag/f )
: class-tags ( class -- seq )
class-types [
dup num-tags get >=
[ drop \ hi-tag tag-number ] when
] map prune ;
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;

10
core/classes/builtin/builtin-tests.factor Normal file
View File

@ -0,0 +1,10 @@
IN: classes.builtin.tests
USING: tools.test words sequences kernel memory accessors ;
[ f ] [
[ word? ] instances
[
[ name>> "f?" = ]
[ vocabulary>> "syntax" = ] bi and
] contains?
] unit-test

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

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes words kernel kernel.private namespaces
sequences ;
USING: accessors classes classes.algebra words kernel
kernel.private namespaces sequences math math.private
combinators assocs ;
IN: classes.builtin
SYMBOL: builtins
@ -11,6 +12,8 @@ PREDICATE: builtin-class < class
: type>class ( n -- class ) builtins get-global nth ;
: class>type ( class -- n ) "type" word-prop ; foldable
: bootstrap-type>class ( n -- class ) builtins get nth ;
M: hi-tag class hi-tag type>class ;
@ -18,3 +21,34 @@ M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;
M: builtin-class rank-class drop 0 ;
: builtin-instance? ( object n -- ? )
#! 7 == tag-mask get
#! 3 == hi-tag tag-number
dup 7 fixnum<= [ swap tag eq? ] [
swap dup tag 3 eq?
[ hi-tag eq? ] [ 2drop f ] if
] if ; inline
M: builtin-class instance?
class>type builtin-instance? ;
M: builtin-class (flatten-class) dup set ;
M: builtin-class (classes-intersect?)
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
[ swap classes-intersect? ]
} cond ;
M: anonymous-intersection (flatten-class)
participants>> [ flatten-builtin-class ] map
dup empty? [
drop builtins get sift [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;
M: anonymous-complement (flatten-class)
drop builtins get sift [ (flatten-class) ] each ;

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

@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math
namespaces sequences words arrays layouts effects math
layouts classes.private classes.union classes.mixin
classes.predicate quotations ;
IN: classes
@ -32,6 +32,8 @@ $nl
{ $subsection class }
"Testing if an object is an instance of a class:"
{ $subsection instance? }
"Class predicates can be used to test instances directly:"
{ $subsection "class-predicates" }
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
{ $subsection object }
{ $subsection null }
@ -63,10 +65,6 @@ HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: update-map
{ $var-description "Assoc 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." } ;

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

@ -6,154 +6,6 @@ classes.algebra vectors definitions source-files
compiler.units kernel.private sorting vocabs ;
IN: classes.tests
! DEFER: bah
! FORGET: bah
UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
! Test redefinition of classes
UNION: union-1 fixnum float ;
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
[ "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
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
[ "union-1" ] [ 8 generic-update-test ] unit-test
[ -7 generic-update-test ] must-fail
! Test mixins
MIXIN: sequence-mixin
INSTANCE: array sequence-mixin
INSTANCE: vector sequence-mixin
INSTANCE: slice sequence-mixin
MIXIN: assoc-mixin
INSTANCE: hashtable assoc-mixin
GENERIC: collection-size ( x -- y )
M: sequence-mixin collection-size length ;
M: assoc-mixin collection-size assoc-size ;
[ 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
[ t ] [ H{ { 1 2 } { 2 3 } } assoc-mixin? ] unit-test
[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test
! Test mixing in of new classes after the fact
DEFER: mx1
FORGET: mx1
MIXIN: mx1
INSTANCE: integer mx1
[ 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
[ \ mx1 forget ] with-compilation-unit
! Empty unions were causing problems
GENERIC: empty-union-test ( obj -- obj )
UNION: empty-union-1 ;
M: empty-union-1 empty-union-test ;
UNION: empty-union-2 ;
M: empty-union-2 empty-union-test ;
! Redefining a class didn't update containing unions
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
[ ] [ "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
USE: io.streams.string
2 [
[ "mixin-forget-test" forget-source ] with-compilation-unit
[ ] [
{
"USING: sequences ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } ] [ { } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
[ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
[ ] [
{
"USING: hashtables ;"
"IN: classes.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } "mixin-forget-test-g" "classes.tests" lookup execute ] must-fail
[ H{ } ] [ H{ } "mixin-forget-test-g" "classes.tests" lookup execute ] unit-test
] times
! Method flattening interfered with mixin update
MIXIN: flat-mx-1
TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1
TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1
TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1
TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1
MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
! Test generic see and parsing
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test
[ t ] [ 3 object instance? ] unit-test
[ t ] [ 3 fixnum instance? ] unit-test
[ f ] [ 3 float instance? ] unit-test

53
core/classes/classes.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions assocs kernel kernel.private
USING: accessors arrays definitions assocs kernel kernel.private
slots.private namespaces sequences strings words vectors math
quotations combinators sorting effects graphs vocabs sets ;
IN: classes
@ -32,13 +32,10 @@ SYMBOL: implementors-map
PREDICATE: class < word
"class" word-prop ;
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) implementors-map get keys ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
[ name>> "?" append ] [ vocabulary>> ] bi create ;
PREDICATE: predicate < word "predicating" word-prop >boolean ;
@ -65,6 +62,16 @@ GENERIC: rank-class ( class -- n )
GENERIC: reset-class ( class -- )
M: class reset-class
{
"class"
"metaclass"
"superclass"
"members"
"participants"
"predicate"
} reset-props ;
M: word reset-class drop ;
GENERIC: implementors ( class/classes -- seq )
@ -78,8 +85,9 @@ GENERIC: implementors ( class/classes -- seq )
tri
] { } make ;
: class-usages ( class -- seq )
[ update-map get at ] closure keys ;
: class-usage ( class -- seq ) update-map get at ;
: class-usages ( class -- seq ) [ class-usage ] closure keys ;
<PRIVATE
@ -114,8 +122,8 @@ M: sequence implementors [ implementors ] gather ;
dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
dup reset-class
dup deferred? [ dup define-symbol ] when
dup word-props
r> assoc-union over set-word-props
dup props>>
r> assoc-union >>props
dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
@ -154,21 +162,24 @@ GENERIC: update-methods ( class seq -- )
: forget-methods ( class -- )
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
GENERIC: class-forgotten ( use class -- )
: forget-class ( class -- )
class-usages [
{
[ forget-predicate ]
[ forget-methods ]
[ implementors-map- ]
[ update-map- ]
[ reset-class ]
} cleave
] each ;
{
[ dup class-usage keys [ class-forgotten ] with each ]
[ forget-predicate ]
[ forget-methods ]
[ implementors-map- ]
[ update-map- ]
[ reset-class ]
} cleave ;
M: class class-forgotten
nip forget-class ;
M: class forget* ( class -- )
[ forget-class ] [ call-next-method ] bi ;
[ call-next-method ] [ forget-class ] bi ;
GENERIC: class ( object -- class )
: instance? ( obj class -- ? )
"predicate" word-prop call ;
GENERIC: instance? ( object class -- ? )

11
core/classes/intersection/intersection.factor
View File

@ -1,7 +1,7 @@
! 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 ;
classes.algebra classes.builtin namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class
@ -27,7 +27,10 @@ M: intersection-class update-class define-intersection-predicate ;
[ drop update-classes ]
2bi ;
M: intersection-class reset-class
{ "class" "metaclass" "participants" } reset-props ;
M: intersection-class rank-class drop 2 ;
M: intersection-class instance?
"participants" word-prop [ instance? ] with all? ;
M: intersection-class (flatten-class)
participants <anonymous-intersection> (flatten-class) ;

107
core/classes/mixin/mixin-tests.factor Normal file
View File

@ -0,0 +1,107 @@
USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
compiler.units kernel.private sorting vocabs ;
IN: classes.mixin.tests
! Test mixins
MIXIN: sequence-mixin
INSTANCE: array sequence-mixin
INSTANCE: vector sequence-mixin
INSTANCE: slice sequence-mixin
MIXIN: assoc-mixin
INSTANCE: hashtable assoc-mixin
GENERIC: collection-size ( x -- y )
M: sequence-mixin collection-size length ;
M: assoc-mixin collection-size assoc-size ;
[ 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
[ t ] [ H{ { 1 2 } { 2 3 } } assoc-mixin? ] unit-test
[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test
! Test mixing in of new classes after the fact
DEFER: mx1
FORGET: mx1
MIXIN: mx1
INSTANCE: integer mx1
[ t ] [ integer mx1 class<= ] unit-test
[ t ] [ mx1 integer class<= ] unit-test
[ t ] [ mx1 number class<= ] unit-test
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval
[ t ] [ array mx1 class<= ] unit-test
[ f ] [ mx1 number class<= ] unit-test
[ \ mx1 forget ] with-compilation-unit
USE: io.streams.string
2 [
[ "mixin-forget-test" forget-source ] with-compilation-unit
[ ] [
{
"USING: sequences ;"
"IN: classes.mixin.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: sequence mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } ] [ { } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] unit-test
[ H{ } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] must-fail
[ ] [
{
"USING: hashtables ;"
"IN: classes.mixin.tests"
"MIXIN: mixin-forget-test"
"INSTANCE: hashtable mixin-forget-test"
"GENERIC: mixin-forget-test-g ( x -- y )"
"M: mixin-forget-test mixin-forget-test-g ;"
} "\n" join <string-reader> "mixin-forget-test"
parse-stream drop
] unit-test
[ { } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] must-fail
[ H{ } ] [ H{ } "mixin-forget-test-g" "classes.mixin.tests" lookup execute ] unit-test
] times
! Method flattening interfered with mixin update
MIXIN: flat-mx-1
TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1
TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1
TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1
TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1
MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
! Too eager with reset-class
[ ] [ "IN: classes.mixin.tests MIXIN: blah SINGLETON: boo INSTANCE: boo blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test
[ ] [ "IN: classes.mixin.tests MIXIN: blah" <string-reader> "mixin-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.mixin.tests" lookup mixin-class? ] unit-test

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

@ -7,7 +7,7 @@ IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class
{ "class" "metaclass" "members" "mixin" } reset-props ;
[ call-next-method ] [ { "mixin" } reset-props ] bi ;
M: mixin-class rank-class drop 3 ;
@ -65,6 +65,8 @@ TUPLE: check-mixin-class mixin ;
update-classes
] [ 2drop ] if-mixin-member? ;
M: mixin-class class-forgotten remove-mixin-instance ;
! Definition protocol implementation ensures that removing an
! INSTANCE: declaration from a source file updates the mixin.
TUPLE: mixin-instance loc class mixin ;
@ -81,8 +83,9 @@ M: mixin-instance hashcode*
[ class>> ] [ mixin>> ] bi 2array hashcode* ;
: <mixin-instance> ( class mixin -- definition )
{ set-mixin-instance-class set-mixin-instance-mixin }
mixin-instance construct ;
mixin-instance new
swap >>mixin
swap >>class ;
M: mixin-instance where mixin-instance-loc ;

15
core/classes/parser/parser.factor Normal file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser words kernel classes compiler.units lexer ;
IN: classes.parser
: save-class-location ( class -- )
location remember-class ;
: create-class-in ( word -- word )
current-vocab create
dup save-class-location
dup predicate-word dup set-word save-location ;
: CREATE-CLASS ( -- word )
scan create-class-in ;

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

@ -1,11 +1,27 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel namespaces words ;
USING: classes classes.algebra kernel namespaces words sequences
quotations arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
DEFER: predicate-instance? ( object class -- ? )
: update-predicate-instance ( -- )
\ predicate-instance? bootstrap-word
classes [ predicate-class? ] filter [
[ literalize ]
[
[ superclass 1array [ declare ] curry ]
[ "predicate-definition" word-prop ]
bi compose
]
bi
] { } map>assoc [ case ] curry
define ;
: predicate-quot ( class -- quot )
[
\ dup ,
@ -21,14 +37,23 @@ PREDICATE: predicate-class < class
[ dup predicate-quot define-predicate ]
[ update-classes ]
bi
] 3tri ;
]
3tri
update-predicate-instance ;
M: predicate-class reset-class
{
"class"
"metaclass"
"predicate-definition"
"superclass"
} reset-props ;
[ call-next-method ]
[ { "predicate-definition" } reset-props ]
bi ;
M: predicate-class rank-class drop 1 ;
M: predicate-class instance?
2dup superclass instance?
[ predicate-instance? ] [ 2drop f ] if ;
M: predicate-class (flatten-class)
superclass (flatten-class) ;
M: predicate-class (classes-intersect?)
superclass classes-intersect? ;

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

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.predicate kernel sequences words ;
USING: classes classes.predicate kernel sequences words ;
IN: classes.singleton
PREDICATE: singleton-class < predicate-class
@ -9,3 +9,5 @@ PREDICATE: singleton-class < predicate-class
: define-singleton-class ( word -- )
\ word over [ eq? ] curry define-predicate-class ;
M: singleton-class instance? eq? ;

14
core/classes/tuple/parser/parser-docs.factor Normal file
View File

@ -0,0 +1,14 @@
IN: classes.tuple.parser
USING: strings help.markup help.syntax ;
HELP: invalid-slot-name
{ $values { "name" string } }
{ $description "Throws an " { $link invalid-slot-name } " error." }
{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
{ $code
"TUPLE: my-mistaken-tuple slot-a slot-b"
""
": some-word ( a b c -- ) ... ;"
}
} ;

67
core/classes/tuple/parser/parser-tests.factor Normal file
View File

@ -0,0 +1,67 @@
IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
sequences math kernel slots tools.test parser compiler.units ;
TUPLE: test-1 ;
[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test
TUPLE: test-2 < test-1 ;
[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test
[ test-1 ] [ test-2 superclass ] unit-test
TUPLE: test-3 a ;
[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test
[ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test
TUPLE: test-4 < test-3 b ;
[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test
TUPLE: test-5 { a integer } ;
[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test
TUPLE: test-6 < test-5 { b integer } ;
[ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test
[ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test
TUPLE: test-7 { b integer initial: 3 } ;
[ 3 ] [ "b" test-7 "slots" word-prop slot-named initial>> ] unit-test
TUPLE: test-8 { b integer read-only } ;
[ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test
[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
[ error>> invalid-slot-name? ]
must-fail-with
[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ]
[ error>> invalid-slot-name? ]
must-fail-with
[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ]
[ error>> unexpected-eof? ]
must-fail-with
[ "IN: classes.tuple.parser.tests USE: generic.standard TUPLE: foo { slot no-method } ;" eval ]
[ error>> no-initial-value? ]
must-fail-with
[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
[ error>> bad-initial-value? ]
must-fail-with
[ ] [
[
{ test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 }
[ dup class? [ forget-class ] [ drop ] if ] each
] with-compilation-unit
] unit-test

55
core/classes/tuple/parser/parser.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sets namespaces sequences summary parser
lexer combinators words classes.parser classes.tuple arrays ;
IN: classes.tuple.parser
: shadowed-slots ( superclass slots -- shadowed )
[ all-slots [ name>> ] map ]
[ [ dup array? [ first ] when ] map ]
bi* intersect ;
: check-slot-shadowing ( class superclass slots -- )
shadowed-slots [
[
"Definition of slot ``" %
%
"'' in class ``" %
name>> %
"'' shadows a superclass slot" %
] "" make note.
] with each ;
ERROR: invalid-slot-name name ;
M: invalid-slot-name summary
drop
"Invalid slot name" ;
: parse-long-slot-name ( -- )
[ scan , \ } parse-until % ] { } make ;
: parse-slot-name ( string/f -- ? )
#! This isn't meant to enforce any kind of policy, just
#! to check for mistakes of this form:
#!
#! TUPLE: blahblah foo bing
#!
#! : ...
{
{ [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] }
{ [ dup ";" = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond ;
: parse-tuple-slots ( -- )
scan parse-slot-name [ parse-tuple-slots ] when ;
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
scan {
{ ";" [ tuple f ] }
{ "<" [ scan-word [ parse-tuple-slots ] { } make ] }
[ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
} case 3dup check-slot-shadowing ;

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

@ -1,8 +1,40 @@
USING: generic help.markup help.syntax kernel
classes.tuple.private classes slots quotations words arrays
generic.standard sequences definitions compiler.units ;
generic.standard sequences definitions compiler.units
growable vectors sbufs assocs math ;
IN: classes.tuple
ARTICLE: "slot-read-only-declaration" "Read-only slots"
"By default, all slots are writable. If a slot is explicitly declared " { $link read-only } ", then no writer method is generated for the slot, and the only way to set it to a value other than its initial value is to construct an instance of the tuple with " { $link boa } ", passing the initial value for the read-only slot on the stack; the common idiom of calling " { $link new } " and then immediately filling in slot values with setter words will not work with read-only slots." ;
ARTICLE: "slot-class-declaration" "Slot class declarations"
"Class declaration is optional, and the default value is " { $link object } ", the class of all objects. If a more specific class is declared, then the object system maintains an invariant that the value of the slot must always be an instance of the class, even during construction. This invariant is enforced at a number of locations:"
{ $list
{ "Writer words (" { $link "accessors" } ") throw an error if the new value does not satisfy the class predicate." }
{ "The " { $link new } " word fills in slots with their initial values; the (per-class) initial values are required to satisfy the class predicate." }
{ "The " { $link boa } " word ensures that the values on the stack satisfy the class predicate." }
{ { $link "mirrors" } " ensure that the value passed to " { $link set-at } " satisfies the class predicate." }
{ "The " { $link slots>tuple } " and " { $link >tuple } " words ensure that the values in the sequence satisfy the correct class predicates." }
{ { $link "tuple-redefinition" } " fills in new slots with initial values and ensures that changes to existing declarations result in incompatible values being replaced with the initial value of their respective slots." }
}
{ $subsection "slot-class-coercion" } ;
ARTICLE: "slot-class-coercion" "Coercive slot declarations"
"If the class of a slot is declared to be one of " { $link fixnum } " or " { $link float } ", then rather than testing values with the class predicate, writer words coerce values to the relevant type with " { $link >fixnum } " or " { $link >float } ". This may still result in error, but permits a wider range of values than a class predicate test. It also results in a possible loss of precision; for example, storing a large integer into a " { $link fixnum } " slot will silently overflow and discard high bits, and storing a ratio into a " { $link float } " slot may lose precision if the ratio is one which cannot be represented exactly with floating-point."
$nl
"This feature is mostly intended as an optimization for low-level code designed to avoid integer overflow, or where floating point precision is sufficient. Most code needs to work transparently with large integers, and thus hsould avoid the coercion behavior by using " { $link integer } " and " { $link real } " in place of " { $link fixnum } " and " { $link float } "." ;
ARTICLE: "tuple-declarations" "Tuple slot declarations"
"The slot specifier syntax of the " { $link POSTPONE: TUPLE: } " parsing word understands the following slot attributes:"
{ $list
"class declaration: values must satisfy the class predicate"
{ "whether a slot is read only or not (" { $link read-only } ")" }
{ "an initial value (" { $link initial: } ")" }
}
{ $subsection "slot-read-only-declaration" }
{ $subsection "slot-class-declaration" }
{ $subsection "slot-initial-values" } ;
ARTICLE: "parametrized-constructors" "Parameterized constructors"
"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
$nl
@ -58,22 +90,30 @@ ARTICLE: "tuple-constructors" "Tuple constructors"
{ $subsection POSTPONE: C: }
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
$nl
"Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple will initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "."
$nl
"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
$nl
"Examples of constructors:"
{ $code
"TUPLE: color red green blue alpha ;"
"TUPLE: color"
"{ red integer }"
"{ green integer }"
"{ blue integer }"
"{ alpha integer initial: 1 } ;"
""
"! The following two are equivalent"
"C: <rgba> rgba"
": <rgba> color boa ;"
""
"! We can define constructors which call other constructors"
": <rgb> f <rgba> ;"
": <rgb> 1 <rgba> ;"
""
"! The following two are equivalent"
": <color> color new ;"
": <color> f f f f <rgba> ;"
"! The following two are equivalent; note the initial value"
": <color> ( -- color ) color new ;"
": <color> ( -- color ) 0 0 0 1 <rgba> ;"
"! Run-time error"
"\"not a number\" 2 3 4 color boa"
}
{ $subsection "parametrized-constructors" } ;
@ -225,37 +265,66 @@ ARTICLE: "tuple-examples" "Tuple examples"
ARTICLE: "tuple-redefinition" "Tuple redefinition"
"In the following, the " { $emphasis "direct slots" } " of a tuple class refers to the slot names specified in the " { $link POSTPONE: TUPLE: } " form defining the tuple class, and the " { $emphasis "effective slots" } " refers to the concatenation of the direct slots together with slots defined on superclasses."
$nl
"When a tuple class is redefined, all instances of the class, including subclasses, are updated. For each instance, the list of effective slots is compared with the previous list. If any slots were removed, the values are removed from the instance and are lost forever. If any slots were added, the instance gains these slots with an initial value of " { $link f } "."
"When the " { $emphasis "effective slots" } " of a tuple class change, all instances of the class, including subclasses, are updated."
$nl
"There are three ways to change the list of effective slots of a class:"
"There are three ways in which the list of effective slots may change:"
{ $list
"Adding or removing direct slots of the class"
"Adding or removing direct slots of a superclass of the class"
"Changing the inheritance hierarchy by redefining a class to have a different superclass"
"Changing the inheritance hierarchy by changing the superclass of a class"
"Declarations changing on existing slots"
}
"In all cases, the new effective slots are compared with the old effective slots, and each instance is updated as follows:"
{ $list
"If any slots were removed, the values are removed from the instance and are lost forever."
{ "If any slots were added, the instance gains these slots with an initial value of " { $link f } "." }
"If any slots were added, the instance gains these slots, all set to their initial values."
"If any slots are permuted, their values in instances do not change; only the layout of the instance changes in memory."
"If the slot declaration of an existing slot changes, existing values are checked to see if they are still an instance of the required class. Any which are not are replaced by the initial value of that slot."
"If the number or order of effective slots changes, any BOA constructors are recompiled."
}
"Note that if a slot is moved from a class to its superclass (or vice versa) in the same compilation unit, the value of the slot is preserved in existing instances, because tuple instance update always runs at the end of a compilation unit. However, if it is removed in one compilation unit and added in another, the value in existing instances is lost." ;
ARTICLE: "protocol-slots" "Protocol slots"
"A " { $emphasis "protocol slot" } " is one which is assumed to exist by the implementation of a class, without being defined on the class itself. The burden is on subclasses (or mixin instances) to provide this slot."
$nl
"Protocol slots are defined using a parsing word:"
{ $subsection POSTPONE: SLOT: }
"Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass."
$nl
"For example, the " { $link growable } " mixin provides an implementation of the sequence protocol which wraps an underlying sequence, resizing it as necessary when elements are added beyond the length of the sequence. It assumes that the concrete mixin instances define two slots, " { $snippet "length" } " and " { $snippet "underlying" } ". These slots are defined as protocol slots:"
{ $snippet "SLOT: length" "SLOT: underlying" }
"An alternate approach would be to define " { $link growable } " as a tuple class with these two slots, and have other classes subclass it as required. However, this rules out subclasses defining these slots with custom type declarations."
$nl
"For example, compare the definitions of the " { $link sbuf } " class,"
{ $code
"TUPLE: sbuf"
"{ \"underlying\" string }"
"{ \"length\" array-capacity } ;"
""
"INSTANCE: sbuf growable"
}
"with that of the " { $link vector } " class:"
{ $code
"TUPLE: vector"
"{ \"underlying\" array }"
"{ \"length\" array-capacity } ;"
""
"INSTANCE: vector growable"
} ;
ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots."
"Tuples are user-defined classes composed of named slots. They are the central data type of Factor's object system."
{ $subsection "tuple-examples" }
"A parsing word defines tuple classes:"
{ $subsection POSTPONE: TUPLE: }
"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot."
"For each tuple class, several words are defined, the class word, a class predicate, and accessor words for each slot."
$nl
"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:"
"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly, and tuple slots are accessed via automatically-generated accessor words."
{ $subsection "accessors" }
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
{ $subsection "tuple-constructors" }
"Expressing relationships through the object system:"
{ $subsection "tuple-subclassing" }
"Introspection:"
{ $subsection "tuple-declarations" }
{ $subsection "protocol-slots" }
{ $subsection "tuple-introspection" }
"Tuple classes can be redefined; this updates existing instances:"
{ $subsection "tuple-redefinition" }
@ -263,6 +332,10 @@ $nl
ABOUT: "tuples"
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes.tuple prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
@ -337,7 +410,7 @@ HELP: <tuple-boa> ( ... layout -- tuple )
HELP: new
{ $values { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
{ $description "Creates a new instance of " { $snippet "class" } " with all slots set to their initial values (see" { $link "tuple-declarations" } ")." }
{ $examples
{ $example
"USING: kernel prettyprint ;"
@ -373,4 +446,5 @@ HELP: construct
HELP: boa
{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." }
{ $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ;

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

@ -3,8 +3,8 @@ math.constants parser sequences tools.test words assocs
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 math.order classes.private ;
calendar prettyprint io.streams.string splitting summary
columns math.order classes.private slots slots.private ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@ -88,20 +88,20 @@ C: <empty> empty
[ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ]
[ "IN: classes.tuple.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 name>> ] unit-test
TUPLE: size-test a b c d ;
[ t ] [
T{ size-test } tuple-size
size-test tuple-size =
size-test tuple-layout size>> =
] unit-test
GENERIC: <yo-momma>
TUPLE: yo-momma ;
"IN: classes.tuple.tests C: <yo-momma> yo-momma" eval
[ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval ] unit-test
[ f ] [ \ <yo-momma> generic? ] unit-test
@ -190,15 +190,6 @@ M: vector silly "z" ;
! Typo
SYMBOL: not-a-tuple-class
[
"IN: classes.tuple.tests C: <not-a-tuple-class> not-a-tuple-class"
eval
] must-fail
[ t ] [
"not-a-tuple-class" "classes.tuple.tests" lookup symbol?
] unit-test
! Missing check
[ not-a-tuple-class boa ] must-fail
[ not-a-tuple-class new ] must-fail
@ -212,16 +203,12 @@ C: <erg's-reshape-problem> erg's-reshape-problem
: 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
[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
[
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ error>> no-tuple-class? ] must-fail-with
! Inheritance
TUPLE: computer cpu ram ;
C: <computer> computer
@ -252,9 +239,9 @@ C: <laptop> laptop
test-laptop-slot-values
[ laptop ] [
"laptop" get tuple-layout
dup layout-echelon swap
layout-superclasses nth
"laptop" get 1 slot
dup echelon>> swap
superclasses>> nth
] unit-test
[ "TUPLE: laptop < computer battery ;" ] [
@ -361,7 +348,7 @@ test-server-slot-values
[ 110 ] [ "server" get voltage>> ] unit-test
! Reshaping superclass and subclass simultaneously
"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
test-laptop-slot-values
test-server-slot-values
@ -490,7 +477,9 @@ USE: vocabs
] with-compilation-unit
] unit-test
[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
[ "USE: words T{ word }" eval ]
[ error>> T{ no-method f word slots>tuple } = ]
must-fail-with
! Accessors not being forgotten...
[ [ ] ] [
@ -595,3 +584,102 @@ GENERIC: break-me ( obj -- )
[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
! Insufficient type checking
[ \ vocab tuple>array drop ] must-fail
! Check type declarations
TUPLE: declared-types { n fixnum } { m string } ;
[ T{ declared-types f 0 "hi" } ]
[ { declared-types f 0 "hi" } >tuple ]
unit-test
[ { declared-types f "hi" 0 } >tuple ]
[ T{ bad-slot-value f "hi" fixnum } = ]
must-fail-with
[ T{ declared-types f 0 "hi" } ]
[ 0.0 "hi" declared-types boa ] unit-test
: foo ( a b -- c ) declared-types boa ;
\ foo must-infer
[ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test
[ "hi" 0.0 declared-types boa ]
[ T{ no-method f "hi" >fixnum } = ]
must-fail-with
[ 0 { } declared-types boa ]
[ T{ bad-slot-value f { } string } = ]
must-fail-with
[ "hi" 0.0 foo ]
[ T{ no-method f "hi" >fixnum } = ]
must-fail-with
[ 0 { } foo ]
[ T{ bad-slot-value f { } string } = ]
must-fail-with
[ T{ declared-types f 0 "" } ] [ declared-types new ] unit-test
: blah ( -- vec ) vector new ;
\ blah must-infer
[ V{ } ] [ blah ] unit-test
! Test reshaping with type declarations and slot attributes
TUPLE: reshape-test x ;
T{ reshape-test f "hi" } "tuple" set
[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test
[ f ] [ \ reshape-test \ (>>x) method ] unit-test
[ "tuple" get 5 >>x ] must-fail
[ "hi" ] [ "tuple" get x>> ] unit-test
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test
[ 0 ] [ "tuple" get x>> ] unit-test
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test
[ 0 ] [ "tuple" get x>> ] unit-test
TUPLE: boa-coercer-test { x array-capacity } ;
[ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test
[ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test
! Test error classes
ERROR: error-class-test a b c ;
[ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test
[ f ] [ \ error-class-test "inline" word-prop ] unit-test
[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ]
[ error>> error>> redefine-error? ] must-fail-with
DEFER: error-y
[ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
[ ] [ "IN: classes.tuple.tests GENERIC: error-y" eval ] unit-test
[ f ] [ \ error-y tuple-class? ] unit-test
[ t ] [ \ error-y generic? ] unit-test
[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test
[ t ] [ \ error-y tuple-class? ] unit-test
[ f ] [ \ error-y generic? ] unit-test

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

@ -1,112 +1,157 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic
classes classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs ;
USING: arrays definitions hashtables kernel kernel.private math
namespaces sequences sequences.private strings vectors words
quotations memory combinators generic classes classes.algebra
classes.builtin classes.private slots.deprecated slots.private
slots compiler.units math.private accessors assocs effects ;
IN: classes.tuple
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: no-tuple-class class ;
ERROR: not-a-tuple object ;
: check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
<PRIVATE
GENERIC: tuple-layout ( object -- layout )
: (tuple) ( layout -- tuple )
#! In non-optimized code, this word simply calls the
#! <tuple> primitive. In optimized code, an intrinsic
#! is generated which allocates a tuple but does not set
#! any of its slots. This means that any code that uses
#! (tuple) must fill in the slots before the next
#! call to GC.
#!
#! This word is only used in the expansion of <tuple-boa>,
#! where this invariant is guaranteed to hold.
<tuple> ;
M: tuple-class tuple-layout "layout" word-prop ;
: tuple-layout ( class -- layout )
"layout" word-prop ;
M: tuple tuple-layout 1 slot ;
: layout-of ( tuple -- layout )
1 slot { tuple-layout } declare ; inline
M: tuple-layout tuple-layout ;
: tuple-size tuple-layout layout-size ; inline
: tuple-size ( tuple -- size )
layout-of size>> ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
[ tuple-size ] [ ] [ tuple-layout ] tri ;
check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
PRIVATE>
: check-slots ( seq class -- seq class )
[ ] [
2dup all-slots [
class>> 2dup instance?
[ 2drop ] [ bad-slot-value ] if
] 2each
] if-bootstrapping ; inline
: check-tuple ( class -- )
dup tuple-class?
[ drop ] [ no-tuple-class ] if ;
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
PRIVATE>
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
layout-class prefix ;
class>> prefix ;
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
: slots>tuple ( tuple class -- array )
GENERIC: slots>tuple ( seq class -- tuple )
M: tuple-class slots>tuple
check-slots pad-slots
tuple-layout <tuple> [
[ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
[ tuple-size ]
[ [ set-array-nth ] curry ]
bi 2each
] keep ;
: >tuple ( tuple -- seq )
: >tuple ( seq -- tuple )
unclip slots>tuple ;
: slot-names ( class -- seq )
"slot-names" word-prop
[ dup array? [ second ] when ] map ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
"slot-names" word-prop ;
ERROR: bad-superclass class ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
2dup [ tuple-layout ] bi@ eq? [
2dup [ layout-of ] bi@ eq? [
[ drop tuple-size ]
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
2bi all-integers?
] [
2drop f
] if ;
] if ; inline
! Predicate generation. We optimize at the expense of simplicity
: (tuple-predicate-quot) ( class -- quot )
#! 4 slot == layout-superclasses
#! 5 slot == layout-echelon
[
[ 1 slot dup 5 slot ] %
dup tuple-layout layout-echelon ,
[ fixnum>= ] %
[
dup tuple-layout layout-echelon ,
[ swap 4 slot array-nth ] %
literalize ,
[ eq? ] %
] [ ] make ,
[ drop f ] ,
\ if ,
] [ ] make ;
: tuple-predicate-quot ( class -- quot )
[
[ dup tuple? ] %
(tuple-predicate-quot) ,
[ drop f ] ,
\ if ,
] [ ] make ;
: tuple-instance? ( object class echelon -- ? )
#! 4 slot == superclasses>>
rot dup tuple? [
layout-of 4 slot
2dup array-capacity fixnum<
[ array-nth eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline
: define-tuple-predicate ( class -- )
dup tuple-predicate-quot define-predicate ;
dup dup tuple-layout echelon>>
[ tuple-instance? ] 2curry define-predicate ;
: superclass-size ( class -- n )
superclasses but-last-slice
[ slot-names length ] map sum ;
[ slot-names length ] sigma ;
: (instance-check-quot) ( class -- quot )
[
\ dup ,
[ "predicate" word-prop % ]
[ [ bad-slot-value ] curry , ] bi
\ unless ,
] [ ] make ;
: (fixnum-check-quot) ( class -- quot )
(instance-check-quot) fixnum "coercer" word-prop prepend ;
: instance-check-quot ( class -- quot )
{
{ [ dup object bootstrap-word eq? ] [ drop [ ] ] }
{ [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
{ [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] }
[ (instance-check-quot) ]
} cond ;
: boa-check-quot ( class -- quot )
all-slots 1 tail [ class>> instance-check-quot ] map spread>quot ;
: define-boa-check ( class -- )
dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype )
[ initial-values ] keep
over [ ] all? [ 2drop f ] [ slots>tuple ] if ;
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
: generate-tuple-slots ( class slots -- slot-specs )
over superclass-size 2 + simple-slots ;
over superclass-size 2 + make-slots deprecated-slots ;
: define-tuple-slots ( class -- )
dup dup "slot-names" word-prop generate-tuple-slots
@ -124,40 +169,54 @@ ERROR: bad-superclass class ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
: compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ;
: compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
[ drop [ class>> ] map ]
[ drop [ initial>> ] map ]
2tri 3array flip ;
: apply-slot-permutation ( old-values permutation -- new-values )
[ [ swap ?nth ] [ drop f ] if* ] with map ;
: update-slot ( old-values n class initial -- value )
pick [
>r >r swap nth dup r> instance?
[ r> drop ] [ drop r> ] if
] [ >r 3drop r> ] if ;
: permute-slots ( old-values -- new-values )
dup first dup outdated-tuples get at
: apply-slot-permutation ( old-values triples -- new-values )
[ first3 update-slot ] with map ;
: permute-slots ( old-values layout -- new-values )
[ class>> all-slots ] [ outdated-tuples get at ] bi
compute-slot-permutation
apply-slot-permutation ;
: change-tuple ( tuple quot -- newtuple )
>r tuple>array r> call >tuple ; inline
: update-tuple ( tuple -- newtuple )
[ permute-slots ] change-tuple ;
[ tuple-slots ] [ layout-of ] bi
[ permute-slots ] [ class>> ] bi
slots>tuple ;
: update-tuples ( -- )
outdated-tuples get
dup assoc-empty? [ drop ] [
[ >r class r> key? ] curry instances
[
over tuple?
[ >r layout-of r> key? ] [ 2drop f ] if
] curry instances
dup [ update-tuple ] map become
] if ;
[ update-tuples ] update-tuples-hook set-global
: update-tuples-after ( class -- )
outdated-tuples get [ all-slot-names ] cache drop ;
[ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
M: tuple-class update-class
[ define-tuple-layout ]
[ define-tuple-slots ]
[ define-tuple-predicate ]
tri ;
{
[ define-tuple-layout ]
[ define-tuple-slots ]
[ define-tuple-predicate ]
[ define-tuple-prototype ]
[ define-boa-check ]
} cleave ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f f tuple-class define-class ]
@ -202,32 +261,54 @@ M: word define-tuple-class
define-new-tuple-class ;
M: tuple-class define-tuple-class
over check-superclass
3dup tuple-class-unchanged?
[ over check-superclass 3dup redefine-tuple-class ] unless
3drop ;
[ 3drop ] [ redefine-tuple-class ] if ;
: thrower-effect ( slots -- effect )
[ dup array? [ first ] when ] map f <effect> t >>terminated? ;
: define-error-class ( class superclass slots -- )
[ define-tuple-class ] [ 2drop ] 3bi
dup [ boa throw ] curry define ;
[ define-tuple-class ]
[ 2drop reset-generic ]
[
[ dup [ boa throw ] curry ]
[ drop ]
[ thrower-effect ]
tri* define-declared
] 3tri ;
M: tuple-class reset-class
[
dup "slot-names" word-prop [
dup "slots" word-prop [
name>>
[ reader-word method forget ]
[ writer-word method forget ] 2bi
] with each
] [
{
"class"
"metaclass"
"superclass"
"layout"
"slots"
} reset-props
[ call-next-method ]
[
{
"layout" "slots" "slot-names" "boa-check" "prototype"
} reset-props
] bi
] bi ;
M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
dup tuple-layout echelon>> tuple-instance? ;
M: tuple-class (flatten-class) dup set ;
M: tuple-class (classes-intersect?)
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
[ swap classes-intersect? ]
} cond ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@ -242,6 +323,15 @@ M: tuple hashcode*
] 2curry each
] recursive-hashcode ;
M: tuple-class new
dup "prototype" word-prop
[ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop call ]
[ tuple-layout ]
bi <tuple-boa> ;
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;

88
core/classes/union/union-tests.factor Normal file
View File

@ -0,0 +1,88 @@
USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
compiler.units kernel.private sorting vocabs io.streams.string ;
IN: classes.union.tests
! DEFER: bah
! FORGET: bah
UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
[ "USING: alien math ;\nIN: classes.union.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test
! Test redefinition of classes
UNION: union-1 fixnum float ;
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
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
"IN: classes.union.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
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
[ "union-1" ] [ 8 generic-update-test ] unit-test
[ -7 generic-update-test ] must-fail
! Empty unions were causing problems
GENERIC: empty-union-test ( obj -- obj )
UNION: empty-union-1 ;
M: empty-union-1 empty-union-test ;
UNION: empty-union-2 ;
M: empty-union-2 empty-union-test ;
! Redefining a class didn't update containing unions
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
[ ] [ "IN: classes.union.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
! Too eager with reset-class
[ ] [ "IN: classes.union.tests SINGLETON: foo UNION: blah foo ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
[ ] [ "IN: classes.union.tests USE: math UNION: blah integer ;" <string-reader> "union-reset-test" parse-stream drop ] unit-test
[ t ] [ "blah" "classes.union.tests" lookup union-class? ] unit-test
GENERIC: test-generic ( x -- y )
TUPLE: a-tuple ;
UNION: a-union a-tuple ;
M: a-union test-generic ;
[ f ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test
[ ] [ [ \ a-tuple forget-class ] with-compilation-unit ] unit-test
[ t ] [ \ test-generic "methods" word-prop assoc-empty? ] unit-test

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

@ -1,7 +1,7 @@
! 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 ;
classes.algebra namespaces arrays math quotations ;
IN: classes.union
PREDICATE: union-class < class
@ -28,7 +28,10 @@ M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- )
[ (define-union-class) ] [ drop update-classes ] 2bi ;
M: union-class reset-class
{ "class" "metaclass" "members" } reset-props ;
M: union-class rank-class drop 2 ;
M: union-class instance?
"members" word-prop [ instance? ] with contains? ;
M: union-class (flatten-class)
members <anonymous-union> (flatten-class) ;

40
core/combinators/combinators-tests.factor
View File

@ -1,5 +1,6 @@
USING: alien strings kernel math tools.test io prettyprint
namespaces combinators words classes sequences ;
namespaces combinators words classes sequences accessors
math.functions ;
IN: combinators.tests
! Compiled
@ -140,7 +141,7 @@ IN: combinators.tests
[ "two" ] [ 2 case-test-1 ] unit-test
! Interpreted
[ "two" ] [ 2 \ case-test-1 word-def call ] unit-test
[ "two" ] [ 2 \ case-test-1 def>> call ] unit-test
[ "x" case-test-1 ] must-fail
@ -158,7 +159,7 @@ IN: combinators.tests
[ 25 ] [ 5 case-test-2 ] unit-test
! Interpreted
[ 25 ] [ 5 \ case-test-2 word-def call ] unit-test
[ 25 ] [ 5 \ case-test-2 def>> call ] unit-test
: case-test-3 ( obj -- obj' )
{
@ -257,12 +258,14 @@ IN: combinators.tests
: do-not-call "do not call" throw ;
: test-case-6
: test-case-6 ( obj -- value )
{
{ \ do-not-call [ "do-not-call" ] }
{ 3 [ "three" ] }
} case ;
\ test-case-6 must-infer
[ "three" ] [ 3 test-case-6 ] unit-test
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
@ -288,11 +291,26 @@ IN: combinators.tests
] unit-test
! Interpreted
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
[ "a hashtable" ] [ H{ } \ case-test-3 def>> call ] unit-test
[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test
[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test
[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test
[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
[ t ] [ { 1 3 2 } contiguous-range? ] unit-test
[ f ] [ { 1 2 2 4 } contiguous-range? ] unit-test
[ f ] [ { + 3 2 } contiguous-range? ] unit-test
[ f ] [ { 1 0 7 } contiguous-range? ] unit-test
[ f ] [ { 1 1 3 7 } contiguous-range? ] unit-test
[ t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
: test-case-7 ( obj -- str )
{
{ \ + [ "plus" ] }
{ \ - [ "minus" ] }
{ \ * [ "times" ] }
{ \ / [ "divide" ] }
{ \ ^ [ "power" ] }
{ \ [ [ "obama" ] }
{ \ ] [ "KFC" ] }
} case ;
\ test-case-7 must-infer
[ "plus" ] [ \ + test-case-7 ] unit-test

124
core/combinators/combinators.factor
View File

@ -1,36 +1,42 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences sequences.private math.private
USING: accessors arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
hashtables sorting words sets math.order ;
IN: combinators
! cleave
: cleave ( x seq -- )
[ call ] with each ;
: cleave>quot ( seq -- quot )
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
! 2cleave
: 2cleave ( x seq -- )
[ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
! 3cleave
: 3cleave ( x seq -- )
[ 3keep ] each 3drop ;
: 3cleave>quot ( seq -- quot )
[ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
! spread
: spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi
append [ ] like ;
[ ] [
[ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip
append
] reduce ;
: spread ( objs... seq -- )
spread>quot call ;
! cond
ERROR: no-cond ;
: cond ( assoc -- )
@ -38,14 +44,23 @@ ERROR: no-cond ;
[ dup callable? [ call ] [ second call ] if ]
[ no-cond ] if* ;
: alist>quot ( default assoc -- quot )
[ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- quot )
[ dup callable? [ [ t ] swap 2array ] when ] map
reverse [ no-cond ] swap alist>quot ;
! case
ERROR: no-case ;
: case-find ( obj assoc -- obj' )
[
dup array? [
dupd first dup word? [
execute
] [
dup wrapper? [ wrapped ] when
dup wrapper? [ wrapped>> ] when
] if =
] [ quotation? ] if
] find nip ;
@ -57,36 +72,6 @@ ERROR: no-case ;
{ [ dup not ] [ no-case ] }
} cond ;
: with-datastack ( stack quot -- newstack )
datastack >r
>r >array set-datastack r> call
datastack r> swap suffix set-datastack 2nip ; inline
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
! These go here, not in sequences and hashtables, since those
! two depend on combinators
M: sequence hashcode*
[ sequence-hashcode ] recursive-hashcode ;
M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: hashtable hashcode*
[
dup assoc-size 1 number=
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;
: alist>quot ( default assoc -- quot )
[ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- quot )
[ dup callable? [ [ t ] swap 2array ] when ] map
reverse [ no-cond ] swap alist>quot ;
: linear-case-quot ( default assoc -- quot )
[
[ 1quotation \ dup prefix \ = suffix ]
@ -112,7 +97,7 @@ M: hashtable hashcode*
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets
[ linear-case-quot ] with map ;
[ [ >r literalize r> ] assoc-map linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep
@ -122,17 +107,14 @@ M: hashtable hashcode*
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] prepend ;
: contiguous-range? ( keys -- from to ? )
: contiguous-range? ( keys -- ? )
dup [ fixnum? ] all? [
dup all-unique? [
dup infimum over supremum
[ - swap prune length + 1 = ] 2keep rot
] [
drop f f f
] if
] [
drop f f f
] if ;
[ prune length ]
[ [ supremum ] [ infimum ] bi - ]
bi - 1 =
] [ drop f ] if
] [ drop f ] if ;
: dispatch-case ( value from to default array -- )
>r >r 3dup between? [
@ -141,23 +123,41 @@ M: hashtable hashcode*
2drop r> call r> drop
] if ; inline
: dispatch-case-quot ( default assoc from to -- quot )
-roll -roll sort-keys values [ >quotation ] map
: dispatch-case-quot ( default assoc -- quot )
[ nip keys [ infimum ] [ supremum ] bi ] 2keep
sort-keys values [ >quotation ] map
[ dispatch-case ] 2curry 2curry ;
: case>quot ( default assoc -- quot )
dup empty? [
drop
] [
dup length 4 <=
over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
[
linear-case-quot
] [
dup keys contiguous-range? [
dispatch-case-quot
] [
2drop hash-case-quot
] if
] if
] if ;
dup keys {
{ [ dup empty? ] [ 2drop ] }
{ [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] }
{ [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
{ [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] }
{ [ dup [ wrapper? ] all? ] [ drop [ >r wrapped>> r> ] assoc-map hash-case-quot ] }
[ drop linear-case-quot ]
} cond ;
! with-datastack
: with-datastack ( stack quot -- newstack )
datastack >r
>r >array set-datastack r> call
datastack r> swap suffix set-datastack 2nip ; inline
! recursive-hashcode
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
! These go here, not in sequences and hashtables, since those
! two cannot depend on us
M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
M: hashtable hashcode*
[
dup assoc-size 1 number=
[ assoc-hashcode ] [ nip assoc-size ] if
] recursive-hashcode ;

4
core/compiler/compiler-docs.factor
View File

@ -26,7 +26,9 @@ ARTICLE: "compiler" "Optimizing compiler"
}
"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
{ $subsection "compiler-usage" }
{ $subsection "compiler-errors" } ;
{ $subsection "compiler-errors" }
{ $subsection "optimizer" }
{ $subsection "generator" } ;
ABOUT: "compiler"

1
core/compiler/compiler.factor
View File

@ -46,7 +46,6 @@ SYMBOL: +failed+
] tri ;
: (compile) ( word -- )
dup dup "compile-count" word-prop 0 or 1 + "compile-count" set-word-prop
[
H{ } clone dependencies set

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

@ -1,8 +1,8 @@
USING: arrays compiler.units kernel kernel.private math
USING: accessors 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 math.order
strings.private system random layouts vectors
sbufs 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
@ -332,11 +332,11 @@ cell 8 = [
] unit-test
[ V{ 1 2 } ] [
{ 1 2 3 } 2 [ array>vector ] compile-call
{ 1 2 3 } 2 [ vector boa ] compile-call
] unit-test
[ SBUF" hello" ] [
"hello world" 5 [ string>sbuf ] compile-call
"hello world" 5 [ sbuf boa ] compile-call
] unit-test
[ [ 3 + ] ] [
@ -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 ) word-def [ { fixnum } declare ] prepend ;
: xword-def ( word -- def ) 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

34
core/compiler/tests/redefine1.factor
View File

@ -1,7 +1,7 @@
IN: compiler.tests
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs ;
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs ;
GENERIC: method-redefine-test ( a -- b )
@ -23,13 +23,13 @@ M: integer method-redefine-test 3 + ;
: hey ( -- ) ;
: there ( -- ) hey ;
[ t ] [ \ hey compiled? ] unit-test
[ t ] [ \ there compiled? ] unit-test
[ t ] [ \ hey compiled>> ] unit-test
[ t ] [ \ there compiled>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ hey compiled? ] unit-test
[ f ] [ \ there compiled? ] unit-test
[ f ] [ \ hey compiled>> ] unit-test
[ f ] [ \ there compiled>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
[ t ] [ \ there compiled? ] unit-test
[ t ] [ \ there compiled>> ] unit-test
! Just changing the stack effect didn't mark a word for recompilation
DEFER: change-effect
@ -44,24 +44,24 @@ DEFER: change-effect
: bad ( -- ) good ;
: ugly ( -- ) bad ;
[ t ] [ \ good compiled? ] unit-test
[ t ] [ \ bad compiled? ] unit-test
[ t ] [ \ ugly compiled? ] unit-test
[ t ] [ \ good compiled>> ] unit-test
[ t ] [ \ bad compiled>> ] unit-test
[ t ] [ \ ugly compiled>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ good compiled? ] unit-test
[ f ] [ \ bad compiled? ] unit-test
[ f ] [ \ ugly compiled? ] unit-test
[ f ] [ \ good compiled>> ] unit-test
[ f ] [ \ bad compiled>> ] unit-test
[ f ] [ \ ugly compiled>> ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
[ t ] [ \ good compiled? ] unit-test
[ t ] [ \ bad compiled? ] unit-test
[ t ] [ \ ugly compiled? ] unit-test
[ t ] [ \ good compiled>> ] unit-test
[ t ] [ \ bad compiled>> ] unit-test
[ t ] [ \ ugly compiled>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test

10
core/compiler/tests/redefine3.factor
View File

@ -1,7 +1,7 @@
IN: compiler.tests
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs ;
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs ;
GENERIC: sheeple ( obj -- x )
@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
: sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled? ] unit-test
[ t ] [ \ sheeple-test compiled>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled? ] unit-test
[ t ] [ \ sheeple-test compiled>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

6
core/compiler/tests/reload.factor
View File

@ -1,6 +1,6 @@
IN: compiler.tests
USE: vocabs.loader
"parser" reload
"sequences" reload
"kernel" reload
! "parser" reload
! "sequences" reload
! "kernel" reload

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

@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
"USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
] unit-test
] times

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

@ -1,5 +1,5 @@
! Black box testing of templating optimization
USING: arrays compiler kernel kernel.private math
USING: accessors arrays compiler kernel kernel.private math
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
@ -138,7 +138,7 @@ unit-test
0 swap hellish-bug-2 drop ;
[ ] [
H{ { 1 2 } { 3 4 } } dup hash-array
H{ { 1 2 } { 3 4 } } dup array>>
[ 0 swap hellish-bug-2 drop ] compile-call
] unit-test
@ -245,13 +245,13 @@ TUPLE: my-tuple ;
[ dup float+ ]
} cleave ;
[ t ] [ \ float-spill-bug compiled? ] unit-test
[ t ] [ \ float-spill-bug compiled>> ] unit-test
! Regression
: dispatch-alignment-regression ( -- c )
{ tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test
[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test

14
core/compiler/tests/tuples.factor
View File

@ -6,19 +6,5 @@ TUPLE: color red green blue ;
[ T{ color f 1 2 3 } ]
[ 1 2 3 [ color boa ] compile-call ] unit-test
[ 1 3 ] [
1 2 3 color boa
[ { color-red color-blue } get-slots ] compile-call
] unit-test
[ T{ color f 10 2 20 } ] [
10 20
1 2 3 color boa [
[
{ set-color-red set-color-blue } set-slots
] compile-call
] keep
] unit-test
[ T{ color f f f f } ]
[ [ color new ] compile-call ] unit-test

6
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 sets ;
USING: accessors kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets ;
IN: compiler.units
SYMBOL: old-definitions
@ -54,7 +54,7 @@ GENERIC: definitions-changed ( assoc obj -- )
: changed-vocabs ( assoc -- vocabs )
[ drop word? ] assoc-filter
[ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
[ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
: updated-definitions ( -- assoc )
H{ } clone

8
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 ;
continuations.private vectors arrays namespaces
assocs words quotations lexer ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
@ -169,8 +169,8 @@ HELP: rethrow
"This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
}
{ $examples
"The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:"
{ $see with-parser }
"The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:"
{ $see with-lexer }
} ;
HELP: throw-restarts

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

@ -66,7 +66,7 @@ IN: continuations.tests
[ 1 3 2 ] [ bar ] unit-test
[ t ] [ \ bar word-def "c" get innermost-frame-quot = ] unit-test
[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test
[ 1 ] [ "c" get innermost-frame-scan ] unit-test

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory
namespaces sequences layouts system hashtables classes alien
byte-arrays bit-arrays float-arrays combinators words sets ;
byte-arrays combinators words sets ;
IN: cpu.architecture
! Register classes

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

@ -8,7 +8,7 @@ generator generator.registers generator.fixup sequences.private
sbufs vectors system layouts math.floats.private
classes classes.tuple classes.tuple.private sbufs.private
vectors.private strings.private slots.private combinators
bit-arrays float-arrays compiler.constants ;
compiler.constants ;
IN: cpu.ppc.intrinsics
: %slot-literal-known-tag
@ -437,14 +437,11 @@ IN: cpu.ppc.intrinsics
{ +clobber+ { "n" } }
} define-intrinsic
\ <tuple> [
tuple "layout" get layout-size 2 + cells %allot
\ (tuple) [
tuple "layout" get size>> 2 + cells %allot
! Store layout
"layout" get 12 load-indirect
12 11 cell STW
! Zero out the rest of the tuple
f v>operand 12 LI
"layout" get layout-size [ 12 11 rot 2 + cells STW ] each
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] H{

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

@ -5,7 +5,7 @@ cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
generator.registers generator.fixup generator system layouts
alien.compiler combinators command-line
compiler compiler.units io vocabs.loader accessors ;
compiler compiler.units io vocabs.loader accessors init ;
IN: cpu.x86.32
! We implement the FFI for Linux, OS X and Windows all at once.
@ -262,9 +262,11 @@ os windows? [
4 "double" c-type set-c-type-align
] unless
: sse2? ( -- ? ) "Intrinsic" throw ;
: (sse2?) ( -- ? ) "Intrinsic" throw ;
\ sse2? [
<<
\ (sse2?) [
{ EAX EBX ECX EDX } [ PUSH ] each
EAX 1 MOV
CPUID
@ -274,6 +276,10 @@ os windows? [
JE
] { } define-if-intrinsic
>>
: sse2? ( -- ? ) (sse2?) ;
"-no-sse2" cli-args member? [
"Checking if your CPU supports SSE2..." print flush
[ optimized-recompile-hook ] recompile-hook [
@ -282,6 +288,14 @@ os windows? [
[
" - yes" print
"cpu.x86.sse2" require
[
sse2? [
"This image was built to use SSE2, which your CPU does not support." print
"You will need to bootstrap Factor again." print
flush
1 exit
] unless
] "cpu.x86" add-init-hook
] [
" - no" print
] if

1
core/cpu/x86/32/bootstrap.factor
View File

@ -11,6 +11,7 @@ IN: bootstrap.x86
: temp-reg ( -- reg ) EBX ;
: stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
: fixnum>slot@ ( -- ) arg0 1 SAR ;
: rex-length ( -- n ) 0 ;

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

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays cpu.x86.assembler
USING: accessors alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces sequences generator.registers generator.fixup system
@ -178,7 +178,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
dup slot-spec-type swap slot-spec-offset 2array
[ class>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )

1
core/cpu/x86/64/bootstrap.factor
View File

@ -11,6 +11,7 @@ IN: bootstrap.x86
: temp-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
: rs-reg ( -- reg ) R15 ;
: fixnum>slot@ ( -- ) ;
: rex-length ( -- n ) 1 ;

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

@ -1,8 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! 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 math.order accessors ;
combinators kernel.private math namespaces sequences
words system layouts math.order accessors
cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.
@ -12,21 +13,6 @@ IN: cpu.x86.assembler
! Beware!
! Register operands -- eg, ECX
<<
: define-register ( name num size -- )
>r >r "cpu.x86.assembler" create dup define-symbol r> r>
>r dupd "register" set-word-prop r>
"register-size" set-word-prop ;
: define-registers ( names size -- )
>r dup length r> [ define-register ] curry 2each ;
: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing
>>
REGISTERS: 8 AL CL DL BL ;
REGISTERS: 16 AX CX DX BX SP BP SI DI ;

15
core/cpu/x86/assembler/syntax/syntax.factor Normal file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences lexer parser ;
IN: cpu.x86.assembler.syntax
: define-register ( name num size -- )
>r >r "cpu.x86.assembler" create dup define-symbol r> r>
>r dupd "register" set-word-prop r>
"register-size" set-word-prop ;
: define-registers ( names size -- )
>r dup length r> [ define-register ] curry 2each ;
: REGISTERS: ( -- )
scan-word ";" parse-tokens swap define-registers ; parsing

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

@ -74,6 +74,90 @@ big-endian off
arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
[
arg1 ds-reg [] MOV ! load from stack
arg1 tag-mask get AND ! compute tag
arg1 tag-bits get SHL ! tag the tag
ds-reg [] arg1 MOV ! push to stack
] f f f jit-tag jit-define
: jit-compare ( -- )
arg1 0 MOV ! load t
arg1 dup [] MOV
temp-reg \ f tag-number MOV ! load f
arg0 ds-reg [] MOV ! load first value
ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] arg0 CMP ! compare with second value
;
[
jit-compare
arg1 temp-reg CMOVNE ! not equal?
ds-reg [] arg1 MOV ! store
] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define
[
arg0 ds-reg [] MOV ! load slot number
ds-reg bootstrap-cell SUB ! adjust stack pointer
arg1 ds-reg [] MOV ! load object
fixnum>slot@ ! turn slot number into offset
arg1 tag-bits get SHR ! mask off tag
arg1 tag-bits get SHL
arg0 arg1 arg0 [+] MOV ! load slot value
ds-reg [] arg0 MOV ! push to stack
] f f f jit-slot jit-define
[
ds-reg bootstrap-cell SUB
] f f f jit-drop jit-define
[
arg0 ds-reg [] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
] f f f jit-dup jit-define
[
rs-reg bootstrap-cell ADD
arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
rs-reg [] arg0 MOV
] f f f jit->r jit-define
[
ds-reg bootstrap-cell ADD
arg0 rs-reg [] MOV
rs-reg bootstrap-cell SUB
ds-reg [] arg0 MOV
] f f f jit-r> jit-define
[
arg0 ds-reg [] MOV
arg1 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell neg [+] arg0 MOV
ds-reg [] arg1 MOV
] f f f jit-swap jit-define
[
arg0 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
] f f f jit-over jit-define
[
arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
arg1 ds-reg [] MOV
arg1 arg0 SUB
ds-reg [] arg1 MOV
] f f f jit-fixnum-fast jit-define
[
jit-compare
arg1 temp-reg CMOVL ! not equal?
ds-reg [] arg1 MOV ! store
] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
] f f f jit-epilog jit-define

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

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors arrays cpu.x86.assembler
USING: accessors alien alien.accessors arrays cpu.x86.assembler
cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
kernel.private math math.private namespaces quotations sequences
words generic byte-arrays hashtables hashtables.private
@ -289,15 +289,11 @@ IN: cpu.x86.intrinsics
{ +clobber+ { "n" } }
} define-intrinsic
\ <tuple> [
tuple "layout" get layout-size 2 + cells [
\ (tuple) [
tuple "layout" get size>> 2 + cells [
! Store layout
"layout" get "scratch" get load-literal
1 object@ "scratch" operand MOV
! Zero out the rest of the tuple
"layout" get layout-size [
2 + object@ f v>operand MOV
] each
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] %allot

35
core/debugger/debugger.factor
View File

@ -1,13 +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 prettyprint.config sequences assocs
sequences.private strings io.styles vectors words system
USING: slots arrays definitions generic hashtables summary io
kernel 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 ;
continuations.private combinators generic.math classes.builtin
classes compiler.units generic.standard vocabs threads
threads.private init kernel.private libc io.encodings
accessors math.order destructors ;
IN: debugger
GENERIC: error. ( error -- )
@ -16,7 +16,6 @@ GENERIC: error-help ( error -- topic )
M: object error. . ;
M: object error-help drop f ;
M: tuple error. describe ;
M: tuple error-help class ;
M: string error. print ;
@ -33,9 +32,6 @@ M: string error. print ;
: :get ( variable -- value )
error-continuation get continuation-name assoc-stack ;
: :vars ( -- )
error-continuation get continuation-name namestack. ;
: :res ( n -- * )
1- restarts get-global nth f restarts set-global restart ;
@ -190,12 +186,13 @@ M: no-method summary
M: no-method error.
"Generic word " write
dup no-method-generic pprint
dup generic>> pprint
" does not define a method for the " write
dup no-method-object class pprint
dup object>> class pprint
" class." print
"Allowed classes: " write dup no-method-generic order .
"Dispatching on object: " write no-method-object short. ;
"Dispatching on object: " write object>> short. ;
M: bad-slot-value summary drop "Bad store to specialized slot" ;
M: no-math-method summary
drop "No suitable arithmetic method" ;
@ -209,8 +206,8 @@ M: inconsistent-next-method summary
M: check-method summary
drop "Invalid parameters for create-method" ;
M: no-tuple-class summary
drop "BOA constructors can only be defined for tuple classes" ;
M: not-a-tuple summary
drop "Not a tuple" ;
M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ;
@ -292,10 +289,6 @@ M: encode-error summary drop "Character encoding error" ;
M: decode-error summary drop "Character decoding error" ;
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" ;

2
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 inspector
USING: combinators kernel math sequences accessors summary
dequeues ;
IN: dlists

8
core/effects/effects.factor
View File

@ -24,7 +24,7 @@ TUPLE: effect in out terminated? ;
GENERIC: (stack-picture) ( obj -- str )
M: string (stack-picture) ;
M: word (stack-picture) word-name ;
M: word (stack-picture) name>> ;
M: integer (stack-picture) drop "object" ;
: stack-picture ( seq -- string )
@ -42,14 +42,14 @@ M: integer (stack-picture) drop "object" ;
GENERIC: stack-effect ( word -- effect/f )
M: symbol stack-effect drop 0 1 <effect> ;
M: symbol stack-effect drop (( -- symbol )) ;
M: word stack-effect
{ "declared-effect" "inferred-effect" }
swap word-props [ at ] curry map [ ] find nip ;
swap props>> [ at ] curry map [ ] find nip ;
M: effect clone
[ in>> clone ] keep effect-out clone <effect> ;
[ in>> clone ] [ out>> clone ] bi <effect> ;
: split-shuffle ( stack shuffle -- stack1 stack2 )
in>> length cut* ;

9
core/effects/parser/parser-docs.factor Normal file
View File

@ -0,0 +1,9 @@
IN: effects.parser
USING: strings effects help.markup help.syntax ;
HELP: parse-effect
{ $values { "end" string } { "effect" "an instance of " { $link effect } } }
{ $description "Parses a stack effect from the current input line." }
{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." }
$parsing-note ;

15
core/effects/parser/parser.factor Normal file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: lexer sets sequences kernel splitting effects ;
IN: effects.parser
: parse-effect ( end -- effect )
parse-tokens dup { "(" "((" } intersect empty? [
{ "--" } split1 dup [
<effect>
] [
"Stack effect declaration must contain --" throw
] if
] [
"Stack effect declaration must not contain ( or ((" throw
] if ;

10
core/float-arrays/float-arrays-tests.factor
View File

@ -1,10 +0,0 @@
IN: float-arrays.tests
USING: float-arrays tools.test ;
[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test
[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize-float-array ] unit-test
[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test
[ -10 F{ } resize-float-array ] must-fail

43
core/float-arrays/float-arrays.factor
View File

@ -1,43 +0,0 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private alien.accessors sequences
sequences.private math math.private ;
IN: float-arrays
<PRIVATE
: float-array@ swap >fixnum 8 fixnum*fast ; inline
PRIVATE>
M: float-array clone (clone) ;
M: float-array length array-capacity ;
M: float-array nth-unsafe
float-array@ alien-double ;
M: float-array set-nth-unsafe
>r >r >float r> r> float-array@ set-alien-double ;
: >float-array ( seq -- float-array ) F{ } clone-like ; inline
M: float-array like
drop dup float-array? [ >float-array ] unless ;
M: float-array new-sequence drop 0.0 <float-array> ;
M: float-array equal?
over float-array? [ sequence= ] [ 2drop f ] if ;
M: float-array resize
resize-float-array ;
INSTANCE: float-array sequence
: 1float-array ( x -- array ) 1 swap <float-array> ; flushable
: 2float-array ( x y -- array ) F{ } 2sequence ; flushable
: 3float-array ( x y z -- array ) F{ } 3sequence ; flushable
: 4float-array ( w x y z -- array ) F{ } 4sequence ; flushable

4
core/generator/fixup/fixup.factor
View File

@ -88,7 +88,7 @@ TUPLE: rel-fixup arg class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
@ -120,7 +120,7 @@ SYMBOL: literal-table
>r add-literal r> rt-xt rel-fixup ;
: rel-primitive ( word class -- )
>r word-def first r> rt-primitive rel-fixup ;
>r def>> first r> rt-primitive rel-fixup ;
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;

17
core/generator/generator.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes combinators cpu.architecture
USING: accessors arrays assocs classes combinators cpu.architecture
effects generator.fixup generator.registers generic hashtables
inference inference.backend inference.dataflow io kernel
kernel.private layouts math namespaces optimizer
@ -13,14 +13,15 @@ SYMBOL: compiled
: queue-compile ( word -- )
{
{ [ dup compiled get key? ] [ drop ] }
{ [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] }
[ compile-queue get push-front ]
} cond ;
{ [ dup "forgotten" word-prop ] [ ] }
{ [ dup compiled get key? ] [ ] }
{ [ dup inlined-block? ] [ ] }
{ [ dup primitive? ] [ ] }
[ dup compile-queue get push-front ]
} cond drop ;
: maybe-compile ( word -- )
dup compiled? [ drop ] [ queue-compile ] if ;
dup compiled>> [ drop ] [ queue-compile ] if ;
SYMBOL: compiling-word
@ -31,7 +32,7 @@ SYMBOL: compiling-loops
! Label of current word, after prologue, makes recursion faster
SYMBOL: current-label-start
: compiled-stack-traces? ( -- ? ) 36 getenv ;
: compiled-stack-traces? ( -- ? ) 59 getenv ;
: begin-compiling ( word label -- )
H{ } clone compiling-loops set

15
core/generator/registers/registers.factor
View File

@ -3,7 +3,7 @@
USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays
words effects alien byte-arrays
accessors sets math.order ;
IN: generator.registers
@ -184,8 +184,6 @@ INSTANCE: constant value
{ [ dup \ f class<= ] [ drop %unbox-f ] }
{ [ dup simple-alien class<= ] [ drop %unbox-alien ] }
{ [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
{ [ dup bit-array class<= ] [ drop %unbox-byte-array ] }
{ [ dup float-array class<= ] [ drop %unbox-byte-array ] }
[ drop %unbox-any-c-ptr ]
} cond ; inline
@ -195,7 +193,9 @@ INSTANCE: constant value
#! temp then temp to the destination.
temp-reg over %move
operand-class temp-reg
{ set-operand-class set-tagged-vreg } tagged construct
tagged new
swap >>vreg
swap >>class
%move ;
: %move ( dst src -- )
@ -562,13 +562,10 @@ M: loc lazy-store
2drop t
] if ;
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;
: class-matches? ( actual expected -- ? )
{
{ f [ drop t ] }
{ known-tag [ class-tag >boolean ] }
{ known-tag [ dup [ class-tag >boolean ] when ] }
[ class<= ]
} case ;
@ -639,7 +636,7 @@ PRIVATE>
[ second template-matches? ] find nip ;
: operand-tag ( operand -- tag/f )
operand-class class-tag ;
operand-class dup [ class-tag ] when ;
UNION: immediate fixnum POSTPONE: f ;

14
core/generic/generic-tests.factor
View File

@ -1,8 +1,8 @@
USING: alien arrays definitions generic generic.standard
USING: accessors alien arrays definitions generic generic.standard
generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words
quotations classes classes.algebra continuations layouts
classes.union sorting compiler.units ;
quotations classes classes.algebra classes.tuple continuations
layouts classes.union sorting compiler.units ;
IN: generic.tests
GENERIC: foobar ( x -- y )
@ -144,7 +144,7 @@ M: integer generic-forget-test-1 / ;
[ t ] [
\ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains?
[ name>> "integer=>generic-forget-test-1" = ] contains?
] unit-test
[ ] [
@ -153,7 +153,7 @@ M: integer generic-forget-test-1 / ;
[ f ] [
\ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains?
[ name>> "integer=>generic-forget-test-1" = ] contains?
] unit-test
GENERIC: generic-forget-test-2 ( a b -- c )
@ -162,7 +162,7 @@ M: sequence generic-forget-test-2 = ;
[ t ] [
\ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains?
[ name>> "sequence=>generic-forget-test-2" = ] contains?
] unit-test
[ ] [
@ -171,7 +171,7 @@ M: sequence generic-forget-test-2 = ;
[ f ] [
\ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains?
[ name>> "sequence=>generic-forget-test-2" = ] contains?
] unit-test
GENERIC: generic-forget-test-3 ( a -- b )

16
core/generic/generic.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private
USING: accessors words kernel sequences namespaces assocs
hashtables definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects combinators
sets ;
IN: generic
@ -30,10 +30,10 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
: specific-method ( class word -- class )
order min-class ;
: specific-method ( class generic -- method/f )
tuck order min-class dup [ swap method ] [ 2drop f ] if ;
GENERIC: effective-method ( ... generic -- method )
GENERIC: effective-method ( generic -- method )
: next-method-class ( class generic -- class/f )
order [ class<= ] with filter reverse dup length 1 =
@ -42,7 +42,7 @@ GENERIC: effective-method ( ... generic -- method )
: next-method ( class generic -- class/f )
[ next-method-class ] keep method ;
GENERIC: next-method-quot* ( class generic -- quot )
GENERIC: next-method-quot* ( class generic combination -- quot )
: next-method-quot ( class generic -- quot )
dup "combination" word-prop next-method-quot* ;
@ -72,7 +72,7 @@ TUPLE: check-method class generic ;
3tri ; inline
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
[ name>> ] bi@ "=>" swap 3append ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
@ -93,7 +93,7 @@ M: method-body crossref?
check-method
[ method-word-props ] 2keep
method-word-name f <word>
[ set-word-props ] keep ;
swap >>props ;
: with-implementors ( class generic quot -- )
[ swap implementors-map get at ] dip call ; inline

2
core/generic/math/math-docs.factor
View File

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

33
core/generic/parser/parser.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel words generic namespaces summary ;
IN: generic.parser
ERROR: not-in-a-method-error ;
M: not-in-a-method-error summary
drop "call-next-method can only be called in a method definition" ;
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
: create-method-in ( class generic -- method )
create-method f set-word dup save-location ;
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
SYMBOL: current-class
SYMBOL: current-generic
: with-method-definition ( quot -- parsed )
[
>r
[ "method-class" word-prop current-class set ]
[ "method-generic" word-prop current-generic set ]
[ ] tri
r> call
] with-scope ; inline
: (M:) ( method def -- )
CREATE-METHOD [ parse-definition ] with-method-definition ;

20
core/generic/standard/engines/engines.factor
View File

@ -1,16 +1,16 @@
USING: assocs kernel namespaces quotations generic math
sequences combinators words classes.algebra ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel kernel.private namespaces quotations
generic math sequences combinators words classes.algebra arrays
;
IN: generic.standard.engines
SYMBOL: default
SYMBOL: assumed
SYMBOL: (dispatch#)
GENERIC: engine>quot ( engine -- quot )
M: quotation engine>quot ;
M: method-body engine>quot 1quotation ;
: engines>quots ( assoc -- assoc' )
[ engine>quot ] assoc-map ;
@ -22,7 +22,11 @@ M: method-body engine>quot 1quotation ;
: linear-dispatch-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
[
[ [ dup ] swap [ eq? ] curry compose ]
[ [ drop ] prepose ]
bi* [ ] like
] assoc-map
alist>quot ;
: split-methods ( assoc class -- first second )
@ -36,8 +40,6 @@ M: method-body engine>quot 1quotation ;
r> execute r> pick set-at
] if ; inline
SYMBOL: (dispatch#)
: (picker) ( n -- quot )
{
{ 0 [ [ dup ] ] }

19
core/generic/standard/engines/predicate/predicate.factor
View File

@ -1,6 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generic.standard.engines generic namespaces kernel
sequences classes.algebra accessors words combinators
assocs ;
kernel.private sequences classes.algebra accessors words
combinators assocs arrays ;
IN: generic.standard.engines.predicate
TUPLE: predicate-dispatch-engine methods ;
@ -24,8 +26,13 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
: sort-methods ( assoc -- assoc' )
>alist [ keys sort-classes ] keep extract-keys ;
: methods-with-default ( engine -- assoc )
methods>> clone default get object bootstrap-word pick set-at ;
M: predicate-dispatch-engine engine>quot
methods>> clone
default get object bootstrap-word pick set-at engines>quots
sort-methods prune-redundant-predicates
class-predicates alist>quot ;
methods-with-default
engines>quots
sort-methods
prune-redundant-predicates
class-predicates
alist>quot ;

2
core/generic/standard/engines/tag/tag.factor
View File

@ -44,7 +44,7 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
"type" word-prop num-tags get - ;
: hi-tag-quot ( -- quot )
[ hi-tag ] num-tags get [ fixnum-fast ] curry compose ;
[ 0 slot ] num-tags get [ fixnum-fast ] curry compose ;
M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map

36
core/generic/standard/engines/tuple/tuple.factor
View File

@ -18,7 +18,7 @@ C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
TUPLE: tuple-dispatch-engine echelons ;
: push-echelon ( class method assoc -- )
>r swap dup "layout" word-prop layout-echelon r>
>r swap dup "layout" word-prop echelon>> r>
[ ?set-at ] change-at ;
: echelon-sort ( assoc -- assoc' )
@ -54,7 +54,7 @@ M: trivial-tuple-dispatch-engine engine>quot
] [ ] make ;
: engine-word-name ( -- string )
generic get word-name "/tuple-dispatch-engine" append ;
generic get name>> "/tuple-dispatch-engine" append ;
PREDICATE: engine-word < word
"tuple-dispatch-generic" word-prop generic? ;
@ -80,15 +80,17 @@ M: engine-word irrelevant? drop t ;
: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
: tuple-layout-superclasses ( obj -- array )
{ tuple } declare
1 slot { tuple-layout } declare
4 slot { array } declare ; inline
: tuple-layout-superclasses% ( -- )
[
{ tuple } declare
1 slot { tuple-layout } declare
4 slot { array } declare
] % ; inline
: tuple-dispatch-engine-body ( engine -- quot )
[
picker %
[ tuple-layout-superclasses ] %
tuple-layout-superclasses%
[ n>> array-nth% ]
[
methods>> [
@ -106,7 +108,7 @@ M: echelon-dispatch-engine engine>quot
] [
[
picker %
[ tuple-layout-superclasses ] %
tuple-layout-superclasses%
[ n>> array-nth% ]
[
methods>> [
@ -120,18 +122,24 @@ M: echelon-dispatch-engine engine>quot
: >=-case-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
[
[ [ dup ] swap [ fixnum>= ] curry compose ]
[ [ drop ] prepose ]
bi* [ ] like
] assoc-map
alist>quot ;
: tuple-layout-echelon ( obj -- array )
{ tuple } declare
1 slot { tuple-layout } declare
5 slot ; inline
: tuple-layout-echelon% ( -- )
[
{ tuple } declare
1 slot { tuple-layout } declare
5 slot
] % ; inline
M: tuple-dispatch-engine engine>quot
[
picker %
[ tuple-layout-echelon ] %
tuple-layout-echelon%
[
tuple assumed set
echelons>> dup empty? [

10
core/generic/standard/standard-tests.factor
View File

@ -287,7 +287,7 @@ M: sbuf no-stack-effect-decl ;
[ ] [ \ no-stack-effect-decl see ] unit-test
[ ] [ \ no-stack-effect-decl word-def . ] unit-test
[ ] [ \ no-stack-effect-decl def>> . ] unit-test
! Cross-referencing with generic words
TUPLE: xref-tuple-1 ;
@ -309,3 +309,11 @@ M: xref-tuple-2 xref-test (xref-test) ;
\ xref-test
\ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
] unit-test
[ t ] [
{ } \ nth effective-method nip \ sequence \ nth method eq?
] unit-test
[ t ] [
\ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
] unit-test

24
core/generic/standard/standard.factor
View File

@ -10,7 +10,16 @@ IN: generic.standard
GENERIC: dispatch# ( word -- n )
M: word dispatch# "combination" word-prop dispatch# ;
M: generic dispatch#
"combination" word-prop dispatch# ;
GENERIC: method-declaration ( class generic -- quot )
M: generic method-declaration
"combination" word-prop method-declaration ;
M: quotation engine>quot
assumed get generic get method-declaration prepend ;
: unpickers
{
@ -93,11 +102,11 @@ ERROR: no-next-method class generic ;
: single-next-method-quot ( class generic -- quot )
[
[ drop [ instance? ] curry % ]
[ drop "predicate" word-prop % ]
[
2dup next-method
[ 2nip 1quotation ]
[ [ no-next-method ] 2curry ] if* ,
[ [ no-next-method ] 2curry [ ] like ] if* ,
]
[ [ inconsistent-next-method ] 2curry , ]
2tri
@ -105,7 +114,9 @@ ERROR: no-next-method class generic ;
] [ ] make ;
: single-effective-method ( obj word -- method )
[ order [ instance? ] with find-last nip ] keep method ;
[ [ order [ instance? ] with find-last nip ] keep method ]
[ "default-method" word-prop ]
bi or ;
TUPLE: standard-combination # ;
@ -133,6 +144,9 @@ M: standard-combination perform-combination
M: standard-combination dispatch# #>> ;
M: standard-combination method-declaration
dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
M: standard-combination next-method-quot*
[
single-next-method-quot picker prepend
@ -155,6 +169,8 @@ PREDICATE: hook-generic < generic
M: hook-combination dispatch# drop 0 ;
M: hook-combination method-declaration 2drop [ ] ;
M: hook-generic extra-values drop 1 ;
M: hook-generic effective-method

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

@ -10,3 +10,5 @@ IN: grouping.tests
2 over set-length
>array
] unit-test
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test

4
core/grouping/grouping.factor
View File

@ -4,7 +4,7 @@ USING: kernel math math.order strings arrays vectors sequences
accessors ;
IN: grouping
TUPLE: abstract-groups seq n ;
TUPLE: abstract-groups { seq read-only } { n read-only } ;
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
@ -56,7 +56,7 @@ M: clumps set-length
M: clumps group@
[ n>> over + ] [ seq>> ] bi ;
TUPLE: sliced-clumps < groups ;
TUPLE: sliced-clumps < clumps ;
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline

26
core/growable/growable-docs.factor
View File

@ -7,31 +7,17 @@ ARTICLE: "growable" "Resizable sequence implementation"
$nl
"There is a resizable sequence mixin:"
{ $subsection growable }
"This mixin implements the sequence protocol in terms of a growable protocol:"
{ $subsection underlying }
{ $subsection set-underlying }
{ $subsection set-fill }
"This mixin implements the sequence protocol by assuming the object has two specific slots:"
{ $list
{ { $snippet "length" } " - the fill pointer (number of occupied elements in the underlying storage)" }
{ { $snippet "underlying" } " - the underlying storage" }
}
"The underlying sequence must implement a generic word:"
{ $subsection resize }
{ $link "vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ;
{ $link "vectors" } ", " { $link "byte-vectors" } " and " { $link "sbufs" } " are implemented using the resizable sequence facility." ;
ABOUT: "growable"
HELP: set-fill
{ $values { "n" "a new fill pointer" } { "seq" growable } }
{ $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." }
{ $side-effects "seq" }
{ $warning "This word is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
HELP: underlying
{ $values { "seq" growable } { "underlying" "the underlying sequence" } }
{ $contract "Outputs the underlying storage of a resizable sequence." } ;
HELP: set-underlying
{ $values { "underlying" sequence } { "seq" growable } }
{ $contract "Modifies the underlying storage of a resizable sequence." }
{ $warning "This word is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ;
HELP: capacity
{ $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } }
{ $description "Outputs the number of elements the sequence can hold without growing." } ;

27
core/growable/growable.factor
View File

@ -1,24 +1,24 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
! Some low-level code used by vectors and string buffers.
USING: kernel kernel.private math math.private
USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
IN: growable
MIXIN: growable
GENERIC: underlying ( seq -- underlying )
GENERIC: set-underlying ( underlying seq -- )
GENERIC: set-fill ( n seq -- )
M: growable nth-unsafe underlying nth-unsafe ;
SLOT: length
SLOT: underlying
M: growable set-nth-unsafe underlying set-nth-unsafe ;
M: growable length length>> ;
M: growable nth-unsafe underlying>> nth-unsafe ;
M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
: capacity ( seq -- n ) underlying length ; inline
: capacity ( seq -- n ) underlying>> length ; inline
: expand ( len seq -- )
[ underlying resize ] keep set-underlying ; inline
[ resize ] change-underlying drop ; inline
: contract ( len seq -- )
[ length ] keep
@ -35,7 +35,7 @@ M: growable set-length ( n seq -- )
] [
2dup capacity > [ 2dup expand ] when
] if
>r >fixnum r> set-fill ;
(>>length) ;
: new-size ( old -- new ) 1+ 3 * ; inline
@ -44,20 +44,19 @@ M: growable set-length ( n seq -- )
2dup length >= [
2dup capacity >= [ over new-size over expand ] when
>r >fixnum r>
2dup >r 1 fixnum+fast r> set-fill
over 1 fixnum+fast over (>>length)
] [
>r >fixnum r>
] if ; inline
M: growable set-nth ensure set-nth-unsafe ;
M: growable clone ( seq -- newseq )
(clone) dup underlying clone over set-underlying ;
M: growable clone (clone) [ clone ] change-underlying ;
M: growable lengthen ( n seq -- )
2dup length > [
2dup capacity > [ over new-size over expand ] when
2dup >r >fixnum r> set-fill
2dup (>>length)
] when 2drop ;
INSTANCE: growable sequence

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

@ -8,7 +8,7 @@ ARTICLE: "hashtables.private" "Hashtable implementation details"
$nl
"There are two special objects: the " { $link ((tombstone)) } " marker and the " { $link ((empty)) } " marker. Neither of these markers can be used as hashtable keys."
$nl
"The " { $link hash-count } " slot is the number of entries including deleted entries, and " { $link hash-deleted } " is the number of deleted entries."
"The " { $snippet "count" } " slot is the number of entries including deleted entries, and " { $snippet "deleted" } " is the number of deleted entries."
{ $subsection <hash-array> }
{ $subsection set-nth-pair }
"If a hashtable's keys are mutated, or if hashing algorithms change, hashtables can be rehashed:"

43
core/hashtables/hashtables.factor
View File

@ -1,9 +1,14 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs
math.private sequences sequences.private vectors grouping ;
USING: accessors arrays kernel kernel.private slots.private math
assocs math.private sequences sequences.private vectors grouping ;
IN: hashtables
TUPLE: hashtable
{ count array-capacity }
{ deleted array-capacity }
{ array array } ;
<PRIVATE
: wrap ( i array -- n )
@ -23,16 +28,16 @@ IN: hashtables
] if ; inline
: key@ ( key hash -- array n ? )
hash-array 2dup hash@ (key@) ; inline
array>> 2dup hash@ (key@) ; inline
: <hash-array> ( n -- array )
1+ next-power-of-2 4 * ((empty)) <array> ; inline
: init-hash ( hash -- )
0 over set-hash-count 0 swap set-hash-deleted ;
0 >>count 0 >>deleted drop ; inline
: reset-hash ( n hash -- )
swap <hash-array> over set-hash-array init-hash ;
swap <hash-array> >>array init-hash ;
: (new-key@) ( key keys i -- keys n empty? )
3dup swap array-nth dup ((empty)) eq? [
@ -46,17 +51,17 @@ IN: hashtables
] if ; inline
: new-key@ ( key hash -- array n empty? )
hash-array 2dup hash@ (new-key@) ; inline
array>> 2dup hash@ (new-key@) ; inline
: set-nth-pair ( value key seq n -- )
2 fixnum+fast [ set-slot ] 2keep
1 fixnum+fast set-slot ; inline
: hash-count+ ( hash -- )
dup hash-count 1+ swap set-hash-count ; inline
[ 1+ ] change-count drop ; inline
: hash-deleted+ ( hash -- )
dup hash-deleted 1+ swap set-hash-deleted ; inline
[ 1+ ] change-deleted drop ; inline
: (set-hash) ( value key hash -- new? )
2dup new-key@
@ -67,11 +72,11 @@ IN: hashtables
swap [ swapd (set-hash) drop ] curry assoc-each ;
: hash-large? ( hash -- ? )
[ hash-count 3 fixnum*fast ]
[ hash-array array-capacity ] bi > ;
[ count>> 3 fixnum*fast ]
[ array>> array-capacity ] bi > ;
: hash-stale? ( hash -- ? )
[ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ;
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ;
: grow-hash ( hash -- )
[ dup >alist swap assoc-size 1+ ] keep
@ -98,7 +103,7 @@ M: hashtable at* ( key hash -- value ? )
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
M: hashtable clear-assoc ( hash -- )
dup init-hash hash-array [ drop ((empty)) ] change-each ;
[ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ;
M: hashtable delete-at ( key hash -- )
tuck key@ [
@ -109,14 +114,12 @@ M: hashtable delete-at ( key hash -- )
] if ;
M: hashtable assoc-size ( hash -- n )
dup hash-count swap hash-deleted - ;
[ count>> ] [ deleted>> ] bi - ;
: rehash ( hash -- )
dup >alist
over hash-array length ((empty)) <array> pick set-hash-array
0 pick set-hash-count
0 pick set-hash-deleted
(rehash) ;
dup >alist >r
dup clear-assoc
r> (rehash) ;
M: hashtable set-at ( value key hash -- )
dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ;
@ -125,10 +128,10 @@ M: hashtable set-at ( value key hash -- )
2 <hashtable> [ set-at ] keep ;
M: hashtable >alist
hash-array 2 <groups> [ first tombstone? not ] filter ;
array>> 2 <groups> [ first tombstone? not ] filter ;
M: hashtable clone
(clone) dup hash-array clone over set-hash-array ;
(clone) [ clone ] change-array ;
M: hashtable equal?
over hashtable? [

16
core/inference/backend/backend.factor
View File

@ -80,7 +80,7 @@ M: object value-literal \ literal-expected inference-warning ;
1 #drop node,
pop-d dup value-literal >r value-recursion r> ;
: value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
: value-vector ( n -- vector ) [ <computed> ] V{ } replicate-as ;
: add-inputs ( seq stack -- n stack )
tuck [ length ] bi@ - dup 0 >
@ -111,7 +111,7 @@ GENERIC: apply-object ( obj -- )
M: object apply-object apply-literal ;
M: wrapper apply-object
wrapped dup +called+ depends-on apply-literal ;
wrapped>> dup +called+ depends-on apply-literal ;
: terminate ( -- )
terminated? on #terminate node, ;
@ -162,7 +162,7 @@ TUPLE: too-many-r> ;
dup ensure-values
#>r
over 0 pick node-inputs
over [ drop pop-d ] map reverse [ push-r ] each
over [ pop-d ] replicate reverse [ push-r ] each
0 pick pick node-outputs
node,
drop ;
@ -171,7 +171,7 @@ TUPLE: too-many-r> ;
dup check-r>
#r>
0 pick pick node-inputs
over [ drop pop-r ] map reverse [ push-d ] each
over [ pop-r ] replicate reverse [ push-d ] each
over 0 pick node-outputs
node,
drop ;
@ -228,7 +228,7 @@ M: object constructor drop f ;
1 infer->r
peek-d reify-curry
1 infer-r>
2 1 <effect> swap #call consume/produce
(( obj quot -- curry )) swap #call consume/produce
] when* ;
: reify-curries ( n -- )
@ -400,7 +400,7 @@ TUPLE: missing-effect word ;
{ [ dup inline? ] [ drop f ] }
{ [ dup deferred? ] [ drop f ] }
{ [ dup crossref? not ] [ drop f ] }
[ word-def [ [ word? ] [ primitive? not ] bi and ] contains? ]
[ def>> [ [ word? ] [ primitive? not ] bi and ] contains? ]
} cond ;
: ?missing-effect ( word -- )
@ -429,7 +429,7 @@ TUPLE: missing-effect word ;
[
init-inference
dependencies off
dup word-def over dup infer-quot-recursive
dup def>> over dup infer-quot-recursive
end-infer
finish-word
current-effect
@ -492,7 +492,7 @@ M: #return collect-label-info*
: inline-block ( word -- #label data )
[
copy-inference nest-node
[ word-def ] [ <inlined-block> ] bi
[ def>> ] [ <inlined-block> ] bi
[ infer-quot-recursive ] 2keep
#label unnest-node
dup collect-label-info

39
core/inference/class/class-tests.factor
View File

@ -4,8 +4,9 @@ inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts vectors optimizer.math.partial accessors
optimizer.inlining math.order ;
system layouts vectors optimizer.math.partial
optimizer.inlining optimizer.backend math.order
accessors hashtables classes assocs ;
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
@ -159,7 +160,7 @@ DEFER: blah
[ dup V{ } eq? [ foo ] when ] dup second dup push define
] with-compilation-unit
\ blah word-def dataflow optimize drop
\ blah def>> dataflow optimize drop
] unit-test
GENERIC: detect-fx ( n -- n )
@ -567,6 +568,38 @@ M: integer detect-integer ;
\ detect-integer inlined?
] unit-test
[ t ] [
[ hashtable new ] \ new inlined?
] unit-test
[ t ] [
[ dup hashtable eq? [ new ] when ] \ new inlined?
] unit-test
[ t ] [
[ { hashtable } declare hashtable instance? ] \ instance? inlined?
] unit-test
[ t ] [
[ { vector } declare hashtable instance? ] \ instance? inlined?
] unit-test
[ f ] [
[ { assoc } declare hashtable instance? ] \ instance? inlined?
] unit-test
TUPLE: declared-fixnum { x fixnum } ;
[ t ] [
[ { declared-fixnum } declare [ 1 + ] change-x ]
{ + fixnum+ >fixnum } inlined?
] unit-test
[ t ] [
[ { declared-fixnum } declare x>> drop ]
{ slot } inlined?
] unit-test
! Later
! [ t ] [

2
core/inference/errors/errors.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
IN: inference.errors
USING: inference.backend inference.dataflow kernel generic
sequences prettyprint io words arrays inspector effects debugger
sequences prettyprint io words arrays summary effects debugger
assocs accessors ;
M: inference-error error-help error>> error-help ;

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

@ -92,7 +92,7 @@ ARTICLE: "inference-errors" "Inference errors"
{ $subsection missing-effect } ;
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
$nl
"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:"
{ $subsection infer. }

6
core/inference/inference-tests.factor
View File

@ -1,4 +1,4 @@
USING: arrays generic inference inference.backend
USING: accessors arrays generic inference inference.backend
inference.dataflow kernel classes kernel.private math
math.parser math.private namespaces namespaces.private parser
sequences strings vectors words quotations effects tools.test
@ -271,7 +271,7 @@ DEFER: #1
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
[ \ #4 word-def infer ] must-fail
[ \ #4 def>> infer ] must-fail
[ [ #1 ] infer ] must-fail
! Similar
@ -396,6 +396,8 @@ DEFER: bar
\ define-tuple-class must-infer
\ define-union-class must-infer
\ define-predicate-class must-infer
\ instance? must-infer
\ next-method-quot must-infer
! Test words with continuations
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as

35
core/inference/known-words/known-words.factor
View File

@ -1,16 +1,15 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.accessors arrays bit-arrays byte-arrays
classes sequences.private continuations.private effects
float-arrays generic hashtables hashtables.private
inference.state inference.backend inference.dataflow io
io.backend io.files io.files.private io.streams.c kernel
kernel.private math math.private memory namespaces
namespaces.private parser prettyprint quotations
USING: accessors alien alien.accessors arrays byte-arrays
classes sequences.private continuations.private effects generic
hashtables hashtables.private inference.state inference.backend
inference.dataflow io io.backend io.files io.files.private
io.streams.c kernel kernel.private math math.private memory
namespaces namespaces.private parser prettyprint quotations
quotations.private sbufs sbufs.private sequences
sequences.private slots.private strings strings.private system
threads.private classes.tuple classes.tuple.private vectors
vectors.private words words.private assocs inspector
vectors.private words words.private assocs summary
compiler.units system.private ;
IN: inference.known-words
@ -137,7 +136,7 @@ M: object infer-call
! Variadic tuple constructor
\ <tuple-boa> [
\ <tuple-boa>
peek-d value-literal layout-size { tuple } <effect>
peek-d value-literal size>> { tuple } <effect>
make-call-node
] "infer" set-word-prop
@ -399,12 +398,6 @@ set-primitive-effect
\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
\ <byte-array> make-flushable
\ <bit-array> { integer } { bit-array } <effect> set-primitive-effect
\ <bit-array> make-flushable
\ <float-array> { integer float } { float-array } <effect> set-primitive-effect
\ <float-array> make-flushable
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
\ <displaced-alien> make-flushable
@ -492,12 +485,6 @@ set-primitive-effect
\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
\ resize-byte-array make-flushable
\ resize-bit-array { integer bit-array } { bit-array } <effect> set-primitive-effect
\ resize-bit-array make-flushable
\ resize-float-array { integer float-array } { float-array } <effect> set-primitive-effect
\ resize-float-array make-flushable
\ resize-string { integer string } { string } <effect> set-primitive-effect
\ resize-string make-flushable
@ -529,9 +516,6 @@ set-primitive-effect
\ fclose { alien } { } <effect> set-primitive-effect
\ expired? { object } { object } <effect> set-primitive-effect
\ expired? make-flushable
\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
\ <wrapper> make-foldable
@ -550,6 +534,9 @@ set-primitive-effect
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
\ <tuple> make-flushable
\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
\ (tuple) make-flushable
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
\ <tuple-layout> make-foldable

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