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

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

db4
Eduardo Cavazos 2008-04-04 12:27:10 -05:00
parent a870b7d635 b35ef01860
commit 0a8bbcf950
269 changed files with 3822 additions and 2832 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -76,8 +76,8 @@ $nl
{ $examples "Here is a typical usage of " { $link add-library } ":"
{ $code
"<< \"freetype\" {"
" { [ macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
" { [ windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
" { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
" { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
" { [ t ] [ drop ] }"
"} cond >>"
}

8
core/alien/alien.factor
View File

@ -29,7 +29,7 @@ M: f expired? drop t ;
f <displaced-alien> { simple-c-ptr } declare ; inline
: alien>native-string ( alien -- string )
windows? [ alien>u16-string ] [ alien>char-string ] if ;
os windows? [ alien>u16-string ] [ alien>char-string ] if ;
: dll-path ( dll -- string )
(dll-path) alien>native-string ;
@ -62,22 +62,16 @@ TUPLE: library path abi dll ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;
TUPLE: alien-callback return parameters abi quot xt ;
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
alien-callback-error ;
TUPLE: alien-indirect return parameters abi ;
ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- )
alien-indirect-error ;
TUPLE: alien-invoke library function return parameters abi ;
ERROR: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )

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

@ -25,7 +25,7 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ;
M: value-type c-type-reg-class drop T{ int-regs } ;
M: value-type c-type-reg-class drop int-regs ;
M: value-type c-type-prep drop f ;

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

@ -4,7 +4,8 @@ USING: bit-arrays byte-arrays float-arrays arrays
generator.registers 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 ;
layouts system compiler.units io.files io.encodings.binary
accessors combinators ;
IN: alien.c-types
DEFER: <int>
@ -17,8 +18,12 @@ boxer prep unboxer
getter setter
reg-class size align stack-align? ;
: construct-c-type ( class -- type )
construct-empty
int-regs >>reg-class ;
: <c-type> ( -- type )
T{ int-regs } { set-c-type-reg-class } \ c-type construct ;
\ c-type construct-c-type ;
SYMBOL: c-types
@ -181,10 +186,10 @@ DEFER: >c-ushort-array
: define-c-type ( type name vocab -- )
>r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
TUPLE: long-long-type ;
TUPLE: long-long-type < c-type ;
: <long-long-type> ( type -- type )
long-long-type construct-delegate ;
: <long-long-type> ( -- type )
long-long-type construct-c-type ;
M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ;
@ -235,22 +240,15 @@ M: long-long-type box-return ( type -- )
: define-from-array ( type vocab -- )
[ from-array-word ] 2keep c-array>quot define ;
: <primitive-type> ( getter setter width boxer unboxer -- type )
<c-type>
[ set-c-type-unboxer ] keep
[ set-c-type-boxer ] keep
[ set-c-type-size ] 2keep
[ set-c-type-align ] keep
[ set-c-type-setter ] keep
[ set-c-type-getter ] keep ;
: define-primitive-type ( type name -- )
"alien.c-types"
[ define-c-type ] 2keep
[ define-deref ] 2keep
[ define-to-array ] 2keep
[ define-from-array ] 2keep
define-out ;
{
[ define-c-type ]
[ define-deref ]
[ define-to-array ]
[ define-from-array ]
[ define-out ]
} 2cleave ;
: expand-constants ( c-type -- c-type' )
#! We use word-def call instead of execute to get around
@ -264,130 +262,157 @@ M: long-long-type box-return ( type -- )
binary file-contents dup malloc-byte-array swap length ;
[
[ alien-cell ]
[ set-alien-cell ]
bootstrap-cell
"box_alien"
"alien_offset" <primitive-type>
<c-type>
[ alien-cell ] >>getter
[ set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
"box_alien" >>boxer
"alien_offset" >>unboxer
"void*" define-primitive-type
[ alien-signed-8 ]
[ set-alien-signed-8 ]
8
"box_signed_8"
"to_signed_8" <primitive-type> <long-long-type>
<long-long-type>
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
8 >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
"longlong" define-primitive-type
[ alien-unsigned-8 ]
[ set-alien-unsigned-8 ]
8
"box_unsigned_8"
"to_unsigned_8" <primitive-type> <long-long-type>
<long-long-type>
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
8 >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
"ulonglong" define-primitive-type
[ alien-signed-cell ]
[ set-alien-signed-cell ]
bootstrap-cell
"box_signed_cell"
"to_fixnum" <primitive-type>
<c-type>
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
"long" define-primitive-type
[ alien-unsigned-cell ]
[ set-alien-unsigned-cell ]
bootstrap-cell
"box_unsigned_cell"
"to_cell" <primitive-type>
<c-type>
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
"ulong" define-primitive-type
[ alien-signed-4 ]
[ set-alien-signed-4 ]
4
"box_signed_4"
"to_fixnum" <primitive-type>
<c-type>
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
4 >>align
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
"int" define-primitive-type
[ alien-unsigned-4 ]
[ set-alien-unsigned-4 ]
4
"box_unsigned_4"
"to_cell" <primitive-type>
<c-type>
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
"uint" define-primitive-type
[ alien-signed-2 ]
[ set-alien-signed-2 ]
2
"box_signed_2"
"to_fixnum" <primitive-type>
<c-type>
[ alien-signed-2 ] >>getter
[ set-alien-signed-2 ] >>setter
2 >>size
2 >>align
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
"short" define-primitive-type
[ alien-unsigned-2 ]
[ set-alien-unsigned-2 ]
2
"box_unsigned_2"
"to_cell" <primitive-type>
<c-type>
[ alien-unsigned-2 ] >>getter
[ set-alien-unsigned-2 ] >>setter
2 >>size
2 >>align
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
"ushort" define-primitive-type
[ alien-signed-1 ]
[ set-alien-signed-1 ]
1
"box_signed_1"
"to_fixnum" <primitive-type>
<c-type>
[ alien-signed-1 ] >>getter
[ set-alien-signed-1 ] >>setter
1 >>size
1 >>align
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
"char" define-primitive-type
[ alien-unsigned-1 ]
[ set-alien-unsigned-1 ]
1
"box_unsigned_1"
"to_cell" <primitive-type>
<c-type>
[ alien-unsigned-1 ] >>getter
[ set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_unsigned_1" >>boxer
"to_cell" >>unboxer
"uchar" define-primitive-type
[ alien-unsigned-4 zero? not ]
[ 1 0 ? set-alien-unsigned-4 ]
4
"box_boolean"
"to_boolean" <primitive-type>
<c-type>
[ alien-unsigned-4 zero? not ] >>getter
[ 1 0 ? set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" define-primitive-type
[ alien-float ]
[ >r >r >float r> r> set-alien-float ]
4
"box_float"
"to_float" <primitive-type>
<c-type>
[ alien-float ] >>getter
[ >r >r >float r> r> set-alien-float ] >>setter
4 >>size
4 >>align
"box_float" >>boxer
"to_float" >>unboxer
single-float-regs >>reg-class
[ >float ] >>prep
"float" define-primitive-type
T{ float-regs f 4 } "float" c-type set-c-type-reg-class
[ >float ] "float" c-type set-c-type-prep
[ alien-double ]
[ >r >r >float r> r> set-alien-double ]
8
"box_double"
"to_double" <primitive-type>
<c-type>
[ alien-double ] >>getter
[ >r >r >float r> r> set-alien-double ] >>setter
8 >>size
8 >>align
"box_double" >>boxer
"to_double" >>unboxer
double-float-regs >>reg-class
[ >float ] >>prep
"double" define-primitive-type
T{ float-regs f 8 } "double" c-type set-c-type-reg-class
[ >float ] "double" c-type set-c-type-prep
[ alien-cell alien>char-string ]
[ set-alien-cell ]
bootstrap-cell
"box_char_string"
"alien_offset" <primitive-type>
<c-type>
[ alien-cell alien>char-string ] >>getter
[ set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
"box_char_string" >>boxer
"alien_offset" >>unboxer
[ string>char-alien ] >>prep
"char*" define-primitive-type
"char*" "uchar*" typedef
[ string>char-alien ] "char*" c-type set-c-type-prep
[ alien-cell alien>u16-string ]
[ set-alien-cell ]
4
"box_u16_string"
"alien_offset" <primitive-type>
<c-type>
[ alien-cell alien>u16-string ] >>getter
[ set-alien-cell ] >>setter
4 >>size
4 >>align
"box_u16_string" >>boxer
"alien_offset" >>unboxer
[ string>u16-alien ] >>prep
"ushort*" define-primitive-type
[ string>u16-alien ] "ushort*" c-type set-c-type-prep
win64? "longlong" "long" ? "ptrdiff_t" typedef
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
] with-compilation-unit

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

@ -9,6 +9,14 @@ kernel.private threads continuations.private libc combinators
compiler.errors continuations layouts accessors ;
IN: alien.compiler
TUPLE: #alien-node < node return parameters abi ;
TUPLE: #alien-callback < #alien-node quot xt ;
TUPLE: #alien-indirect < #alien-node ;
TUPLE: #alien-invoke < #alien-node library function ;
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
@ -62,29 +70,36 @@ GENERIC: reg-size ( register-class -- n )
M: int-regs reg-size drop cell ;
M: float-regs reg-size float-regs-size ;
M: single-float-regs reg-size drop 4 ;
M: double-float-regs reg-size drop 8 ;
GENERIC: reg-class-variable ( register-class -- symbol )
M: reg-class reg-class-variable ;
M: float-regs reg-class-variable drop float-regs ;
GENERIC: inc-reg-class ( register-class -- )
: (inc-reg-class)
dup class inc
M: reg-class inc-reg-class
dup reg-class-variable inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
M: int-regs inc-reg-class
(inc-reg-class) ;
M: float-regs inc-reg-class
dup (inc-reg-class)
dup call-next-method
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
: reg-class-full? ( class -- ? )
dup class get swap param-regs length >= ;
[ reg-class-variable get ] [ param-regs length ] bi >= ;
: spill-param ( reg-class -- n reg-class )
reg-size stack-params dup get -rot +@ T{ stack-params } ;
stack-params get
>r reg-size stack-params +@ r>
stack-params ;
: fastcall-param ( reg-class -- n reg-class )
[ dup class get swap inc-reg-class ] keep ;
[ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
: alloc-parameter ( parameter -- reg reg-class )
c-type-reg-class dup reg-class-full?
@ -229,32 +244,32 @@ M: no-such-symbol compiler-error-type
] if ;
: alien-invoke-dlsym ( node -- symbols dll )
dup alien-invoke-function dup pick stdcall-mangle 2array
swap alien-invoke-library library dup [ library-dll ] when
dup function>> dup pick stdcall-mangle 2array
swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
\ alien-invoke [
! Four literals
4 ensure-values
\ alien-invoke empty-node
#alien-invoke construct-empty
! Compile-time parameters
pop-parameters over set-alien-invoke-parameters
pop-literal nip over set-alien-invoke-function
pop-literal nip over set-alien-invoke-library
pop-literal nip over set-alien-invoke-return
pop-parameters >>parameters
pop-literal nip >>function
pop-literal nip >>library
pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
! Set ABI
dup alien-invoke-library
library [ library-abi ] [ "cdecl" ] if*
over set-alien-invoke-abi
dup library>>
library [ abi>> ] [ "cdecl" ] if*
>>abi
! Add node to IR
dup node,
! Magic #: consume exactly the number of inputs
0 alien-invoke-stack
] "infer" set-word-prop
M: alien-invoke generate-node
M: #alien-invoke generate-node
dup alien-invoke-frame [
end-basic-block
%prepare-alien-invoke
@ -273,11 +288,11 @@ M: alien-indirect-error summary
! Three literals and function pointer
4 ensure-values
4 reify-curries
\ alien-indirect empty-node
#alien-indirect construct-empty
! Compile-time parameters
pop-literal nip over set-alien-indirect-abi
pop-parameters over set-alien-indirect-parameters
pop-literal nip over set-alien-indirect-return
pop-literal nip >>abi
pop-parameters >>parameters
pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot [ dip ] curry recursive-state get infer-quot
! Add node to IR
@ -286,7 +301,7 @@ M: alien-indirect-error summary
1 alien-invoke-stack
] "infer" set-word-prop
M: alien-indirect generate-node
M: #alien-indirect generate-node
dup alien-invoke-frame [
! Flush registers
end-basic-block
@ -315,17 +330,17 @@ M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- )
alien-callback-xt [ word-xt drop <alien> ] curry
xt>> [ word-xt drop <alien> ] curry
recursive-state get infer-quot ;
\ alien-callback [
4 ensure-values
\ alien-callback empty-node dup node,
pop-literal nip over set-alien-callback-quot
pop-literal nip over set-alien-callback-abi
pop-parameters over set-alien-callback-parameters
pop-literal nip over set-alien-callback-return
gensym dup register-callback over set-alien-callback-xt
#alien-callback construct-empty dup node,
pop-literal nip >>quot
pop-literal nip >>abi
pop-parameters >>parameters
pop-literal nip >>return
gensym dup register-callback >>xt
callback-bottom
] "infer" set-word-prop
@ -365,8 +380,7 @@ TUPLE: callback-context ;
: wrap-callback-quot ( node -- quot )
[
dup alien-callback-quot
swap prepare-callback-return append ,
[ quot>> ] [ prepare-callback-return ] bi append ,
[ callback-context construct-empty do-callback ] %
] [ ] make ;
@ -387,7 +401,7 @@ TUPLE: callback-context ;
callback-unwind %unwind ;
: generate-callback ( node -- )
dup alien-callback-xt dup [
dup xt>> dup [
init-templates
%save-word-xt
%prologue-later
@ -398,5 +412,5 @@ TUPLE: callback-context ;
] with-stack-frame
] with-generator ;
M: alien-callback generate-node
M: #alien-callback generate-node
end-basic-block generate-callback iterate-next ;

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

@ -16,6 +16,22 @@ $nl
"To make an assoc into an alist:"
{ $subsection >alist } ;
ARTICLE: "enums" "Enumerations"
"An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:"
{ $subsection enum }
{ $subsection <enum> }
"Inverting a permutation using enumerations:"
{ $example "USING: assocs sorting prettyprint ;" ": invert <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
HELP: enum
{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
$nl
"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
HELP: <enum>
{ $values { "seq" sequence } { "enum" enum } }
{ $description "Creates a new enumeration." } ;
ARTICLE: "assocs-protocol" "Associative mapping protocol"
"All associative mappings must be instances of a mixin class:"
{ $subsection assoc }

26
core/assocs/assocs.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! Copyright (C) 2007, 2008 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays math sequences.private vectors ;
USING: kernel sequences arrays math sequences.private vectors
accessors ;
IN: assocs
MIXIN: assoc
@ -189,3 +190,24 @@ M: f clear-assoc drop ;
M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
INSTANCE: sequence assoc
TUPLE: enum seq ;
C: <enum> enum
M: enum at*
seq>> 2dup bounds-check?
[ nth t ] [ 2drop f f ] if ;
M: enum set-at seq>> set-nth ;
M: enum delete-at enum-seq delete-nth ;
M: enum >alist ( enum -- alist )
seq>> [ length ] keep 2array flip ;
M: enum assoc-size seq>> length ;
M: enum clear-assoc seq>> delete-all ;
INSTANCE: enum assoc

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

@ -14,13 +14,7 @@ IN: bootstrap.compiler
"alien.remote-control" require
] unless
"cpu." cpu append require
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
"cpu." cpu word-name append require
enable-compiler
@ -43,8 +37,6 @@ nl
wrap probe
delegate
underlying
find-pair-next namestack*

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

@ -4,15 +4,16 @@ USING: alien arrays bit-arrays byte-arrays generic assocs
hashtables assocs hashtables.private io kernel kernel.private
math namespaces parser prettyprint sequences sequences.private
strings sbufs vectors words quotations assocs system layouts
splitting growable classes classes.tuple classes.tuple.private
words.private io.binary io.files vocabs vocabs.loader
source-files definitions debugger float-arrays
splitting growable classes classes.builtin classes.tuple
classes.tuple.private words.private io.binary io.files vocabs
vocabs.loader source-files definitions debugger float-arrays
quotations.private sequences.private combinators
io.encodings.binary ;
IN: bootstrap.image
: my-arch ( -- arch )
cpu dup "ppc" = [ >r os "-" r> 3append ] when ;
cpu word-name
dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;

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

@ -2,7 +2,8 @@
! 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 ;
float-arrays quotations assocs layouts classes.tuple.private
kernel.private ;
BIN: 111 tag-mask set
8 num-tags set
@ -15,6 +16,7 @@ H{
{ bignum BIN: 001 }
{ tuple BIN: 010 }
{ object BIN: 011 }
{ hi-tag BIN: 011 }
{ ratio BIN: 100 }
{ float BIN: 101 }
{ complex BIN: 110 }

144
core/bootstrap/primitives.factor
View File

@ -3,10 +3,10 @@
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes
classes.tuple classes.tuple.private kernel.private vocabs
vocabs.loader source-files definitions slots.deprecated
classes.union compiler.units bootstrap.image.private io.files
accessors combinators ;
classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
slots.deprecated classes.union compiler.units
bootstrap.image.private io.files accessors combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@ -31,6 +31,7 @@ crossref off
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
H{ } clone changed-words set
H{ } clone forgotten-definitions set
H{ } clone root-cache set
H{ } clone source-files set
H{ } clone update-map set
@ -101,17 +102,24 @@ num-types get f <array> builtins set
} [ create-vocab drop ] each
! Builtin classes
: builtin-predicate-quot ( class -- quot )
: lo-tag-eq-quot ( n -- quot )
[ \ tag , , \ eq? , ] [ ] make ;
: hi-tag-eq-quot ( n -- quot )
[
"type" word-prop
[ tag-mask get < \ tag \ type ? , ] [ , ] bi
\ eq? ,
[ 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 ]
[ predicate-word make-inline ]
bi ;
dup builtin-predicate-quot define-predicate ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
@ -119,27 +127,56 @@ num-types get f <array> builtins set
: register-builtin ( class -- )
[ dup lookup-type-number "type" set-word-prop ]
[ dup "type" word-prop builtins get set-nth ]
bi ;
[ f f builtin-class define-class ]
tri ;
: define-builtin-slots ( symbol slotspec -- )
[ drop ] [ 1 simple-slots ] 2bi
[ "slots" set-word-prop ] [ define-slots ] 2bi ;
: define-builtin ( symbol slotspec -- )
>r
{
[ register-builtin ]
[ f f builtin-class define-class ]
[ define-builtin-predicate ]
[ ]
} cleave
>r [ define-builtin-predicate ] keep
r> define-builtin-slots ;
! Forward definitions
"object" "kernel" create t "class" set-word-prop
"object" "kernel" create union-class "metaclass" set-word-prop
"fixnum" "math" create register-builtin
"bignum" "math" create register-builtin
"tuple" "kernel" create register-builtin
"ratio" "math" create register-builtin
"float" "math" create register-builtin
"complex" "math" create register-builtin
"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
"word" "words" create register-builtin
"byte-array" "byte-arrays" create register-builtin
"tuple-layout" "classes.tuple.private" create register-builtin
"null" "kernel" create drop
! Catch-all class for providing a default method.
"object" "kernel" create
[ f builtins get [ ] subset union-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]
bi
"object?" "kernel" vocab-words delete-at
! Class of objects with object tag
"hi-tag" "kernel.private" create
builtins get num-tags get tail define-union-class
! Empty class with no instances
"null" "kernel" create
[ f { } union-class define-class ]
[ [ drop f ] "predicate" set-word-prop ]
bi
"null?" "kernel" vocab-words delete-at
"fixnum" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@ -328,47 +365,28 @@ define-builtin
}
} define-builtin
"tuple" "kernel" create { } define-builtin
"tuple" "kernel" lookup
{
{
{ "object" "kernel" }
"delegate"
{ "delegate" "kernel" }
{ "set-delegate" "kernel" }
}
}
[ drop ] [ generate-tuple-slots ] 2bi
[ [ name>> ] map "slot-names" set-word-prop ]
[ "slots" set-word-prop ]
[ define-slots ] 2tri
"tuple" "kernel" lookup define-tuple-layout
! Define general-t type, which is any object that is not f.
"general-t" "kernel" create
f "f" "syntax" lookup builtins get remove [ ] subset union-class
define-class
"tuple" "kernel" create {
[ { } define-builtin ]
[ { "delegate" } "slot-names" set-word-prop ]
[ define-tuple-layout ]
[
{
{
{ "object" "kernel" }
"delegate"
{ "delegate" "kernel" }
{ "set-delegate" "kernel" }
}
}
[ drop ] [ generate-tuple-slots ] 2bi
[ "slots" set-word-prop ]
[ define-slots ]
2bi
]
} cleave
"f" "syntax" create [ not ] "predicate" set-word-prop
"f?" "syntax" create "syntax" vocab-words delete-at
"general-t" "kernel" create [ ] "predicate" set-word-prop
"general-t?" "kernel" create "syntax" vocab-words delete-at
! Catch-all class for providing a default method.
"object" "kernel" create [ drop t ] "predicate" set-word-prop
"object" "kernel" create
f builtins get [ ] subset union-class define-class
! Class of objects with object tag
"hi-tag" "classes.private" create
f builtins get num-tags get tail union-class define-class
! Null class with no instances.
"null" "kernel" create [ drop f ] "predicate" set-word-prop
"null" "kernel" create f { } union-class define-class
"f?" "syntax" vocab-words delete-at
! Create special tombstone values
"tombstone" "hashtables.private" create
@ -638,7 +656,6 @@ f builtins get num-tags get tail union-class define-class
{ "code-room" "memory" }
{ "os-env" "system" }
{ "millis" "system" }
{ "type" "kernel.private" }
{ "tag" "kernel.private" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
@ -710,7 +727,6 @@ f builtins get num-tags get tail union-class define-class
{ "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" }
{ "<tuple-boa>" "classes.tuple.private" }
{ "class-hash" "kernel.private" }
{ "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "kernel.private" }

1
core/bootstrap/stage1.factor
View File

@ -19,7 +19,6 @@ vocabs.loader system debugger continuations ;
! Rehash hashtables, since bootstrap.image creates them
! using the host image's hashing algorithms
[ hashtable? ] instances [ rehash ] each
boot
] %

6
core/bootstrap/stage2.factor
View File

@ -11,7 +11,7 @@ IN: bootstrap.stage2
SYMBOL: bootstrap-time
: default-image-name ( -- string )
vm file-name windows? [ "." split1 drop ] when
vm file-name os windows? [ "." split1 drop ] when
".image" append resource-path ;
: do-crossref ( -- )
@ -65,8 +65,8 @@ parse-command-line
"-no-crossref" cli-args member? [ do-crossref ] unless
! Set dll paths
wince? [ "windows.ce" require ] when
winnt? [ "windows.nt" require ] when
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when
"deploy-vocab" get [
"stage2: deployment mode" print

2
core/bootstrap/syntax.factor
View File

@ -43,6 +43,7 @@ IN: bootstrap.syntax
"PRIMITIVE:"
"PRIVATE>"
"SBUF\""
"SINGLETON:"
"SYMBOL:"
"TUPLE:"
"T{"
@ -66,6 +67,7 @@ IN: bootstrap.syntax
"CS{"
"<<"
">>"
"call-next-method"
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol

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

@ -4,7 +4,7 @@ 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 ;
random inference effects kernel.private ;
: class= [ class< ] 2keep swap class< and ;
@ -23,8 +23,8 @@ random inference effects ;
[ t ] [ number object number class-and* ] unit-test
[ t ] [ object number number class-and* ] unit-test
[ t ] [ slice reversed null class-and* ] unit-test
[ t ] [ general-t \ f null class-and* ] unit-test
[ t ] [ general-t \ f object class-or* ] unit-test
[ t ] [ \ f class-not \ f null class-and* ] unit-test
[ t ] [ \ f class-not \ f object class-or* ] unit-test
TUPLE: first-one ;
TUPLE: second-one ;
@ -68,13 +68,13 @@ UNION: c a b ;
[ t ] [ \ tuple-class \ class class< ] unit-test
[ f ] [ \ class \ tuple-class class< ] unit-test
TUPLE: delegate-clone ;
TUPLE: tuple-example ;
[ t ] [ \ null \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ f ] [ \ object \ delegate-clone class< ] unit-test
[ t ] [ \ delegate-clone \ tuple class< ] unit-test
[ f ] [ \ tuple \ delegate-clone class< ] unit-test
[ t ] [ \ null \ tuple-example class< ] unit-test
[ f ] [ \ object \ tuple-example class< ] unit-test
[ f ] [ \ object \ tuple-example class< ] unit-test
[ t ] [ \ tuple-example \ tuple class< ] unit-test
[ f ] [ \ tuple \ tuple-example class< ] unit-test
TUPLE: a1 ;
TUPLE: b1 ;
@ -96,7 +96,7 @@ UNION: z1 b1 c1 ;
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
[ f ] [ growable hi-tag classes-intersect? ] unit-test
[ f ] [ growable \ hi-tag classes-intersect? ] unit-test
[ t ] [
growable tuple sequence class-and class<

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

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
;
USING: kernel classes classes.builtin combinators accessors
sequences arrays vectors assocs namespaces words sorting layouts
math hashtables kernel.private ;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )
@ -103,7 +103,7 @@ C: <anonymous-complement> anonymous-complement
{
{ [ over tuple eq? ] [ 2drop t ] }
{ [ over builtin-class? ] [ 2drop f ] }
{ [ over tuple-class? ] [ [ class< ] 2keep swap class< or ] }
{ [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }
{ [ t ] [ swap classes-intersect? ] }
} cond ;
@ -211,12 +211,6 @@ C: <anonymous-complement> anonymous-complement
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
: class-hashes ( class -- seq )
flatten-class keys [
dup builtin-class?
[ "type" word-prop ] [ hashcode ] if
] map ;
: flatten-builtin-class ( class -- assoc )
flatten-class [
dup tuple class< [ 2drop tuple tuple ] when
@ -229,5 +223,5 @@ C: <anonymous-complement> anonymous-complement
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
[ drop object tag-number ] when
[ drop \ hi-tag tag-number ] when
] map prune ;

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

@ -0,0 +1,28 @@
USING: help.syntax help.markup classes layouts ;
IN: classes.builtin
ARTICLE: "builtin-classes" "Built-in classes"
"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
$nl
"The set of built-in classes is a class:"
{ $subsection builtin-class }
{ $subsection builtin-class? }
"See " { $link "type-index" } " for a list of built-in classes." ;
HELP: builtin-class
{ $class-description "The class of built-in classes." }
{ $examples
"The class of arrays is a built-in class:"
{ $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" }
"However, an instance of the array class is not a built-in class; it is not even a class:"
{ $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
} ;
HELP: builtins
{ $var-description "Vector mapping type numbers to builtin class words." } ;
HELP: type>class
{ $values { "n" "a non-negative integer" } { "class" class } }
{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;

18
core/classes/builtin/builtin.factor Normal file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes words kernel kernel.private namespaces
sequences ;
IN: classes.builtin
SYMBOL: builtins
PREDICATE: builtin-class < class
"metaclass" word-prop builtin-class eq? ;
: type>class ( n -- class ) builtins get-global nth ;
: bootstrap-type>class ( n -- class ) builtins get nth ;
M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;

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

@ -4,14 +4,6 @@ layouts classes.private classes.union classes.mixin
classes.predicate quotations ;
IN: classes
ARTICLE: "builtin-classes" "Built-in classes"
"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
$nl
"The set of built-in classes is a class:"
{ $subsection builtin-class }
{ $subsection builtin-class? }
"See " { $link "type-index" } " for a list of built-in classes." ;
ARTICLE: "class-predicates" "Class predicate words"
"With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property."
$nl
@ -21,7 +13,6 @@ $nl
{ { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } }
{ { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } }
{ { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } }
{ { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } }
}
"The set of class predicate words is a class:"
{ $subsection predicate }
@ -39,16 +30,21 @@ $nl
{ $subsection class? }
"You can ask an object for its class:"
{ $subsection class }
"Testing if an object is an instance of a class:"
{ $subsection instance? }
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
{ $subsection object }
{ $subsection null }
"Obtaining a list of all defined classes:"
{ $subsection classes }
"Other sorts of classes:"
"There are several sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
{ $subsection "mixins" }
{ $subsection "predicates" }
{ $subsection "singletons" }
{ $link "tuples" } " are documented in their own section."
$nl
"Classes can be inspected and operated upon:"
{ $subsection "class-operations" }
{ $see-also "class-index" } ;
@ -58,37 +54,20 @@ ABOUT: "classes"
HELP: class
{ $values { "object" object } { "class" class } }
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
{ $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." }
{ $class-description "The class of all class words." }
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
HELP: builtin-class
{ $class-description "The class of built-in classes." }
{ $examples
"The class of arrays is a built-in class:"
{ $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" }
"However, an instance of the array class is not a built-in class; it is not even a class:"
{ $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
} ;
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: builtins
{ $var-description "Vector mapping type numbers to builtin class words." } ;
HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
HELP: type>class
{ $values { "n" "a non-negative integer" } { "class" class } }
{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;

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

@ -3,7 +3,7 @@ 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 ;
compiler.units kernel.private ;
IN: classes.tests
! DEFER: bah
@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
! 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
[ t ] [ 3 number instance? ] unit-test
[ f ] [ 3 null instance? ] unit-test
[ t ] [ "hi" \ hi-tag instance? ] unit-test

60
core/classes/classes.factor
View File

@ -25,23 +25,16 @@ SYMBOL: class-or-cache
class-and-cache get clear-assoc
class-or-cache get clear-assoc ;
PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
SYMBOL: update-map
SYMBOL: builtins
PREDICATE: builtin-class < class
"metaclass" word-prop builtin-class eq? ;
PREDICATE: class < word
"class" word-prop ;
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] subset ;
: type>class ( n -- class ) builtins get-global nth ;
: bootstrap-type>class ( n -- class ) builtins get nth ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
@ -58,7 +51,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
dup class? [ "superclass" word-prop ] [ drop f ] if ;
: superclasses ( class -- supers )
[ dup ] [ dup superclass swap ] [ ] unfold reverse nip ;
[ superclass ] follow reverse ;
: members ( class -- seq )
#! Output f for non-classes to work with algebra code
@ -72,7 +65,7 @@ M: word reset-class drop ;
! update-map
: class-uses ( class -- seq )
dup members swap superclass [ suffix ] when* ;
[ members ] [ superclass ] bi [ suffix ] when* ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
@ -83,7 +76,7 @@ M: word reset-class drop ;
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
: define-class-props ( superclass members metaclass -- assoc )
: make-class-props ( superclass members metaclass -- assoc )
[
[ dup [ bootstrap-word ] when "superclass" set ]
[ [ bootstrap-word ] map "members" set ]
@ -92,12 +85,16 @@ M: word reset-class drop ;
] H{ } make-assoc ;
: (define-class) ( word props -- )
over reset-class
over deferred? [ over define-symbol ] when
>r dup word-props r> union over set-word-props
dup predicate-word 2dup 1quotation "predicate" set-word-prop
over "predicating" set-word-prop
t "class" set-word-prop ;
>r
dup reset-class
dup deferred? [ dup define-symbol ] when
dup word-props
r> union over set-word-props
dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
[ drop t "class" set-word-prop ]
2tri ;
PRIVATE>
@ -105,25 +102,24 @@ GENERIC: update-class ( class -- )
M: class update-class drop ;
: update-classes ( assoc -- )
[ drop update-class ] assoc-each ;
GENERIC: update-methods ( assoc -- )
: update-classes ( class -- )
class-usages
[ [ drop update-class ] assoc-each ]
[ update-methods ]
bi ;
: define-class ( word superclass members metaclass -- )
#! If it was already a class, update methods after.
reset-caches
define-class-props
make-class-props
[ drop update-map- ]
[ (define-class) ] [
drop
[ update-map+ ] [
class-usages
[ update-classes ]
[ update-methods ] bi
] bi
] 2tri ;
[ (define-class) ]
[ drop update-map+ ]
2tri ;
GENERIC: class ( object -- class ) inline
GENERIC: class ( object -- class )
M: object class type type>class ;
: instance? ( obj class -- ? )
"predicate" word-prop call ;

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

@ -1,16 +1,18 @@
USING: help.markup help.syntax help words compiler.units
classes ;
classes sequences ;
IN: classes.mixin
ARTICLE: "mixins" "Mixin classes"
"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, new classes can be made into instances of a mixin class after the original definition of the mixin."
"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, mixin classes have the additional property that they are " { $emphasis "open" } "; new classes can be added to the mixin after the original definition of the mixin."
{ $subsection POSTPONE: MIXIN: }
{ $subsection POSTPONE: INSTANCE: }
{ $subsection define-mixin-class }
{ $subsection add-mixin-instance }
"The set of mixin classes is a class:"
{ $subsection mixin-class }
{ $subsection mixin-class? } ;
{ $subsection mixin-class? }
"Mixins are used to defines suites of behavior which are generally useful and can be applied to user-defined classes. For example, the " { $link immutable-sequence } " mixin can be used with user-defined sequences to make them immutable."
{ $see-also "unions" "tuple-subclassing" } ;
HELP: mixin-class
{ $class-description "The class of mixin classes." } ;

2
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
{ "metaclass" "members" "mixin" } reset-props ;
{ "class" "metaclass" "members" "mixin" } reset-props ;
: redefine-mixin-class ( class members -- )
dupd define-union-class

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

@ -14,11 +14,19 @@ PREDICATE: predicate-class < class
] [ ] make ;
: define-predicate-class ( class superclass definition -- )
>r dupd f predicate-class define-class
r> dupd "predicate-definition" set-word-prop
dup predicate-quot define-predicate ;
[ drop f predicate-class define-class ]
[ nip "predicate-definition" set-word-prop ]
[
2drop
[ dup predicate-quot define-predicate ]
[ update-classes ]
bi
] 3tri ;
M: predicate-class reset-class
{
"metaclass" "predicate-definition" "superclass"
"class"
"metaclass"
"predicate-definition"
"superclass"
} reset-props ;

0
extra/classes/singleton/authors.txt → core/classes/singleton/authors.txt
View File

34
core/classes/singleton/singleton-docs.factor Normal file
View File

@ -0,0 +1,34 @@
USING: help.markup help.syntax kernel words ;
IN: classes.singleton
ARTICLE: "singletons" "Singleton classes"
"A singleton is a class with only one instance and with no state."
{ $subsection POSTPONE: SINGLETON: }
{ $subsection define-singleton-class }
"The set of all singleton classes is itself a class:"
{ $subsection singleton-class? }
{ $subsection singleton-class } ;
HELP: SINGLETON:
{ $syntax "SINGLETON: class" }
{ $values
{ "class" "a new singleton to define" }
}
{ $description
"Defines a new singleton class. The class word itself is the sole instance of the singleton class."
}
{ $examples
{ $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
} ;
HELP: define-singleton-class
{ $values { "word" "a new word" } }
{ $description
"Defines a singleton class. This is the run-time equivalent of " { $link POSTPONE: SINGLETON: } "." } ;
{ POSTPONE: SINGLETON: define-singleton-class } related-words
HELP: singleton-class
{ $class-description "The class of singleton classes." } ;
ABOUT: "singletons"

6
extra/classes/singleton/singleton-tests.factor → core/classes/singleton/singleton-tests.factor
View File

@ -4,9 +4,9 @@ IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
[ t ] [ bzzt bzzt? ] unit-test
[ t ] [ bzzt bzzt eq? ] unit-test
GENERIC: zammo ( obj -- )
GENERIC: zammo ( obj -- str )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton? ] unit-test
[ "USING: singleton ;\nIN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
[ t ] [ omg singleton-class? ] unit-test
[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test

11
core/classes/singleton/singleton.factor Executable file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.predicate kernel sequences words ;
IN: classes.singleton
PREDICATE: singleton-class < predicate-class
[ "predicate-definition" word-prop ]
[ [ eq? ] curry ] bi sequence= ;
: define-singleton-class ( word -- )
\ word over [ eq? ] curry define-predicate-class ;

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

@ -3,14 +3,63 @@ classes.tuple.private classes slots quotations words arrays
generic.standard sequences definitions compiler.units ;
IN: classes.tuple
ARTICLE: "tuple-constructors" "Constructors"
"Tuples are created by calling one of two words:"
ARTICLE: "parametrized-constructors" "Parameterized constructors"
"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link construct-empty } " or " { $link construct-boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
$nl
"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:"
{ $code
"TUPLE: vehicle max-speed occupants ;"
""
": add-occupant ( person vehicle -- ) occupants>> push ;"
""
"TUPLE: car < vehicle engine ;"
": <car> ( max-speed engine -- car )"
" car construct-empty"
" V{ } clone >>occupants"
" swap >>engine"
" swap >>max-speed ;"
""
"TUPLE: aeroplane < vehicle max-altitude ;"
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
" aeroplane construct-empty"
" V{ } clone >>occupants"
" swap >>max-altitude"
" swap >>max-speed ;"
}
"The two constructors depend on the implementation of " { $snippet "vehicle" } " because they are responsible for initializing the " { $snippet "occupants" } " slot to an empty vector. If this slot is changed to contain a hashtable instead, there will be two places instead of one. A better approach is to use a parametrized constructor for vehicles:"
{ $code
"TUPLE: vehicle max-speed occupants ;"
""
": add-occupant ( person vehicle -- ) occupants>> push ;"
""
": construct-vehicle ( class -- vehicle )"
" construct-empty"
" V{ } clone >>occupants ;"
""
"TUPLE: car < vehicle engine ;"
": <car> ( max-speed engine -- car )"
" car construct-vehicle"
" swap >>engine"
" swap >>max-speed ;"
""
"TUPLE: aeroplane < vehicle max-altitude ;"
": <aeroplane> ( max-speed max-altitude -- aeroplane )"
" aeroplane construct-vehicle"
" swap >>max-altitude"
" swap >>max-speed ;"
}
"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ;
ARTICLE: "tuple-constructors" "Tuple constructors"
"Tuples are created by calling one of two constructor primitives:"
{ $subsection construct-empty }
{ $subsection construct-boa }
"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
$nl
"A shortcut for defining BOA constructors:"
{ $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
"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 ;"
@ -22,29 +71,77 @@ $nl
""
": <color> construct-empty ;"
": <color> f f f f <rgba> ; ! identical to above"
}
{ $subsection "parametrized-constructors" } ;
ARTICLE: "tuple-inheritance-example" "Tuple subclassing example"
"Rectangles, parallelograms and circles are all shapes. We support two operations on shapes:"
{ $list
"Computing the area"
"Computing the perimiter"
}
"Rectangles and parallelograms use the same algorithm for computing the area, whereas they use different algorithms for computing perimiter. Also, rectangles and parallelograms both have " { $snippet "width" } " and " { $snippet "height" } " slots. We can exploit this with subclassing:"
{ $code
"GENERIC: area ( shape -- n )"
"GENERIC: perimiter ( shape -- n )"
""
"TUPLE: shape ;"
""
"TUPLE: circle < shape radius ;"
"M: area circle radius>> sq pi * ;"
"M: perimiter circle radius>> 2 * pi * ;"
""
"TUPLE: quad < shape width height"
"M: area quad [ width>> ] [ height>> ] bi * ;"
""
"TUPLE: rectangle < quad ;"
"M: rectangle perimiter [ width>> 2 * ] [ height>> 2 * ] bi + ;"
""
": hypot ( a b -- c ) [ sq ] bi@ + sqrt ;"
""
"TUPLE: parallelogram < quad skew ;"
"M: parallelogram perimiter"
" [ width>> 2 * ] [ [ height>> ] [ skew>> ] bi hypot 2 * ] bi + ;"
} ;
ARTICLE: "tuple-delegation" "Tuple delegation"
"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown."
{ $subsection delegate }
{ $subsection set-delegate }
"A tuple's delegate should either be another tuple, or " { $link f } ", indicating no delegate is set. Delegation from a tuple to an object of some other type is not fully supported and should be used with caution."
ARTICLE: "tuple-inheritance-anti-example" "When not to use tuple subclassing"
"Tuple subclassing should only be used for " { $emphasis "is-a" } " relationships; for example, a car " { $emphasis "is a" } " vehicle, and a circle " { $emphasis "is a" } " shape."
{ $heading "Anti-pattern #1: subclassing for has-a" }
"Subclassing should not be used for " { $emphasis "has-a" } " relationships. For example, if a shape " { $emphasis "has a" } " color, then " { $snippet "shape" } " should not subclass " { $snippet "color" } ". Using tuple subclassing in inappropriate situations leads to code which is more brittle and less flexible than it should be."
$nl
"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object."
"For example, suppose that " { $snippet "shape" } " inherits from " { $snippet "color" } ":"
{ $code
"TUPLE: color r g b ;"
"TUPLE: shape < color ... ;"
}
"Now, the implementation of " { $snippet "shape" } " depends on a specific representation of colors as RGB colors. If a new generic color protocol is devised which also allows HSB and YUV colors to be used, the shape class will not be able to take advantage of them without changes. A better approach is to store the color in a slot:"
{ $code
"TUPLE: rgb-color r g b ;"
"TUPLE: hsv-color h s v ;"
"..."
"TUPLE: shape color ... ;"
}
"The " { $vocab-link "delegate" } " library provides a language abstraction for expressing has-a relationships."
{ $heading "Anti-pattern #2: subclassing for implementation sharing only" }
"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this properly does not hold, then subclassing should not be used."
$nl
"A pair of words examine delegation chains:"
{ $subsection delegates }
{ $subsection is? }
"An example:"
{ $example
"TUPLE: ellipse center radius ;"
"TUPLE: colored color ;"
"{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
"{ 1 0 0 } <colored> \"my-shape\" set"
"\"my-ellipse\" get \"my-shape\" get set-delegate"
"\"my-shape\" get dup color>> swap center>> .s"
"{ 0 0 }\n{ 1 0 0 }"
} ;
"There are two alternatives which are preferred to subclassing in this case. The first is " { $link "mixins" } "."
$nl
"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
{ $heading "Anti-pattern #3: subclassing to override a method definition" }
"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link construct-empty } ", " { $link construct-boa } ", or a custom parametrized constructor."
{ $see-also "parametrized-constructors" } ;
ARTICLE: "tuple-subclassing" "Tuple subclassing"
"Tuple subclassing can be used to express natural relationships between classes at the language level. For example, every car " { $emphasis "is a" } " vehicle, so if the " { $snippet "car" } " class subclasses the " { $snippet "vehicle" } " class, it can " { $emphasis "inherit" } " the slots and methods of " { $snippet "vehicle" } "."
$nl
"To define one tuple class as a subclass of another, use the optional superclass parameter to " { $link POSTPONE: TUPLE: } ":"
{ $code
"TUPLE: subclass < superclass ... ;"
}
{ $subsection "tuple-inheritance-example" }
{ $subsection "tuple-inheritance-anti-example" }
{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ;
ARTICLE: "tuple-introspection" "Tuple introspection"
"In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way."
@ -119,7 +216,28 @@ ARTICLE: "tuple-examples" "Tuple examples"
": promote ( person -- person )"
" [ 1.2 * ] change-salary"
" [ next-position ] change-position ;"
} ;
}
"An example using subclassing can be found in " { $link "tuple-inheritance-example" } "." ;
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 } "."
$nl
"There are three ways to change the list of effective slots of a class:"
{ $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"
}
"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 are permuted, their values in instances do not change; only the layout of the instance changes in memory."
"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: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots."
@ -132,35 +250,21 @@ $nl
{ $subsection "accessors" }
"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
{ $subsection "tuple-constructors" }
"Further topics:"
{ $subsection "tuple-delegation" }
"Expressing relationships through the object system:"
{ $subsection "tuple-subclassing" }
"Introspection:"
{ $subsection "tuple-introspection" }
"Tuple classes can be redefined; this updates existing instances:"
{ $subsection "tuple-redefinition" }
"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
ABOUT: "tuples"
HELP: delegate
{ $values { "obj" object } { "delegate" object } }
{ $description "Returns an object's delegate, or " { $link f } " if no delegate is set." }
{ $notes "A direct consequence of this behavior is that an object may not have a delegate of " { $link f } "." } ;
HELP: set-delegate
{ $values { "delegate" object } { "tuple" tuple } }
{ $description "Sets a tuple's delegate. Method calls not handled by the tuple's class will now be passed on to the delegate." } ;
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
HELP: removed-slots
{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
HELP: forget-removed-slots
{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
HELP: tuple
{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
$nl
@ -187,7 +291,7 @@ $low-level-note ;
HELP: tuple-slots
{ $values { "tuple" tuple } { "seq" sequence } }
{ $description "Pushes a sequence of tuple slot values, not including the tuple class word and delegate." } ;
{ $description "Pushes a sequence of tuple slot values, not including the tuple class word." } ;
{ tuple-slots tuple>array } related-words
@ -209,26 +313,16 @@ HELP: define-tuple-class
{ tuple-class define-tuple-class POSTPONE: TUPLE: } related-words
HELP: delegates
{ $values { "obj" object } { "seq" sequence } }
{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
HELP: is?
{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the object or one of its delegates satisfies the predicate quotation."
$nl
"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ;
HELP: >tuple
{ $values { "seq" sequence } { "tuple" tuple } }
{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots."
{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word and the remainder the declared slots."
$nl
"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
HELP: tuple>array ( tuple -- array )
{ $values { "tuple" tuple } { "array" array } }
{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ;
{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
HELP: <tuple> ( layout -- tuple )
{ $values { "layout" tuple-layout } { "tuple" tuple } }

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

@ -16,25 +16,6 @@ TUPLE: rect x y w h ;
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
GENERIC: delegation-test
M: object delegation-test drop 3 ;
TUPLE: quux-tuple ;
: <quux-tuple> quux-tuple construct-empty ;
M: quux-tuple delegation-test drop 4 ;
TUPLE: quuux-tuple ;
: <quuux-tuple> { set-delegate } quuux-tuple construct ;
[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
GENERIC: delegation-test-2
TUPLE: quux-tuple-2 ;
: <quux-tuple-2> quux-tuple-2 construct-empty ;
M: quux-tuple-2 delegation-test-2 drop 4 ;
TUPLE: quuux-tuple-2 ;
: <quuux-tuple-2> { set-delegate } quuux-tuple-2 construct ;
[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
! Make sure we handle tuple class redefinition
TUPLE: redefinition-test ;
@ -62,13 +43,13 @@ C: <point> point
[ 200 ] [ "p" get y>> ] unit-test
[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
"p" get 300 ">>z" "accessors" lookup execute drop
[ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
[ 4 ] [ "p" get tuple-size ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
"IN: classes.tuple.tests TUPLE: point z y ;" eval
[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
[ 3 ] [ "p" get tuple-size ] unit-test
@ -102,11 +83,6 @@ C: <empty> empty
[ t ] [ <empty> hashcode fixnum? ] unit-test
TUPLE: delegate-clone ;
[ T{ delegate-clone T{ empty f } } ]
[ T{ delegate-clone T{ empty f } } clone ] unit-test
! Compiler regression
[ t length ] [ object>> t eq? ] must-fail-with
@ -242,7 +218,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[
"IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ no-tuple-class? ] is? ] must-fail-with
] [ error>> no-tuple-class? ] must-fail-with
! Inheritance
TUPLE: computer cpu ram ;
@ -394,7 +370,9 @@ test-server-slot-values
! Reshape crash
TUPLE: test1 a ; TUPLE: test2 < test1 b ;
T{ test2 f "a" "b" } "test" set
C: <test2> test2
"a" "b" <test2> "test" set
: test-a/b
[ "a" ] [ "test" get a>> ] unit-test
@ -509,3 +487,45 @@ USE: vocabs
define-tuple-class
] with-compilation-unit
] unit-test
[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
! Accessors not being forgotten...
[ [ ] ] [
"IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
<string-reader>
"forget-accessors-test" parse-stream
] unit-test
[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
: accessor-exists? ( class name -- ? )
>r "forget-accessors-test" "classes.tuple.tests" lookup r>
">>" append "accessors" lookup method >boolean ;
[ t ] [ "x" accessor-exists? ] unit-test
[ t ] [ "y" accessor-exists? ] unit-test
[ t ] [ "z" accessor-exists? ] unit-test
[ [ ] ] [
"IN: classes.tuple.tests GENERIC: forget-accessors-test"
<string-reader>
"forget-accessors-test" parse-stream
] unit-test
[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
[ f ] [ "x" accessor-exists? ] unit-test
[ f ] [ "y" accessor-exists? ] unit-test
[ f ] [ "z" accessor-exists? ] unit-test
TUPLE: another-forget-accessors-test ;
[ [ ] ] [
"IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
<string-reader>
"another-forget-accessors-test" parse-stream
] unit-test
[ t ] [ \ another-forget-accessors-test class? ] unit-test

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

@ -7,10 +7,6 @@ classes classes.private slots.deprecated slots.private slots
compiler.units math.private accessors assocs ;
IN: classes.tuple
M: tuple delegate 2 slot ;
M: tuple set-delegate 2 set-slot ;
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: no-tuple-class class ;
@ -19,7 +15,7 @@ ERROR: no-tuple-class class ;
GENERIC: tuple-layout ( object -- layout )
M: class tuple-layout "layout" word-prop ;
M: tuple-class tuple-layout "layout" word-prop ;
M: tuple tuple-layout 1 slot ;
@ -40,7 +36,9 @@ PRIVATE>
[ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array )
prepare-tuple>array >r copy-tuple-slots r> layout-class prefix ;
prepare-tuple>array
>r copy-tuple-slots r>
layout-class prefix ;
: tuple-slots ( tuple -- array )
prepare-tuple>array drop copy-tuple-slots ;
@ -54,7 +52,8 @@ PRIVATE>
unclip slots>tuple ;
: slot-names ( class -- seq )
"slot-names" word-prop ;
"slot-names" word-prop
[ dup array? [ second ] when ] map ;
<PRIVATE
@ -105,7 +104,7 @@ PRIVATE>
over superclass-size 2 + simple-slots ;
: define-tuple-slots ( class -- )
dup dup slot-names generate-tuple-slots
dup dup "slot-names" word-prop generate-tuple-slots
[ "slots" set-word-prop ]
[ define-accessors ] ! new
[ define-slots ] ! old
@ -120,15 +119,6 @@ PRIVATE>
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
: removed-slots ( class newslots -- seq )
swap slot-names seq-diff ;
: forget-removed-slots ( class slots -- )
dupd removed-slots [
[ reader-word forget-method ]
[ writer-word forget-method ] 2bi
] with each ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
@ -161,25 +151,23 @@ PRIVATE>
: update-tuples-after ( class -- )
outdated-tuples get [ all-slot-names ] cache drop ;
: subclasses ( class -- classes )
class-usages keys [ tuple-class? ] subset ;
: each-subclass ( class quot -- )
>r subclasses r> each ; inline
: define-tuple-shape ( class -- )
[ define-tuple-slots ]
M: tuple-class update-class
[ define-tuple-layout ]
[ define-tuple-slots ]
[ define-tuple-predicate ]
tri ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
[ nip "slot-names" set-word-prop ]
[
2drop
[ define-tuple-shape ] each-subclass
] 3tri ;
[ 2drop update-classes ]
3tri ;
: subclasses ( class -- classes )
class-usages keys [ tuple-class? ] subset ;
: each-subclass ( class quot -- )
>r subclasses r> each ; inline
: redefine-tuple-class ( class superclass slots -- )
[
@ -191,9 +179,8 @@ PRIVATE>
tri
] each-subclass
]
[ nip forget-removed-slots ]
[ define-new-tuple-class ]
3tri ;
3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
@ -214,6 +201,22 @@ M: tuple-class define-tuple-class
[ define-tuple-class ] [ 2drop ] 3bi
dup [ construct-boa throw ] curry define ;
M: tuple-class reset-class
[
dup "slot-names" word-prop [
[ reader-word method forget ]
[ writer-word method forget ] 2bi
] with each
] [
{
"class"
"metaclass"
"superclass"
"layout"
"slots"
} reset-props
] bi ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
@ -227,26 +230,13 @@ M: tuple hashcode*
] 2curry reduce
] recursive-hashcode ;
M: tuple-class reset-class
{ "metaclass" "superclass" "slots" "layout" } reset-props ;
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
M: object construct-empty ( class -- tuple )
tuple-layout <tuple> ;
M: object construct-boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;
! Deprecated
M: object set-slots ( ... obj slots -- )
<reversed> get-slots ;
M: object construct ( ... slots class -- tuple )
construct-empty [ swap set-slots ] keep ;
: delegates ( obj -- seq )
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
: delegates ( obj -- seq ) [ delegate ] follow ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline

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

@ -11,7 +11,9 @@ ARTICLE: "unions" "Union classes"
{ $subsection members }
"The set of union classes is a class:"
{ $subsection union-class }
{ $subsection union-class? } ;
{ $subsection union-class? }
"Unions are used to define behavior shared between a fixed set of classes."
{ $see-also "mixins" "tuple-subclassing" } ;
ABOUT: "unions"

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

@ -1,33 +1,21 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
generic.standard namespaces arrays math quotations ;
namespaces arrays math quotations ;
IN: classes.union
PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes.
: small-union-predicate-quot ( members -- quot )
: union-predicate-quot ( members -- quot )
dup empty? [
drop [ drop f ]
] [
unclip first "predicate" word-prop swap
[ >r "predicate" word-prop [ dup ] prepend r> ]
assoc-map alist>quot
] if ;
: big-union-predicate-quot ( members -- quot )
[ small-union-predicate-quot ] [ dup ]
class-hash-dispatch-quot ;
: union-predicate-quot ( members -- quot )
[ [ drop t ] ] { } map>assoc
dup length 4 <= [
small-union-predicate-quot
] [
flatten-methods
big-union-predicate-quot
unclip "predicate" word-prop swap [
"predicate" word-prop [ dup ] prepend
[ drop t ]
] { } map>assoc alist>quot
] if ;
: define-union-predicate ( class -- )
@ -36,7 +24,9 @@ PREDICATE: union-class < class
M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- )
f swap union-class define-class ;
[ f swap union-class define-class ]
[ drop update-classes ]
2bi ;
M: union-class reset-class
{ "metaclass" "members" } reset-props ;
{ "class" "metaclass" "members" } reset-props ;

14
core/combinators/combinators.factor
View File

@ -9,18 +9,24 @@ hashtables sorting ;
[ call ] with each ;
: cleave>quot ( seq -- quot )
[ [ keep ] curry ] map concat [ drop ] append ;
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
: 2cleave ( x seq -- )
[ [ call ] 3keep drop ] each 2drop ;
[ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
[ [ 2keep ] curry ] map concat [ 2drop ] append ;
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
: 3cleave ( x seq -- )
[ 3keep ] each 3drop ;
: 3cleave>quot ( seq -- quot )
[ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
: spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi
append ;
append [ ] like ;
: spread ( objs... seq -- )
spread>quot call ;

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

@ -47,7 +47,7 @@ SYMBOL: main-vocab-hook
] bind ;
: ignore-cli-args? ( -- ? )
macosx? "run" get "ui" = and ;
os macosx? "run" get "ui" = and ;
: script-mode ( -- )
t "quiet" set-global

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

@ -2,14 +2,21 @@ USING: generator help.markup help.syntax words io parser
assocs words.private sequences compiler.units ;
IN: compiler
HELP: enable-compiler
{ $description "Enables the optimizing compiler." } ;
HELP: disable-compiler
{ $description "Enables the optimizing compiler." } ;
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
$nl
"The main entry point to the optimizing compiler:"
"Normally, new word definitions are recompiled automatically. This can be changed:"
{ $subsection disable-compiler }
{ $subsection enable-compiler }
"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
{ $subsection decompile }
"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ;
"Higher-level words can be found in " { $link "compilation-units" } "." ;
ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:"

6
core/compiler/compiler.factor
View File

@ -56,5 +56,11 @@ IN: compiler
compiled get >alist
] with-scope ;
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
: recompile-all ( -- )
forget-errors all-words compile ;

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

@ -174,11 +174,6 @@ sequences.private ;
[ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
[ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
[ t ] [ f type f [ type ] compile-call eq? ] unit-test
[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
@ -223,9 +218,6 @@ sequences.private ;
[ t ] [ f [ f eq? ] compile-call ] unit-test
! regression
[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test
! regression
[ 3 ] [
100001 f <array> 3 100000 pick set-nth

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

@ -4,7 +4,7 @@ USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
words kernel math effects definitions compiler.units ;
: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
[
[ ] [ init-templates ] unit-test
@ -15,18 +15,18 @@ words kernel math effects definitions compiler.units ;
[ ] [ compute-free-vregs ] unit-test
[ f ] [ 0 <int-vreg> T{ int-regs } free-vregs member? ] unit-test
[ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
[ f ] [
[
copy-templates
1 <int-vreg> phantom-push
compute-free-vregs
1 <int-vreg> T{ int-regs } free-vregs member?
1 <int-vreg> int-regs free-vregs member?
] with-scope
] unit-test
[ t ] [ 1 <int-vreg> T{ int-regs } free-vregs member? ] unit-test
[ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
] with-scope
[
@ -173,12 +173,12 @@ SYMBOL: template-chosen
] unit-test
[ ] [
2 phantom-d get phantom-input
2 phantom-datastack get phantom-input
[ { { f "a" } { f "b" } } lazy-load ] { } make drop
] unit-test
[ t ] [
phantom-d get [ cached? ] all?
phantom-datastack get [ cached? ] all?
] unit-test
! >r

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

@ -26,10 +26,6 @@ IN: compiler.tests
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test
[ { 1 2 3 } { 1 4 3 } 8 8 ]
[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ]
unit-test
! Test literals in either side of a shuffle
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
@ -176,14 +172,14 @@ TUPLE: my-tuple ;
[ 1 t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
[ 0 alien-unsigned-1 ] keep type
[ 0 alien-unsigned-1 ] keep hi-tag
] compile-call byte-array type-number =
] unit-test
[ t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
0 alien-cell type
0 alien-cell hi-tag
] compile-call alien type-number =
] unit-test
@ -206,3 +202,47 @@ TUPLE: my-tuple ;
] [ 2drop no-case ] if
] compile-call
] unit-test
: float-spill-bug
{
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
[ dup float+ ]
} cleave ;
[ t ] [ \ float-spill-bug compiled? ] unit-test

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

@ -22,11 +22,3 @@ TUPLE: color red green blue ;
[ T{ color f f f f } ]
[ [ color construct-empty ] compile-call ] unit-test
[ T{ color "a" f "b" f } ] [
"a" "b"
[ { set-delegate set-color-green } color construct ]
compile-call
] unit-test
[ T{ color f f f f } ] [ [ { } color construct ] compile-call ] unit-test

27
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 ;
assocs words quotations io ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
@ -17,6 +17,25 @@ ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
{ $subsection error-continuation }
"Developer tools for inspecting these values are found in " { $link "debugger" } "." ;
ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."
{ $heading "Anti-pattern #1: Ignoring errors" }
"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."
{ $heading "Anti-pattern #2: Catching errors too early" }
"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."
$nl
"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
{ $heading "Anti-pattern #3: Dropping and rethrowing" }
"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
{ $heading "Anti-pattern #4: Logging and rethrowing" }
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information."
{ $heading "Anti-pattern #5: Leaking external resources" }
"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
{ $code
"<external-resource> ... do stuff ... dispose"
}
"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ;
ARTICLE: "errors" "Error handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
$nl
@ -27,10 +46,13 @@ $nl
{ $subsection cleanup }
{ $subsection recover }
{ $subsection ignore-errors }
"Syntax sugar for defining errors:"
{ $subsection POSTPONE: ERROR: }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
{ $subsection "debugger" }
{ $subsection "errors-post-mortem" }
{ $subsection "errors-anti-examples" }
"When Factor encouters a critical error, it calls the following word:"
{ $subsection die } ;
@ -61,8 +83,7 @@ $nl
"Another two words resume continuations:"
{ $subsection continue }
{ $subsection continue-with }
"Continuations serve as the building block for a number of higher-level abstractions."
{ $subsection "errors" }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
ABOUT: "continuations"

24
core/continuations/continuations.factor
View File

@ -141,14 +141,9 @@ GENERIC: dispose ( object -- )
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
TUPLE: condition restarts continuation ;
TUPLE: condition error restarts continuation ;
: <condition> ( error restarts cc -- condition )
{
set-delegate
set-condition-restarts
set-condition-continuation
} condition construct ;
C: <condition> condition ( error restarts cc -- condition )
: throw-restarts ( error restarts -- restart )
[ <condition> throw ] callcc1 2nip ;
@ -161,15 +156,14 @@ TUPLE: restart name obj continuation ;
C: <restart> restart
: restart ( restart -- )
dup restart-obj swap restart-continuation continue-with ;
[ obj>> ] [ continuation>> ] bi continue-with ;
M: object compute-restarts drop { } ;
M: tuple compute-restarts delegate compute-restarts ;
M: condition compute-restarts
[ delegate compute-restarts ] keep
[ condition-restarts ] keep
condition-continuation
[ <restart> ] curry { } assoc>map
append ;
[ error>> compute-restarts ]
[
[ restarts>> ]
[ condition-continuation [ <restart> ] curry ] bi
{ } assoc>map
] bi append ;

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

@ -5,10 +5,8 @@ namespaces sequences layouts system hashtables classes alien
byte-arrays bit-arrays float-arrays combinators words ;
IN: cpu.architecture
SYMBOL: compiler-backend
! A pseudo-register class for parameters spilled on the stack
TUPLE: stack-params ;
SINGLETON: stack-params
! Return values of this class go here
GENERIC: return-reg ( register-class -- reg )
@ -26,122 +24,122 @@ GENERIC: vregs ( register-class -- regs )
! Load a literal (immediate or indirect)
GENERIC# load-literal 1 ( obj vreg -- )
HOOK: load-indirect compiler-backend ( obj reg -- )
HOOK: load-indirect cpu ( obj reg -- )
HOOK: stack-frame compiler-backend ( frame-size -- n )
HOOK: stack-frame cpu ( frame-size -- n )
: stack-frame* ( -- n )
\ stack-frame get stack-frame ;
! Set up caller stack frame
HOOK: %prologue compiler-backend ( n -- )
HOOK: %prologue cpu ( n -- )
: %prologue-later \ %prologue-later , ;
! Tear down stack frame
HOOK: %epilogue compiler-backend ( n -- )
HOOK: %epilogue cpu ( n -- )
: %epilogue-later \ %epilogue-later , ;
! Store word XT in stack frame
HOOK: %save-word-xt compiler-backend ( -- )
HOOK: %save-word-xt cpu ( -- )
! Store dispatch branch XT in stack frame
HOOK: %save-dispatch-xt compiler-backend ( -- )
HOOK: %save-dispatch-xt cpu ( -- )
M: object %save-dispatch-xt %save-word-xt ;
! Call another word
HOOK: %call compiler-backend ( word -- )
HOOK: %call cpu ( word -- )
! Local jump for branches
HOOK: %jump-label compiler-backend ( label -- )
HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
HOOK: %jump-t compiler-backend ( label -- )
HOOK: %jump-t cpu ( label -- )
HOOK: %dispatch compiler-backend ( -- )
HOOK: %dispatch cpu ( -- )
HOOK: %dispatch-label compiler-backend ( word -- )
HOOK: %dispatch-label cpu ( word -- )
! Return to caller
HOOK: %return compiler-backend ( -- )
HOOK: %return cpu ( -- )
! Change datastack height
HOOK: %inc-d compiler-backend ( n -- )
HOOK: %inc-d cpu ( n -- )
! Change callstack height
HOOK: %inc-r compiler-backend ( n -- )
HOOK: %inc-r cpu ( n -- )
! Load stack into vreg
HOOK: %peek compiler-backend ( vreg loc -- )
HOOK: %peek cpu ( vreg loc -- )
! Store vreg to stack
HOOK: %replace compiler-backend ( vreg loc -- )
HOOK: %replace cpu ( vreg loc -- )
! Box and unbox floats
HOOK: %unbox-float compiler-backend ( dst src -- )
HOOK: %box-float compiler-backend ( dst src -- )
HOOK: %unbox-float cpu ( dst src -- )
HOOK: %box-float cpu ( dst src -- )
! FFI stuff
! Is this integer small enough to appear in value template
! slots?
HOOK: small-enough? compiler-backend ( n -- ? )
HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? compiler-backend ( size -- ? )
HOOK: struct-small-enough? cpu ( size -- ? )
! Do we pass explode value structs?
HOOK: value-structs? compiler-backend ( -- ? )
HOOK: value-structs? cpu ( -- ? )
! If t, fp parameters are shadowed by dummy int parameters
HOOK: fp-shadows-int? compiler-backend ( -- ? )
HOOK: fp-shadows-int? cpu ( -- ? )
HOOK: %prepare-unbox compiler-backend ( -- )
HOOK: %prepare-unbox cpu ( -- )
HOOK: %unbox compiler-backend ( n reg-class func -- )
HOOK: %unbox cpu ( n reg-class func -- )
HOOK: %unbox-long-long compiler-backend ( n func -- )
HOOK: %unbox-long-long cpu ( n func -- )
HOOK: %unbox-small-struct compiler-backend ( size -- )
HOOK: %unbox-small-struct cpu ( size -- )
HOOK: %unbox-large-struct compiler-backend ( n size -- )
HOOK: %unbox-large-struct cpu ( n size -- )
HOOK: %box compiler-backend ( n reg-class func -- )
HOOK: %box cpu ( n reg-class func -- )
HOOK: %box-long-long compiler-backend ( n func -- )
HOOK: %box-long-long cpu ( n func -- )
HOOK: %prepare-box-struct compiler-backend ( size -- )
HOOK: %prepare-box-struct cpu ( size -- )
HOOK: %box-small-struct compiler-backend ( size -- )
HOOK: %box-small-struct cpu ( size -- )
HOOK: %box-large-struct compiler-backend ( n size -- )
HOOK: %box-large-struct cpu ( n size -- )
GENERIC: %save-param-reg ( stack reg reg-class -- )
GENERIC: %load-param-reg ( stack reg reg-class -- )
HOOK: %prepare-alien-invoke compiler-backend ( -- )
HOOK: %prepare-alien-invoke cpu ( -- )
HOOK: %prepare-var-args compiler-backend ( -- )
HOOK: %prepare-var-args cpu ( -- )
M: object %prepare-var-args ;
HOOK: %alien-invoke compiler-backend ( function library -- )
HOOK: %alien-invoke cpu ( function library -- )
HOOK: %cleanup compiler-backend ( alien-node -- )
HOOK: %cleanup cpu ( alien-node -- )
HOOK: %alien-callback compiler-backend ( quot -- )
HOOK: %alien-callback cpu ( quot -- )
HOOK: %callback-value compiler-backend ( ctype -- )
HOOK: %callback-value cpu ( ctype -- )
! Return to caller with stdcall unwinding (only for x86)
HOOK: %unwind compiler-backend ( n -- )
HOOK: %unwind cpu ( n -- )
HOOK: %prepare-alien-indirect compiler-backend ( -- )
HOOK: %prepare-alien-indirect cpu ( -- )
HOOK: %alien-indirect compiler-backend ( -- )
HOOK: %alien-indirect cpu ( -- )
M: stack-params param-reg drop ;
@ -179,15 +177,15 @@ PREDICATE: inline-array < integer 32 < ;
] if-small-struct ;
! Alien accessors
HOOK: %unbox-byte-array compiler-backend ( dst src -- )
HOOK: %unbox-byte-array cpu ( dst src -- )
HOOK: %unbox-alien compiler-backend ( dst src -- )
HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-f compiler-backend ( dst src -- )
HOOK: %unbox-f cpu ( dst src -- )
HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien compiler-backend ( dst src -- )
HOOK: %box-alien cpu ( dst src -- )
: operand ( var -- op ) get v>operand ; inline

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

@ -32,7 +32,7 @@ IN: cpu.ppc.allot
12 11 float tag-number ORI
f fresh-object ;
M: ppc-backend %box-float ( dst src -- )
M: ppc %box-float ( dst src -- )
[ v>operand ] bi@ %allot-float 12 MR ;
: %allot-bignum ( #digits -- )
@ -78,7 +78,7 @@ M: ppc-backend %box-float ( dst src -- )
"end" resolve-label
] with-scope ;
M: ppc-backend %box-alien ( dst src -- )
M: ppc %box-alien ( dst src -- )
{ "end" "f" } [ define-label ] each
0 over v>operand 0 CMPI
"f" get BEQ

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

@ -7,8 +7,6 @@ layouts classes words.private alien combinators
compiler.constants ;
IN: cpu.ppc.architecture
TUPLE: ppc-backend ;
! PowerPC register assignments
! r3-r10, r16-r31: integer vregs
! f0-f13: float vregs
@ -21,14 +19,14 @@ TUPLE: ppc-backend ;
: reserved-area-size
os {
{ "linux" [ 2 ] }
{ "macosx" [ 6 ] }
{ linux [ 2 ] }
{ macosx [ 6 ] }
} case cells ; foldable
: lr-save
os {
{ "linux" [ 1 ] }
{ "macosx" [ 2 ] }
{ linux [ 1 ] }
{ macosx [ 2 ] }
} case cells ; foldable
: param@ ( n -- x ) reserved-area-size + ; inline
@ -44,7 +42,7 @@ TUPLE: ppc-backend ;
: xt-save ( n -- i ) 2 cells - ;
M: ppc-backend stack-frame ( n -- i )
M: ppc stack-frame ( n -- i )
local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ;
@ -60,8 +58,8 @@ M: int-regs vregs
M: float-regs return-reg drop 1 ;
M: float-regs param-regs
drop os H{
{ "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
{ "linux" { 1 2 3 4 5 6 7 8 } }
{ macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
{ linux { 1 2 3 4 5 6 7 8 } }
} at ;
M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
@ -73,14 +71,14 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
M: immediate load-literal
[ v>operand ] bi@ LOAD ;
M: ppc-backend load-indirect ( obj reg -- )
M: ppc load-indirect ( obj reg -- )
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
dup 0 LWZ ;
M: ppc-backend %save-word-xt ( -- )
M: ppc %save-word-xt ( -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
M: ppc-backend %prologue ( n -- )
M: ppc %prologue ( n -- )
0 MFLR
1 1 pick neg ADDI
11 1 pick xt-save STW
@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- )
11 1 pick next-save STW
0 1 rot lr-save + STW ;
M: ppc-backend %epilogue ( n -- )
M: ppc %epilogue ( n -- )
#! At the end of each word that calls a subroutine, we store
#! the previous link register value in r0 by popping it off
#! the stack, set the link register to the contents of r0,
@ -104,14 +102,14 @@ M: ppc-backend %epilogue ( n -- )
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
M: ppc-backend %call ( label -- ) BL ;
M: ppc %call ( label -- ) BL ;
M: ppc-backend %jump-label ( label -- ) B ;
M: ppc %jump-label ( label -- ) B ;
M: ppc-backend %jump-t ( label -- )
M: ppc %jump-t ( label -- )
0 "flag" operand f v>operand CMPI BNE ;
M: ppc-backend %dispatch ( -- )
M: ppc %dispatch ( -- )
[
%epilogue-later
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
@ -124,35 +122,43 @@ M: ppc-backend %dispatch ( -- )
{ +scratch+ { { f "offset" } } }
} with-template ;
M: ppc-backend %dispatch-label ( word -- )
M: ppc %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
M: ppc-backend %return ( -- ) %epilogue-later BLR ;
M: ppc %return ( -- ) %epilogue-later BLR ;
M: ppc-backend %unwind drop %return ;
M: ppc %unwind drop %return ;
M: ppc-backend %peek ( vreg loc -- )
M: ppc %peek ( vreg loc -- )
>r v>operand r> loc>operand LWZ ;
M: ppc-backend %replace
M: ppc %replace
>r v>operand r> loc>operand STW ;
M: ppc-backend %unbox-float ( dst src -- )
M: ppc %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset LFD ;
M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
: STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
GENERIC: STF ( src dst reg-class -- )
M: single-float-regs STF drop STFS ;
M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
: LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
GENERIC: LF ( src dst reg-class -- )
M: single-float-regs LF drop LFS ;
M: double-float-regs LF drop LFD ;
M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
@ -166,19 +172,19 @@ M: stack-params %save-param-reg ( stack reg reg-class -- )
0 1 rot param@ stack-frame* + LWZ
0 1 rot local@ STW ;
M: ppc-backend %prepare-unbox ( -- )
M: ppc %prepare-unbox ( -- )
! First parameter is top of stack
3 ds-reg 0 LWZ
ds-reg dup cell SUBI ;
M: ppc-backend %unbox ( n reg-class func -- )
M: ppc %unbox ( n reg-class func -- )
! Value must be in r3
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: ppc-backend %unbox-long-long ( n func -- )
M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4
! Call the unboxer
f %alien-invoke
@ -188,7 +194,7 @@ M: ppc-backend %unbox-long-long ( n func -- )
4 1 rot cell + local@ STW
] when* ;
M: ppc-backend %unbox-large-struct ( n size -- )
M: ppc %unbox-large-struct ( n size -- )
! Value must be in r3
! Compute destination address
4 1 roll local@ ADDI
@ -197,7 +203,7 @@ M: ppc-backend %unbox-large-struct ( n size -- )
! Call the function
"to_value_struct" f %alien-invoke ;
M: ppc-backend %box ( n reg-class func -- )
M: ppc %box ( n reg-class func -- )
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
@ -205,7 +211,7 @@ M: ppc-backend %box ( n reg-class func -- )
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
r> f %alien-invoke ;
M: ppc-backend %box-long-long ( n func -- )
M: ppc %box-long-long ( n func -- )
>r [
3 1 pick local@ LWZ
4 1 rot cell + local@ LWZ
@ -215,12 +221,12 @@ M: ppc-backend %box-long-long ( n func -- )
: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
M: ppc-backend %prepare-box-struct ( size -- )
M: ppc %prepare-box-struct ( size -- )
#! Compute target address for value struct return
3 1 rot f struct-return@ ADDI
3 1 0 local@ STW ;
M: ppc-backend %box-large-struct ( n size -- )
M: ppc %box-large-struct ( n size -- )
#! If n = f, then we're boxing a returned struct
[ swap struct-return@ ] keep
! Compute destination address
@ -230,7 +236,7 @@ M: ppc-backend %box-large-struct ( n size -- )
! Call the function
"box_value_struct" f %alien-invoke ;
M: ppc-backend %prepare-alien-invoke
M: ppc %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
@ -240,20 +246,20 @@ M: ppc-backend %prepare-alien-invoke
ds-reg 11 8 STW
rs-reg 11 12 STW ;
M: ppc-backend %alien-invoke ( symbol dll -- )
M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym (%call) ;
M: ppc-backend %alien-callback ( quot -- )
M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
M: ppc-backend %prepare-alien-indirect ( -- )
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
3 1 cell temp@ STW ;
M: ppc-backend %alien-indirect ( -- )
M: ppc %alien-indirect ( -- )
11 1 cell temp@ LWZ (%call) ;
M: ppc-backend %callback-value ( ctype -- )
M: ppc %callback-value ( ctype -- )
! Save top of data stack
3 ds-reg 0 LWZ
3 1 0 local@ STW
@ -264,7 +270,7 @@ M: ppc-backend %callback-value ( ctype -- )
! Unbox former top of data stack to return registers
unbox-return ;
M: ppc-backend %cleanup ( alien-node -- ) drop ;
M: ppc %cleanup ( alien-node -- ) drop ;
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
@ -272,34 +278,34 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
M: ppc-backend value-structs?
M: ppc value-structs?
#! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first.
linux? not ;
os linux? not ;
M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ;
M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
M: ppc-backend small-enough? ( n -- ? ) -32768 32767 between? ;
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
M: ppc-backend struct-small-enough? ( size -- ? ) drop f ;
M: ppc struct-small-enough? ( size -- ? ) drop f ;
M: ppc-backend %box-small-struct
M: ppc %box-small-struct
drop "No small structs" throw ;
M: ppc-backend %unbox-small-struct
M: ppc %unbox-small-struct
drop "No small structs" throw ;
! Alien intrinsics
M: ppc-backend %unbox-byte-array ( dst src -- )
M: ppc %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset ADDI ;
M: ppc-backend %unbox-alien ( dst src -- )
M: ppc %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset LWZ ;
M: ppc-backend %unbox-f ( dst src -- )
M: ppc %unbox-f ( dst src -- )
drop 0 swap v>operand LI ;
M: ppc-backend %unbox-any-c-ptr ( dst src -- )
M: ppc %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in R12
0 12 LI

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

@ -402,55 +402,6 @@ IN: cpu.ppc.intrinsics
{ +output+ { "out" } }
} define-intrinsic
\ type [
"end" define-label
! Get the tag
"y" operand "obj" operand tag-mask get ANDI
! Tag the tag
"y" operand "x" operand %tag-fixnum
! Compare with object tag number (3).
0 "y" operand object tag-number CMPI
! Jump if the object doesn't store type info in its header
"end" get BNE
! It does store type info in its header
"x" operand "obj" operand header-offset LWZ
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } { f "y" } } }
{ +output+ { "x" } }
} define-intrinsic
\ class-hash [
"end" define-label
"tuple" define-label
"object" define-label
! Get the tag
"y" operand "obj" operand tag-mask get ANDI
! Compare with tuple tag number (2).
0 "y" operand tuple tag-number CMPI
"tuple" get BEQ
! Compare with object tag number (3).
0 "y" operand object tag-number CMPI
"object" get BEQ
! Tag the tag
"y" operand "x" operand %tag-fixnum
"end" get B
"object" get resolve-label
! Load header type
"x" operand "obj" operand header-offset LWZ
"end" get B
"tuple" get resolve-label
! Load class hash
"x" operand "obj" operand tuple-class-offset LWZ
"x" operand dup class-hash-offset LWZ
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } { f "y" } } }
{ +output+ { "x" } }
} define-intrinsic
: userenv ( reg -- )
#! Load the userenv pointer in a register.
"userenv" f rot %load-dlsym ;

11
core/cpu/ppc/ppc.factor
View File

@ -2,18 +2,13 @@ USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture
namespaces alien.c-types kernel system combinators ;
{
{ [ macosx? ] [
{ [ os macosx? ] [
4 "longlong" c-type set-c-type-align
4 "ulonglong" c-type set-c-type-align
4 "double" c-type set-c-type-align
] }
{ [ linux? ] [
{ [ os linux? ] [
t "longlong" c-type set-c-type-stack-align?
t "ulonglong" c-type set-c-type-stack-align?
] }
} cond
T{ ppc-backend } compiler-backend set-global
macosx? [
4 "double" c-type set-c-type-align
] when

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

@ -8,23 +8,20 @@ alien.compiler combinators command-line
compiler compiler.units io vocabs.loader accessors ;
IN: cpu.x86.32
PREDICATE: x86-32-backend < x86-backend
x86-backend-cell 4 = ;
! We implement the FFI for Linux, OS X and Windows all at once.
! OS X requires that the stack be 16-byte aligned, and we do
! this on all platforms, sacrificing some stack space for
! code simplicity.
M: x86-32-backend ds-reg ESI ;
M: x86-32-backend rs-reg EDI ;
M: x86-32-backend stack-reg ESP ;
M: x86-32-backend xt-reg ECX ;
M: x86-32-backend stack-save-reg EDX ;
M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 xt-reg ECX ;
M: x86.32 stack-save-reg EDX ;
M: temp-reg v>operand drop EBX ;
M: x86-32-backend %alien-invoke ( symbol dll -- )
M: x86.32 %alien-invoke ( symbol dll -- )
(CALL) rel-dlsym ;
! On x86, parameters are never passed in registers.
@ -61,20 +58,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
! On x86, we can always use an address as an operand
! directly.
M: x86-32-backend address-operand ;
M: x86.32 address-operand ;
M: x86-32-backend fixnum>slot@ 1 SHR ;
M: x86.32 fixnum>slot@ 1 SHR ;
M: x86-32-backend prepare-division CDQ ;
M: x86.32 prepare-division CDQ ;
M: x86-32-backend load-indirect
M: x86.32 load-indirect
0 [] MOV rc-absolute-cell rel-literal ;
M: object %load-param-reg 3drop ;
M: object %save-param-reg 3drop ;
M: x86-32-backend %prepare-unbox ( -- )
M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX.
EAX ESI [] MOV
ESI 4 SUB ;
@ -87,7 +84,7 @@ M: x86-32-backend %prepare-unbox ( -- )
f %alien-invoke
] with-aligned-stack ;
M: x86-32-backend %unbox ( n reg-class func -- )
M: x86.32 %unbox ( n reg-class func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
@ -96,7 +93,7 @@ M: x86-32-backend %unbox ( n reg-class func -- )
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
M: x86-32-backend %unbox-long-long ( n func -- )
M: x86.32 %unbox-long-long ( n func -- )
(%unbox)
! Store the return value on the C stack
[
@ -104,7 +101,7 @@ M: x86-32-backend %unbox-long-long ( n func -- )
cell + stack@ EDX MOV
] when* ;
M: x86-32-backend %unbox-struct-2
M: x86.32 %unbox-struct-2
#! Alien must be in EAX.
4 [
EAX PUSH
@ -115,7 +112,7 @@ M: x86-32-backend %unbox-struct-2
EAX EAX [] MOV
] with-aligned-stack ;
M: x86-32-backend %unbox-large-struct ( n size -- )
M: x86.32 %unbox-large-struct ( n size -- )
#! Alien must be in EAX.
! Compute destination address
ECX ESP roll [+] LEA
@ -147,7 +144,7 @@ M: x86-32-backend %unbox-large-struct ( n size -- )
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
push-return-reg ;
M: x86-32-backend %box ( n reg-class func -- )
M: x86.32 %box ( n reg-class func -- )
over reg-size [
>r (%box) r> f %alien-invoke
] with-aligned-stack ;
@ -158,19 +155,19 @@ M: x86-32-backend %box ( n reg-class func -- )
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
#! boxing a parameter being passed to a callback from C.
[
T{ int-regs } box@
int-regs box@
EDX over stack@ MOV
EAX swap cell - stack@ MOV
] when*
EDX PUSH
EAX PUSH ;
M: x86-32-backend %box-long-long ( n func -- )
M: x86.32 %box-long-long ( n func -- )
8 [
>r (%box-long-long) r> f %alien-invoke
] with-aligned-stack ;
M: x86-32-backend %box-large-struct ( n size -- )
M: x86.32 %box-large-struct ( n size -- )
! Compute destination address
[ swap struct-return@ ] keep
ECX ESP roll [+] LEA
@ -183,13 +180,13 @@ M: x86-32-backend %box-large-struct ( n size -- )
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
M: x86-32-backend %prepare-box-struct ( size -- )
M: x86.32 %prepare-box-struct ( size -- )
! Compute target address for value struct return
EAX ESP rot f struct-return@ [+] LEA
! Store it as the first parameter
ESP [] EAX MOV ;
M: x86-32-backend %unbox-struct-1
M: x86.32 %unbox-struct-1
#! Alien must be in EAX.
4 [
EAX PUSH
@ -198,7 +195,7 @@ M: x86-32-backend %unbox-struct-1
EAX EAX [] MOV
] with-aligned-stack ;
M: x86-32-backend %box-small-struct ( size -- )
M: x86.32 %box-small-struct ( size -- )
#! Box a <= 8-byte struct returned in EAX:DX. OS X only.
12 [
PUSH
@ -207,21 +204,21 @@ M: x86-32-backend %box-small-struct ( size -- )
"box_small_struct" f %alien-invoke
] with-aligned-stack ;
M: x86-32-backend %prepare-alien-indirect ( -- )
M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ EAX MOV ;
M: x86-32-backend %alien-indirect ( -- )
M: x86.32 %alien-indirect ( -- )
cell temp@ CALL ;
M: x86-32-backend %alien-callback ( quot -- )
M: x86.32 %alien-callback ( quot -- )
4 [
EAX load-indirect
EAX PUSH
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
M: x86-32-backend %callback-value ( ctype -- )
M: x86.32 %callback-value ( ctype -- )
! Align C stack
ESP 12 SUB
! Save top of data stack
@ -236,7 +233,7 @@ M: x86-32-backend %callback-value ( ctype -- )
! Unbox EAX
unbox-return ;
M: x86-32-backend %cleanup ( alien-node -- )
M: x86.32 %cleanup ( alien-node -- )
#! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue.
@ -254,19 +251,14 @@ M: x86-32-backend %cleanup ( alien-node -- )
}
} cond ;
M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ;
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
windows? [
os windows? [
cell "longlong" c-type set-c-type-align
cell "ulonglong" c-type set-c-type-align
] unless
windows? [
4 "double" c-type set-c-type-align
] unless
T{ x86-backend f 4 } compiler-backend set-global
: sse2? "Intrinsic" throw ;
\ sse2? [

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

@ -8,14 +8,11 @@ layouts alien alien.accessors alien.compiler alien.structs slots
splitting assocs ;
IN: cpu.x86.64
PREDICATE: amd64-backend < x86-backend
x86-backend-cell 8 = ;
M: amd64-backend ds-reg R14 ;
M: amd64-backend rs-reg R15 ;
M: amd64-backend stack-reg RSP ;
M: amd64-backend xt-reg RCX ;
M: amd64-backend stack-save-reg RSI ;
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 xt-reg RCX ;
M: x86.64 stack-save-reg RSI ;
M: temp-reg v>operand drop RBX ;
@ -34,18 +31,18 @@ M: float-regs vregs
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
M: amd64-backend address-operand ( address -- operand )
M: x86.64 address-operand ( address -- operand )
#! On AMD64, we have to load 64-bit addresses into a
#! scratch register first. The usage of R11 here is a hack.
#! This word can only be called right before a subroutine
#! call, where all vregs have been flushed anyway.
temp-reg v>operand [ swap MOV ] keep ;
M: amd64-backend fixnum>slot@ drop ;
M: x86.64 fixnum>slot@ drop ;
M: amd64-backend prepare-division CQO ;
M: x86.64 prepare-division CQO ;
M: amd64-backend load-indirect ( literal reg -- )
M: x86.64 load-indirect ( literal reg -- )
0 [] MOV rc-relative rel-literal ;
M: stack-params %load-param-reg
@ -56,27 +53,27 @@ M: stack-params %load-param-reg
M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-param-reg ;
M: amd64-backend %prepare-unbox ( -- )
M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack
RDI R14 [] MOV
R14 cell SUB ;
M: amd64-backend %unbox ( n reg-class func -- )
M: x86.64 %unbox ( n reg-class func -- )
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
M: amd64-backend %unbox-long-long ( n func -- )
T{ int-regs } swap %unbox ;
M: x86.64 %unbox-long-long ( n func -- )
int-regs swap %unbox ;
M: amd64-backend %unbox-struct-1 ( -- )
M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load first cell
RAX RAX [] MOV ;
M: amd64-backend %unbox-struct-2 ( -- )
M: x86.64 %unbox-struct-2 ( -- )
#! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load second cell
@ -84,7 +81,7 @@ M: amd64-backend %unbox-struct-2 ( -- )
! Load first cell
RAX RAX [] MOV ;
M: amd64-backend %unbox-large-struct ( n size -- )
M: x86.64 %unbox-large-struct ( n size -- )
! Source is in RDI
! Load destination address
RSI RSP roll [+] LEA
@ -97,7 +94,7 @@ M: amd64-backend %unbox-large-struct ( n size -- )
0 over param-reg swap return-reg
2dup eq? [ 2drop ] [ MOV ] if ;
M: amd64-backend %box ( n reg-class func -- )
M: x86.64 %box ( n reg-class func -- )
rot [
rot [ 0 swap param-reg ] keep %load-param-reg
] [
@ -105,19 +102,19 @@ M: amd64-backend %box ( n reg-class func -- )
] if*
f %alien-invoke ;
M: amd64-backend %box-long-long ( n func -- )
T{ int-regs } swap %box ;
M: x86.64 %box-long-long ( n func -- )
int-regs swap %box ;
M: amd64-backend struct-small-enough? ( size -- ? ) 2 cells <= ;
M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
M: amd64-backend %box-small-struct ( size -- )
M: x86.64 %box-small-struct ( size -- )
#! Box a <= 16-byte struct returned in RAX:RDX.
RDI RAX MOV
RSI RDX MOV
RDX swap MOV
"box_small_struct" f %alien-invoke ;
M: amd64-backend %box-large-struct ( n size -- )
M: x86.64 %box-large-struct ( n size -- )
! Struct size is parameter 2
RSI over MOV
! Compute destination address
@ -125,27 +122,27 @@ M: amd64-backend %box-large-struct ( n size -- )
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ;
M: amd64-backend %prepare-box-struct ( size -- )
M: x86.64 %prepare-box-struct ( size -- )
! Compute target address for value struct return
RAX RSP rot f struct-return@ [+] LEA
RSP 0 [+] RAX MOV ;
M: amd64-backend %prepare-var-args RAX RAX XOR ;
M: x86.64 %prepare-var-args RAX RAX XOR ;
M: amd64-backend %alien-invoke ( symbol dll -- )
M: x86.64 %alien-invoke ( symbol dll -- )
0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
M: amd64-backend %prepare-alien-indirect ( -- )
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ RAX MOV ;
M: amd64-backend %alien-indirect ( -- )
M: x86.64 %alien-indirect ( -- )
cell temp@ CALL ;
M: amd64-backend %alien-callback ( quot -- )
M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ;
M: amd64-backend %callback-value ( ctype -- )
M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
! Put former top of data stack in RDI
@ -157,9 +154,9 @@ M: amd64-backend %callback-value ( ctype -- )
! Unbox former top of data stack to return registers
unbox-return ;
M: amd64-backend %cleanup ( alien-node -- ) drop ;
M: x86.64 %cleanup ( alien-node -- ) drop ;
M: amd64-backend %unwind ( n -- ) drop %epilogue-later 0 RET ;
M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
USE: cpu.x86.intrinsics
@ -171,11 +168,9 @@ USE: cpu.x86.intrinsics
\ alien-signed-4 small-reg-32 define-signed-getter
\ set-alien-signed-4 small-reg-32 define-setter
T{ x86-backend f 8 } compiler-backend set-global
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
stack-params "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
@ -197,7 +192,7 @@ M: struct-type flatten-value-type ( type -- seq )
] [
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
T{ int-regs } swap member?
int-regs swap member?
"void*" "double" ? c-type ,
] each
] if ;

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

@ -46,7 +46,7 @@ IN: cpu.x86.allot
allot-reg swap tag-number OR
allot-reg MOV ;
M: x86-backend %box-float ( dst src -- )
M: x86 %box-float ( dst src -- )
#! Only called by pentium4 backend, uses SSE2 instruction
#! dest is a loc or a vreg
float 16 [
@ -86,7 +86,7 @@ M: x86-backend %box-float ( dst src -- )
"end" resolve-label
] with-scope ;
M: x86-backend %box-alien ( dst src -- )
M: x86 %box-alien ( dst src -- )
[
{ "end" "f" } [ define-label ] each
dup v>operand 0 CMP

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

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math
@ -6,13 +6,11 @@ memory namespaces sequences words generator generator.registers
generator.fixup system layouts combinators compiler.constants ;
IN: cpu.x86.architecture
TUPLE: x86-backend cell ;
HOOK: ds-reg compiler-backend
HOOK: rs-reg compiler-backend
HOOK: stack-reg compiler-backend
HOOK: xt-reg compiler-backend
HOOK: stack-save-reg compiler-backend
HOOK: ds-reg cpu
HOOK: rs-reg cpu
HOOK: stack-reg cpu
HOOK: xt-reg cpu
HOOK: stack-save-reg cpu
: stack@ stack-reg swap [+] ;
@ -24,7 +22,11 @@ M: rs-loc v>operand rs-loc-n rs-reg reg-stack ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ;
: MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ;
GENERIC: MOVSS/D ( dst src reg-class -- )
M: single-float-regs MOVSS/D drop MOVSS ;
M: double-float-regs MOVSS/D drop MOVSD ;
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
@ -33,34 +35,34 @@ GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-return-reg ( stack@ reg-class -- )
HOOK: address-operand compiler-backend ( address -- operand )
HOOK: address-operand cpu ( address -- operand )
HOOK: fixnum>slot@ compiler-backend
HOOK: fixnum>slot@ cpu
HOOK: prepare-division compiler-backend
HOOK: prepare-division cpu
M: immediate load-literal v>operand swap v>operand MOV ;
M: x86-backend stack-frame ( n -- i )
M: x86 stack-frame ( n -- i )
3 cells + 16 align cell - ;
M: x86-backend %save-word-xt ( -- )
M: x86 %save-word-xt ( -- )
xt-reg 0 MOV rc-absolute-cell rel-this ;
: factor-area-size 4 cells ;
M: x86-backend %prologue ( n -- )
M: x86 %prologue ( n -- )
dup cell + PUSH
xt-reg PUSH
stack-reg swap 2 cells - SUB ;
M: x86-backend %epilogue ( n -- )
M: x86 %epilogue ( n -- )
stack-reg swap ADD ;
: %alien-global ( symbol dll register -- )
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
M: x86-backend %prepare-alien-invoke
M: x86 %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
@ -70,11 +72,11 @@ M: x86-backend %prepare-alien-invoke
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;
M: x86-backend %call ( label -- ) CALL ;
M: x86 %call ( label -- ) CALL ;
M: x86-backend %jump-label ( label -- ) JMP ;
M: x86 %jump-label ( label -- ) JMP ;
M: x86-backend %jump-t ( label -- )
M: x86 %jump-t ( label -- )
"flag" operand f v>operand CMP JNE ;
: code-alignment ( -- n )
@ -83,7 +85,7 @@ M: x86-backend %jump-t ( label -- )
: align-code ( n -- )
0 <repetition> % ;
M: x86-backend %dispatch ( -- )
M: x86 %dispatch ( -- )
[
%epilogue-later
! Load jump table base. We use a temporary register
@ -105,27 +107,27 @@ M: x86-backend %dispatch ( -- )
{ +clobber+ { "n" } }
} with-template ;
M: x86-backend %dispatch-label ( word -- )
M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
M: x86-backend %unbox-float ( dst src -- )
M: x86 %unbox-float ( dst src -- )
[ v>operand ] bi@ float-offset [+] MOVSD ;
M: x86-backend %peek [ v>operand ] bi@ MOV ;
M: x86 %peek [ v>operand ] bi@ MOV ;
M: x86-backend %replace swap %peek ;
M: x86 %replace swap %peek ;
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
M: x86-backend %inc-d ( n -- ) ds-reg (%inc) ;
M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
M: x86-backend %inc-r ( n -- ) rs-reg (%inc) ;
M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
M: x86-backend fp-shadows-int? ( -- ? ) f ;
M: x86 fp-shadows-int? ( -- ? ) f ;
M: x86-backend value-structs? t ;
M: x86 value-structs? t ;
M: x86-backend small-enough? ( n -- ? )
M: x86 small-enough? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
: %untag ( reg -- ) tag-mask get bitnot AND ;
@ -143,34 +145,34 @@ M: x86-backend small-enough? ( n -- ? )
\ stack-frame get swap -
] ?if ;
HOOK: %unbox-struct-1 compiler-backend ( -- )
HOOK: %unbox-struct-1 cpu ( -- )
HOOK: %unbox-struct-2 compiler-backend ( -- )
HOOK: %unbox-struct-2 cpu ( -- )
M: x86-backend %unbox-small-struct ( size -- )
M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
} case ;
M: x86-backend struct-small-enough? ( size -- ? )
M: x86 struct-small-enough? ( size -- ? )
{ 1 2 4 8 } member?
os { "linux" "netbsd" "solaris" } member? not and ;
os { linux netbsd solaris } member? not and ;
M: x86-backend %return ( -- ) 0 %unwind ;
M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics
M: x86-backend %unbox-byte-array ( dst src -- )
M: x86 %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset [+] LEA ;
M: x86-backend %unbox-alien ( dst src -- )
M: x86 %unbox-alien ( dst src -- )
[ v>operand ] bi@ alien-offset [+] MOV ;
M: x86-backend %unbox-f ( dst src -- )
M: x86 %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
M: x86-backend %unbox-any-c-ptr ( dst src -- )
M: x86 %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in ds-reg
ds-reg PUSH

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

@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics
{ +output+ { "in" } }
} define-intrinsic
\ type [
"end" define-label
! Make a copy
"x" operand "obj" operand MOV
! Get the tag
"x" operand tag-mask get AND
! Tag the tag
"x" operand %tag-fixnum
! Compare with object tag number (3).
"x" operand object tag-number tag-fixnum CMP
"end" get JNE
! If we have equality, load type from header
"x" operand "obj" operand -3 [+] MOV
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
\ class-hash [
"end" define-label
"tuple" define-label
"object" define-label
! Make a copy
"x" operand "obj" operand MOV
! Get the tag
"x" operand tag-mask get AND
! Tag the tag
"x" operand %tag-fixnum
! Compare with tuple tag number (2).
"x" operand tuple tag-number tag-fixnum CMP
"tuple" get JE
! Compare with object tag number (3).
"x" operand object tag-number tag-fixnum CMP
"object" get JE
"end" get JMP
"object" get resolve-label
! Load header type
"x" operand "obj" operand header-offset [+] MOV
"end" get JMP
"tuple" get resolve-label
! Load class hash
"x" operand "obj" operand tuple-class-offset [+] MOV
"x" operand dup class-hash-offset [+] MOV
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
! Slots
: %slot-literal-known-tag
"obj" operand

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

@ -1,6 +1,7 @@
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
help generic.standard continuations system debugger.private ;
help generic.standard continuations system debugger.private
io.files.private ;
IN: debugger
ARTICLE: "errors-assert" "Assertions"

18
core/debugger/debugger.factor
View File

@ -4,9 +4,9 @@ USING: arrays definitions generic hashtables inspector io kernel
math namespaces prettyprint sequences assocs sequences.private
strings io.styles vectors words system splitting math.parser
classes.tuple continuations continuations.private combinators
generic.math io.streams.duplex classes compiler.units
generic.standard vocabs threads threads.private init
kernel.private libc io.encodings ;
generic.math io.streams.duplex classes.builtin classes
compiler.units generic.standard vocabs threads threads.private
init kernel.private libc io.encodings accessors ;
IN: debugger
GENERIC: error. ( error -- )
@ -202,6 +202,12 @@ M: no-method error.
M: no-math-method summary
drop "No suitable arithmetic method" ;
M: no-next-method summary
drop "Executing call-next-method from least-specific method" ;
M: inconsistent-next-method summary
drop "Executing call-next-method with inconsistent parameters" ;
M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
@ -223,9 +229,11 @@ M: slice-error error.
M: bounds-error summary drop "Sequence index out of bounds" ;
M: condition error. delegate error. ;
M: condition error. error>> error. ;
M: condition error-help drop f ;
M: condition summary error>> summary ;
M: condition error-help error>> error-help ;
M: assert summary drop "Assertion failed" ;

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

@ -12,8 +12,6 @@ $nl
{ $subsection forget }
"Definitions can answer a sequence of definitions they directly depend on:"
{ $subsection uses }
"When a definition is changed, all definitions which depend on it are notified via a hook:"
{ $subsection redefined* }
"Definitions must implement a few operations used for printing them in source form:"
{ $subsection synopsis* }
{ $subsection definer }
@ -108,11 +106,6 @@ HELP: usage
{ $description "Outputs a sequence of definitions that directly call the given definition." }
{ $notes "The sequence might include the definition itself, if it is a recursive word." } ;
HELP: redefined*
{ $values { "defspec" "a definition specifier" } }
{ $contract "Updates the definition to cope with a callee being redefined." }
$low-level-note ;
HELP: unxref
{ $values { "defspec" "a definition specifier" } }
{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." }

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

@ -4,7 +4,7 @@ compiler.units words ;
TUPLE: combination-1 ;
M: combination-1 perform-combination 2drop [ ] ;
M: combination-1 perform-combination drop [ ] define ;
M: combination-1 make-default-method 2drop [ "No method" throw ] ;

7
core/definitions/definitions.factor
View File

@ -42,13 +42,6 @@ M: object uses drop f ;
: usage ( defspec -- seq ) \ f or crossref get at keys ;
GENERIC: redefined* ( defspec -- )
M: object redefined* drop ;
: redefined ( defspec -- )
[ crossref get at ] closure [ drop redefined* ] assoc-each ;
: unxref ( defspec -- )
dup uses crossref get remove-vertex ;

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

@ -111,7 +111,7 @@ SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get push-new* ;
: string>symbol ( str -- alien )
[ wince? [ string>u16-alien ] [ string>char-alien ] if ]
[ os wince? [ string>u16-alien ] [ string>char-alien ] if ]
over string? [ call ] [ map ] if ;
: add-dlsym-literals ( symbol dll -- )

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

@ -3,7 +3,8 @@
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 bit-arrays float-arrays
accessors ;
IN: generator.registers
SYMBOL: +input+
@ -13,9 +14,11 @@ SYMBOL: +clobber+
SYMBOL: known-tag
! Register classes
TUPLE: int-regs ;
TUPLE: float-regs size ;
SINGLETON: int-regs
SINGLETON: single-float-regs
SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
<PRIVATE
@ -48,13 +51,13 @@ M: value minimal-ds-loc* drop ;
M: value lazy-store 2drop ;
! A scratch register for computations
TUPLE: vreg n ;
TUPLE: vreg n reg-class ;
: <vreg> ( n reg-class -- vreg )
{ set-vreg-n set-delegate } vreg construct ;
C: <vreg> vreg ( n reg-class -- vreg )
M: vreg v>operand dup vreg-n swap vregs nth ;
M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
M: vreg live-vregs* , ;
M: vreg move-spec reg-class>> move-spec ;
INSTANCE: vreg value
@ -62,9 +65,9 @@ M: float-regs move-spec drop float ;
M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling
TUPLE: temp-reg ;
TUPLE: temp-reg reg-class>> ;
: temp-reg T{ temp-reg T{ int-regs } } ;
: temp-reg T{ temp-reg f int-regs } ;
M: temp-reg move-spec drop f ;
@ -73,7 +76,7 @@ INSTANCE: temp-reg value
! A data stack location.
TUPLE: ds-loc n class ;
: <ds-loc> { set-ds-loc-n } ds-loc construct ;
: <ds-loc> f ds-loc construct-boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
@ -84,8 +87,7 @@ M: ds-loc live-loc?
! A retain stack location.
TUPLE: rs-loc n class ;
: <rs-loc> { set-rs-loc-n } rs-loc construct ;
: <rs-loc> f rs-loc construct-boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
@ -126,7 +128,7 @@ INSTANCE: cached value
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
{ set-tagged-vreg } tagged construct ;
f tagged construct-boa ;
M: tagged v>operand tagged-vreg v>operand ;
M: tagged set-operand-class set-tagged-class ;
@ -228,48 +230,44 @@ INSTANCE: constant value
} case ;
! A compile-time stack
TUPLE: phantom-stack height ;
TUPLE: phantom-stack height stack ;
M: phantom-stack clone
call-next-method [ clone ] change-stack ;
GENERIC: finalize-height ( stack -- )
SYMBOL: phantom-d
SYMBOL: phantom-r
: <phantom-stack> ( class -- stack )
>r
V{ } clone 0
{ set-delegate set-phantom-stack-height }
phantom-stack construct
r> construct-delegate ;
: construct-phantom-stack ( class -- stack )
>r 0 V{ } clone r> construct-boa ; inline
: (loc)
#! Utility for methods on <loc>
phantom-stack-height - ;
height>> - ;
: (finalize-height) ( stack word -- )
#! We consolidate multiple stack height changes until the
#! last moment, and we emit the final height changing
#! instruction here.
swap [
phantom-stack-height
dup zero? [ 2drop ] [ swap execute ] if
0
] keep set-phantom-stack-height ; inline
[
over zero? [ 2drop ] [ execute ] if 0
] curry change-height drop ; inline
GENERIC: <loc> ( n stack -- loc )
TUPLE: phantom-datastack ;
TUPLE: phantom-datastack < phantom-stack ;
: <phantom-datastack> phantom-datastack <phantom-stack> ;
: <phantom-datastack> ( -- stack )
phantom-datastack construct-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ;
TUPLE: phantom-retainstack ;
TUPLE: phantom-retainstack < phantom-stack ;
: <phantom-retainstack> phantom-retainstack <phantom-stack> ;
: <phantom-retainstack> ( -- stack )
phantom-retainstack construct-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
@ -281,34 +279,33 @@ M: phantom-retainstack finalize-height
>r <reversed> r> [ <loc> ] curry map ;
: phantom-locs* ( phantom -- locs )
dup length swap phantom-locs ;
[ stack>> length ] keep phantom-locs ;
: phantoms ( -- phantom phantom )
phantom-datastack get phantom-retainstack get ;
: (each-loc) ( phantom quot -- )
>r dup phantom-locs* swap r> 2each ; inline
>r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
: each-loc ( quot -- )
>r phantom-d get r> phantom-r get over
>r >r (each-loc) r> r> (each-loc) ; inline
phantoms 2array swap [ (each-loc) ] curry each ; inline
: adjust-phantom ( n phantom -- )
[ phantom-stack-height + ] keep set-phantom-stack-height ;
swap [ + ] curry change-height drop ;
GENERIC: cut-phantom ( n phantom -- seq )
M: phantom-stack cut-phantom
[ delegate swap cut* swap ] keep set-delegate ;
: cut-phantom ( n phantom -- seq )
swap [ cut* swap ] curry change-stack drop ;
: phantom-append ( seq stack -- )
over length over adjust-phantom push-all ;
over length over adjust-phantom stack>> push-all ;
: add-locs ( n phantom -- )
2dup length <= [
2dup stack>> length <= [
2drop
] [
[ phantom-locs ] keep
[ length head-slice* ] keep
[ append >vector ] keep
delegate set-delegate
[ stack>> length head-slice* ] keep
[ append >vector ] change-stack drop
] if ;
: phantom-input ( n phantom -- seq )
@ -316,18 +313,16 @@ M: phantom-stack cut-phantom
2dup cut-phantom
>r >r neg r> adjust-phantom r> ;
: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
: each-phantom ( quot -- ) phantoms rot bi@ ; inline
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: live-vregs ( -- seq )
[ [ [ live-vregs* ] each ] each-phantom ] { } make ;
[ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
dup phantom-locs* swap 2array flip
[ phantom-locs* ] [ stack>> ] bi 2array flip
[ live-loc? ] assoc-subset
values ;
@ -340,15 +335,14 @@ SYMBOL: fresh-objects
! Computing free registers and initializing allocator
: reg-spec>class ( spec -- class )
float eq?
T{ float-regs f 8 } T{ int-regs } ? ;
float eq? double-float-regs int-regs ? ;
: free-vregs ( reg-class -- seq )
#! Free vregs in a given register class
\ free-vregs get at ;
: alloc-vreg ( spec -- reg )
dup reg-spec>class free-vregs pop swap {
[ reg-spec>class free-vregs pop ] keep {
{ f [ <tagged> ] }
{ unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] }
@ -374,8 +368,8 @@ SYMBOL: fresh-objects
} cond ;
: alloc-vreg-for ( value spec -- vreg )
swap operand-class swap alloc-vreg
dup tagged? [ tuck set-tagged-class ] [ nip ] if ;
alloc-vreg swap operand-class
over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
2dup allocation [
@ -393,7 +387,7 @@ M: value (lazy-load)
: compute-free-vregs ( -- )
#! Create a new hashtable for thee free-vregs variable.
live-vregs
{ T{ int-regs } T{ float-regs f 8 } }
{ int-regs double-float-regs }
[ 2dup (compute-free-vregs) ] H{ } map>assoc
\ free-vregs set
drop ;
@ -418,7 +412,7 @@ M: loc lazy-store
#! When shuffling more values than can fit in registers, we
#! need to find an area on the data stack which isn't in
#! use.
dup phantom-stack-height neg [ minimal-ds-loc* ] reduce ;
[ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
: find-tmp-loc ( -- n )
#! Find an area of the data stack which is not referenced
@ -442,7 +436,7 @@ M: loc lazy-store
: fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all
#! shuffle inputs at once.
T{ int-regs } free-vregs [ length ] bi@ <= ;
int-regs free-vregs [ length ] bi@ <= ;
: finalize-locs ( -- )
#! Perform any deferred stack shuffling.
@ -462,13 +456,13 @@ M: loc lazy-store
#! Kill register assignments but preserve constants and
#! class information.
dup phantom-locs*
over [
over stack>> [
dup constant? [ nip ] [
operand-class over set-operand-class
] if
] 2map
over delete-all
swap push-all ;
over stack>> delete-all
swap stack>> push-all ;
: reset-phantoms ( -- )
[ reset-phantom ] each-phantom ;
@ -483,10 +477,11 @@ M: loc lazy-store
! Loading stacks to vregs
: free-vregs? ( int# float# -- ? )
T{ float-regs f 8 } free-vregs length <=
>r T{ int-regs } free-vregs length <= r> and ;
double-float-regs free-vregs length <=
>r int-regs free-vregs length <= r> and ;
: phantom&spec ( phantom spec -- phantom' spec' )
>r stack>> r>
[ length f pad-left ] keep
[ <reversed> ] bi@ ; inline
@ -504,7 +499,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
[ substitute-here ] curry each-phantom ;
[ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- )
>r dup constant? [ constant-value ] when r> set ;
@ -516,14 +511,15 @@ M: loc lazy-store
substitute-vregs ;
: load-inputs ( -- )
+input+ get dup length phantom-d get phantom-input
swap lazy-load ;
+input+ get
[ length phantom-datastack get phantom-input ] keep
lazy-load ;
: output-vregs ( -- seq seq )
+output+ +clobber+ [ get [ get ] map ] bi@ ;
: clash? ( seq -- ? )
phantoms append [
phantoms [ stack>> ] bi@ append [
dup cached? [ cached-vreg ] when swap member?
] with contains? ;
@ -534,22 +530,21 @@ M: loc lazy-store
: count-input-vregs ( phantom spec -- )
phantom&spec [
>r dup cached? [ cached-vreg ] when r> allocation
>r dup cached? [ cached-vreg ] when r> first allocation
] 2map count-vregs ;
: count-scratch-regs ( spec -- )
[ first reg-spec>class ] map count-vregs ;
: guess-vregs ( dinput rinput scratch -- int# float# )
H{
{ T{ int-regs } 0 }
{ T{ float-regs 8 } 0 }
} clone [
[
0 int-regs set
0 double-float-regs set
count-scratch-regs
phantom-r get swap count-input-vregs
phantom-d get swap count-input-vregs
T{ int-regs } get T{ float-regs 8 } get
] bind ;
phantom-retainstack get swap count-input-vregs
phantom-datastack get swap count-input-vregs
int-regs get double-float-regs get
] with-scope ;
: alloc-scratch ( -- )
+scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
@ -566,7 +561,7 @@ M: loc lazy-store
outputs-clash? [ finalize-contents ] when ;
: template-outputs ( -- )
+output+ get [ get ] map phantom-d get phantom-append ;
+output+ get [ get ] map phantom-datastack get phantom-append ;
: value-matches? ( value spec -- ? )
#! If the spec is a quotation and the value is a literal
@ -581,12 +576,6 @@ M: loc lazy-store
2drop t
] if ;
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
[ drop object tag-number ] when
] map prune ;
: class-tag ( class -- tag/f )
class-tags dup length 1 = [ first ] [ drop f ] if ;
@ -602,7 +591,7 @@ M: loc lazy-store
>r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( spec -- ? )
phantom-d get +input+ rot at
phantom-datastack get +input+ rot at
[ spec-matches? ] phantom&spec-agree? ;
: ensure-template-vregs ( -- )
@ -611,14 +600,14 @@ M: loc lazy-store
] unless ;
: clear-phantoms ( -- )
[ delete-all ] each-phantom ;
[ stack>> delete-all ] each-phantom ;
PRIVATE>
: set-operand-classes ( classes -- )
phantom-d get
phantom-datastack get
over length over add-locs
[ set-operand-class ] 2reverse-each ;
stack>> [ set-operand-class ] 2reverse-each ;
: end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the
@ -627,7 +616,7 @@ PRIVATE>
finalize-contents
clear-phantoms
finalize-heights
fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
: with-template ( quot hash -- )
clone [
@ -647,16 +636,16 @@ PRIVATE>
: init-templates ( -- )
#! Initialize register allocator.
V{ } clone fresh-objects set
<phantom-datastack> phantom-d set
<phantom-retainstack> phantom-r set
<phantom-datastack> phantom-datastack set
<phantom-retainstack> phantom-retainstack set
compute-free-vregs ;
: copy-templates ( -- )
#! Copies register allocator state, used when compiling
#! branches.
fresh-objects [ clone ] change
phantom-d [ clone ] change
phantom-r [ clone ] change
phantom-datastack [ clone ] change
phantom-retainstack [ clone ] change
compute-free-vregs ;
: find-template ( templates -- pair/f )
@ -672,17 +661,17 @@ UNION: immediate fixnum POSTPONE: f ;
operand-class immediate class< ;
: phantom-push ( obj -- )
1 phantom-d get adjust-phantom
phantom-d get push ;
1 phantom-datastack get adjust-phantom
phantom-datastack get stack>> push ;
: phantom-shuffle ( shuffle -- )
[ effect-in length phantom-d get phantom-input ] keep
shuffle* phantom-d get phantom-append ;
[ effect-in length phantom-datastack get phantom-input ] keep
shuffle* phantom-datastack get phantom-append ;
: phantom->r ( n -- )
phantom-d get phantom-input
phantom-r get phantom-append ;
phantom-datastack get phantom-input
phantom-retainstack get phantom-append ;
: phantom-r> ( n -- )
phantom-r get phantom-input
phantom-d get phantom-append ;
phantom-retainstack get phantom-input
phantom-datastack get phantom-append ;

37
core/generic/generic-docs.factor
View File

@ -37,7 +37,8 @@ $nl
{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
{ $subsection methods }
"Finding the most specific method for an object:"
{ $subsection effective-method }
"A generic word contains methods; the list of methods specializing on a class can also be obtained:"
{ $subsection implementors }
"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
@ -63,17 +64,21 @@ ARTICLE: "method-combination" "Custom method combination"
"Developing a custom method combination requires that a parsing word calling " { $link define-generic } " be defined; additionally, it is a good idea to implement the definition protocol words " { $link definer } " and " { $link synopsis* } " on the class of words having this method combination, to properly support developer tools."
$nl
"The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation."
$nl
"Method combination utilities:"
{ $subsection single-combination }
{ $subsection class-predicates }
{ $subsection simplify-alist }
{ $subsection math-upgrade }
{ $subsection object-method }
{ $subsection error-method }
"More quotation construction utilities can be found in " { $link "quotations" } " and " { $link "combinators-quot" } "."
{ $see-also "generic-introspection" } ;
ARTICLE: "call-next-method" "Calling less-specific methods"
"If a generic word is called with an object and multiple methods specialize on classes that this object is an instance of, usually the most specific method is called (" { $link "method-order" } ")."
$nl
"Less-specific methods can be called directly:"
{ $subsection POSTPONE: call-next-method }
"A lower-level word which the above expands into:"
{ $subsection (call-next-method) }
"To look up the next applicable method reflectively:"
{ $subsection next-method }
"Errors thrown by improper calls to " { $link POSTPONE: call-next-method } ":"
{ $subsection inconsistent-next-method }
{ $subsection no-next-method } ;
ARTICLE: "generic" "Generic words and methods"
"A " { $emphasis "generic word" } " is composed of zero or more " { $emphasis "methods" } " together with a " { $emphasis "method combination" } ". A method " { $emphasis "specializes" } " on a class; when a generic word executed, the method combination chooses the most appropriate method and calls its definition."
$nl
@ -91,6 +96,7 @@ $nl
{ $subsection POSTPONE: M: }
"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "."
{ $subsection "method-order" }
{ $subsection "call-next-method" }
{ $subsection "generic-introspection" }
{ $subsection "method-combination" }
"Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ;
@ -129,10 +135,6 @@ HELP: <method>
{ $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
{ $description "Creates a new method." } ;
HELP: methods
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
HELP: order
{ $values { "generic" generic } { "seq" "a sequence of classes" } }
{ $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ;
@ -160,4 +162,9 @@ HELP: forget-methods
{ $values { "class" class } }
{ $description "Remove all method definitions which specialize on the class." } ;
{ sort-classes methods order } related-words
{ sort-classes order } related-words
HELP: (call-next-method)
{ $values { "class" class } { "generic" generic } }
{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;

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

@ -21,19 +21,6 @@ M: word class-of drop "word" ;
[ "Hello world" ] [ 4 foobar foobar ] unit-test
[ "Goodbye cruel world" ] [ 4 foobar ] unit-test
GENERIC: bool>str ( x -- y )
M: general-t bool>str drop "true" ;
M: f bool>str drop "false" ;
: str>bool
H{
{ "true" t }
{ "false" f }
} at ;
[ t ] [ t bool>str str>bool ] unit-test
[ f ] [ f bool>str str>bool ] unit-test
! Testing unions
UNION: funnies quotation float complex ;
@ -51,16 +38,6 @@ M: very-funny gooey sq ;
[ 0.25 ] [ 0.5 gooey ] unit-test
DEFER: complement-test
FORGET: complement-test
GENERIC: complement-test ( x -- y )
M: f complement-test drop "f" ;
M: general-t complement-test drop "general-t" ;
[ "general-t" ] [ 5 complement-test ] unit-test
[ "f" ] [ f complement-test ] unit-test
GENERIC: empty-method-test ( x -- y )
M: object empty-method-test ;
TUPLE: for-arguments-sake ;
@ -171,37 +148,6 @@ M: f tag-and-f 4 ;
[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
! define-class hashing issue
TUPLE: debug-combination ;
M: debug-combination make-default-method
2drop [ "Oops" throw ] ;
M: debug-combination perform-combination
drop
order [ dup class-hashes ] { } map>assoc sort-keys
1quotation ;
SYMBOL: redefinition-test-generic
[
redefinition-test-generic
T{ debug-combination }
define-generic
] with-compilation-unit
TUPLE: redefinition-test-tuple ;
"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
[ t ] [
[
redefinition-test-generic ,
"IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
redefinition-test-generic ,
] { } make all-equal?
] unit-test
! Issues with forget
GENERIC: generic-forget-test-1

77
core/generic/generic.factor
View File

@ -6,16 +6,7 @@ classes.algebra quotations arrays vocabs effects ;
IN: generic
! Method combination protocol
GENERIC: perform-combination ( word combination -- quot )
M: object perform-combination
#! We delay the invalid method combination error for a
#! reason. If we call forget-vocab on a vocabulary which
#! defines a method combination, a generic using this
#! method combination, and a method on the generic, and the
#! method combination is forgotten first, then forgetting
#! the method will throw an error. We don't want that.
nip [ "Invalid method combination" throw ] curry [ ] like ;
GENERIC: perform-combination ( word combination -- )
GENERIC: make-default-method ( generic combination -- method )
@ -25,8 +16,9 @@ PREDICATE: generic < word
M: generic definition drop f ;
: make-generic ( word -- )
dup { "unannotated-def" } reset-props
dup dup "combination" word-prop perform-combination define ;
[ { "unannotated-def" } reset-props ]
[ dup "combination" word-prop perform-combination ]
bi ;
: method ( class generic -- method/f )
"methods" word-prop at ;
@ -37,10 +29,19 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
: methods ( word -- assoc )
"methods" word-prop
[ keys sort-classes ] keep
[ dupd at ] curry { } map>assoc ;
GENERIC: effective-method ( ... generic -- method )
: next-method-class ( class generic -- class/f )
order [ class< ] with subset reverse dup length 1 =
[ drop f ] [ second ] if ;
: next-method ( class generic -- class/f )
[ next-method-class ] keep method ;
GENERIC: next-method-quot ( class generic -- quot )
: (call-next-method) ( class generic -- )
next-method-quot call ;
TUPLE: check-method class generic ;
@ -62,6 +63,9 @@ PREDICATE: method-body < word
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
M: method-body crossref?
drop t ;
: method-word-props ( class generic -- assoc )
[
"method-generic" set
@ -104,14 +108,6 @@ M: method-spec definer
M: method-spec definition
first2 method definition ;
: forget-method ( class generic -- )
dup generic? [
[ delete-at* ] with-methods
[ forget-word ] [ drop ] if
] [
2drop
] if ;
M: method-spec forget*
first2 method forget* ;
@ -120,9 +116,15 @@ M: method-body definer
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
dup "method-class" word-prop
over "method-generic" word-prop forget-method
t "forgotten" set-word-prop
[
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
dup generic? [
[ delete-at* ] with-methods
[ call-next-method ] [ drop ] if
] [ 2drop ] if
]
[ t "forgotten" set-word-prop ] bi
] if ;
: implementors* ( classes -- words )
@ -135,12 +137,13 @@ M: method-body forget*
dup associate implementors* ;
: forget-methods ( class -- )
[ implementors ] keep [ swap 2array ] curry map forget-all ;
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
dup forget-methods
dup update-map-
forget-word ;
[ forget-methods ]
[ update-map- ]
[ call-next-method ]
tri ;
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
@ -156,11 +159,15 @@ M: assoc update-methods ( assoc -- )
] if ;
M: generic subwords
dup "methods" word-prop values
swap "default-method" word-prop suffix ;
[
[ "default-method" word-prop , ]
[ "methods" word-prop values % ]
[ "engines" word-prop % ]
tri
] { } make ;
M: generic forget-word
dup subwords [ forget ] each (forget-word) ;
M: generic forget*
[ subwords forget-all ] [ call-next-method ] bi ;
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;

11
core/generic/math/math.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
sequences.private classes classes.algebra definitions ;
sequences.private classes classes.builtin classes.algebra
definitions ;
IN: generic.math
PREDICATE: math-class < class
@ -12,9 +13,9 @@ PREDICATE: math-class < class
number bootstrap-word class<
] if ;
: last/first ( seq -- pair ) dup peek swap first 2array ;
: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
: math-precedence ( class -- n )
: math-precedence ( class -- pair )
{
{ [ dup null class< ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
@ -71,13 +72,15 @@ M: math-combination make-default-method
M: math-combination perform-combination
drop
dup
\ over [
dup math-class? [
\ dup [ >r 2dup r> math-method ] math-vtable
] [
over object-method
] if nip
] math-vtable nip ;
] math-vtable nip
define ;
PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;

49
core/generic/standard/engines/engines.factor Normal file
View File

@ -0,0 +1,49 @@
USING: assocs kernel namespaces quotations generic math
sequences combinators words classes.algebra ;
IN: generic.standard.engines
SYMBOL: default
SYMBOL: assumed
GENERIC: engine>quot ( engine -- quot )
M: quotation engine>quot ;
M: method-body engine>quot 1quotation ;
: engines>quots ( assoc -- assoc' )
[ engine>quot ] assoc-map ;
: engines>quots* ( assoc -- assoc' )
[ over assumed [ engine>quot ] with-variable ] assoc-map ;
: if-small? ( assoc true false -- )
>r >r dup assoc-size 4 <= r> r> if ; inline
: linear-dispatch-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
alist>quot ;
: split-methods ( assoc class -- first second )
[ [ nip class< not ] curry assoc-subset ]
[ [ nip class< ] curry assoc-subset ] 2bi ;
: convert-methods ( assoc class word -- assoc' )
over >r >r split-methods dup assoc-empty? [
r> r> 3drop
] [
r> execute r> pick set-at
] if ; inline
SYMBOL: (dispatch#)
: (picker) ( n -- quot )
{
{ 0 [ [ dup ] ] }
{ 1 [ [ over ] ] }
{ 2 [ [ pick ] ] }
[ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
} case ;
: picker ( -- quot ) \ (dispatch#) get (picker) ;

32
core/generic/standard/engines/predicate/predicate.factor Normal file
View File

@ -0,0 +1,32 @@
USING: generic.standard.engines generic namespaces kernel
sequences classes.algebra accessors words combinators
assocs ;
IN: generic.standard.engines.predicate
TUPLE: predicate-dispatch-engine methods ;
C: <predicate-dispatch-engine> predicate-dispatch-engine
: class-predicates ( assoc -- assoc )
[ >r "predicate" word-prop picker prepend r> ] assoc-map ;
: keep-going? ( assoc -- ? )
assumed get swap second first class< ;
: prune-redundant-predicates ( assoc -- default assoc' )
{
{ [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
{ [ t ] [ [ first second ] [ 1 tail-slice ] bi ] }
} cond ;
: sort-methods ( assoc -- assoc' )
[ keys sort-classes ]
[ [ dupd at ] curry ] bi { } map>assoc ;
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 ;

57
core/generic/standard/engines/tag/tag.factor Normal file
View File

@ -0,0 +1,57 @@
USING: classes.private generic.standard.engines namespaces
arrays assocs sequences.private quotations kernel.private
math slots.private math.private kernel accessors words
layouts ;
IN: generic.standard.engines.tag
TUPLE: lo-tag-dispatch-engine methods ;
C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
: direct-dispatch-quot ( alist n -- quot )
default get <array>
[ <enum> swap update ] keep
[ dispatch ] curry >quotation ;
: lo-tag-number ( class -- n )
dup \ hi-tag bootstrap-word eq? [
drop \ hi-tag tag-number
] [
"type" word-prop
] if ;
M: lo-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
[
picker % [ tag ] % [
linear-dispatch-quot
] [
num-tags get direct-dispatch-quot
] if-small? %
] [ ] make ;
TUPLE: hi-tag-dispatch-engine methods ;
C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
: convert-hi-tag-methods ( assoc -- assoc' )
\ hi-tag bootstrap-word
\ <hi-tag-dispatch-engine> convert-methods ;
: num-hi-tags num-types get num-tags get - ;
: hi-tag-number ( class -- n )
"type" word-prop num-tags get - ;
: hi-tag-quot ( -- quot )
[ hi-tag ] num-tags get [ fixnum-fast ] curry compose ;
M: hi-tag-dispatch-engine engine>quot
methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
[
picker % hi-tag-quot % [
linear-dispatch-quot
] [
num-hi-tags direct-dispatch-quot
] if-small? %
] [ ] make ;

128
core/generic/standard/engines/tuple/tuple.factor Normal file
View File

@ -0,0 +1,128 @@
IN: generic.standard.engines.tuple
USING: kernel classes.tuple.private hashtables assocs sorting
accessors combinators sequences slots.private math.parser words
effects namespaces generic generic.standard.engines
classes.algebra math math.private quotations arrays ;
TUPLE: echelon-dispatch-engine n methods ;
C: <echelon-dispatch-engine> echelon-dispatch-engine
TUPLE: trivial-tuple-dispatch-engine methods ;
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>
[ ?set-at ] change-at ;
: echelon-sort ( assoc -- assoc' )
V{ } clone [
[
push-echelon
] curry assoc-each
] keep sort-keys ;
: <tuple-dispatch-engine> ( methods -- engine )
echelon-sort
[
over zero? [
dup assoc-empty?
[ drop f ] [ values first ] if
] [
dupd <echelon-dispatch-engine>
] if
] assoc-map [ nip ] assoc-subset
\ tuple-dispatch-engine construct-boa ;
: convert-tuple-methods ( assoc -- assoc' )
tuple bootstrap-word
\ <tuple-dispatch-engine> convert-methods ;
M: trivial-tuple-dispatch-engine engine>quot
methods>> engines>quots* linear-dispatch-quot ;
: hash-methods ( methods -- buckets )
>alist V{ } clone [ hashcode 1array ] distribute-buckets
[ <trivial-tuple-dispatch-engine> ] map ;
: class-hash-dispatch-quot ( methods -- quot )
#! 1 slot == word hashcode
[
[ dup 1 slot ] %
hash-methods [ engine>quot ] map hash-dispatch-quot %
] [ ] make ;
: tuple-dispatch-engine-word-name ( engine -- string )
[
generic get word-name %
"/tuple-dispatch-engine/" %
n>> #
] "" make ;
PREDICATE: tuple-dispatch-engine-word < word
"tuple-dispatch-engine" word-prop ;
M: tuple-dispatch-engine-word stack-effect
"tuple-dispatch-generic" word-prop stack-effect ;
M: tuple-dispatch-engine-word crossref?
drop t ;
: remember-engine ( word -- )
generic get "engines" word-prop push ;
: <tuple-dispatch-engine-word> ( engine -- word )
tuple-dispatch-engine-word-name f <word>
{
[ t "tuple-dispatch-engine" set-word-prop ]
[ generic get "tuple-dispatch-generic" set-word-prop ]
[ remember-engine ]
[ ]
} cleave ;
: define-tuple-dispatch-engine-word ( engine quot -- word )
>r <tuple-dispatch-engine-word> dup r> define ;
: tuple-dispatch-engine-body ( engine -- quot )
#! 1 slot == tuple-layout
#! 2 slot == 0 array-nth
#! 4 slot == layout-superclasses
[
picker %
[ 1 slot 4 slot ] %
[ n>> 2 + , [ slot ] % ]
[
methods>> [
<trivial-tuple-dispatch-engine> engine>quot
] [
class-hash-dispatch-quot
] if-small? %
] bi
] [ ] make ;
M: echelon-dispatch-engine engine>quot
dup tuple-dispatch-engine-body
define-tuple-dispatch-engine-word
1quotation ;
: >=-case-quot ( alist -- quot )
default get [ drop ] prepend swap
[ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
alist>quot ;
M: tuple-dispatch-engine engine>quot
#! 1 slot == tuple-layout
#! 5 slot == layout-echelon
[
picker %
[ 1 slot 5 slot ] %
echelons>>
[
tuple assumed set
[ engine>quot dup default set ] assoc-map
] with-scope
>=-case-quot %
] [ ] make ;

40
core/generic/standard/standard-docs.factor
View File

@ -1,4 +1,5 @@
USING: generic help.markup help.syntax sequences ;
USING: generic help.markup help.syntax sequences math
math.parser ;
IN: generic.standard
HELP: no-method
@ -10,7 +11,7 @@ HELP: standard-combination
{ $class-description
"Performs standard method combination."
$nl
"Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. If no suitable method is defined on the class of the dispatch object, the generic word is called on the dispatch object's delegate. If the delegate is " { $link f } ", an exception is thrown."
"Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. A " { $link no-method } " error is thrown if no suitable method is defined on the class."
}
{ $examples
"A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
@ -31,3 +32,38 @@ HELP: define-simple-generic
{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
{ standard-combination hook-combination } related-words
HELP: no-next-method
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
{ $examples
"The following code throws this error:"
{ $code
"GENERIC: error-test ( object -- )"
""
"M: number error-test 3 + call-next-method ;"
""
"M: integer error-test recip call-next-method ;"
""
"123 error-test"
}
"This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
} ;
HELP: inconsistent-next-method
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
{ $examples
"The following code throws this error:"
{ $code
"GENERIC: error-test ( object -- )"
""
"M: string error-test print ;"
""
"M: integer error-test number>string call-next-method ;"
""
"123 error-test"
}
"This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
$nl
"This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
{ $code "M: integer error-test number>string error-test ;" }
} ;

235
core/generic/standard/standard-tests.factor Normal file
View File

@ -0,0 +1,235 @@
IN: generic.standard.tests
USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces ;
GENERIC: lo-tag-test
M: integer lo-tag-test 3 + ;
M: float lo-tag-test 4 - ;
M: rational lo-tag-test 2 - ;
M: complex lo-tag-test sq ;
[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
GENERIC: hi-tag-test
M: string hi-tag-test ", in bed" append ;
M: integer hi-tag-test 3 + ;
M: array hi-tag-test [ hi-tag-test ] map ;
M: sequence hi-tag-test reverse ;
[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
TUPLE: shape ;
TUPLE: abstract-rectangle < shape width height ;
TUPLE: rectangle < abstract-rectangle ;
C: <rectangle> rectangle
TUPLE: parallelogram < abstract-rectangle skew ;
C: <parallelogram> parallelogram
TUPLE: circle < shape radius ;
C: <circle> circle
GENERIC: area
M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
M: circle area radius>> sq pi * ;
[ 12 ] [ 4 3 <rectangle> area ] unit-test
[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
[ t ] [ 2 <circle> area 4 pi * = ] unit-test
GENERIC: perimiter
: rectangle-perimiter + 2 * ;
M: rectangle perimiter
[ width>> ] [ height>> ] bi
rectangle-perimiter ;
: hypotenuse [ sq ] bi@ + sqrt ;
M: parallelogram perimiter
[ width>> ]
[ [ height>> ] [ skew>> ] bi hypotenuse ] bi
rectangle-perimiter ;
M: circle perimiter 2 * pi * ;
[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
GENERIC: big-mix-test
M: object big-mix-test drop "object" ;
M: tuple big-mix-test drop "tuple" ;
M: integer big-mix-test drop "integer" ;
M: float big-mix-test drop "float" ;
M: complex big-mix-test drop "complex" ;
M: string big-mix-test drop "string" ;
M: array big-mix-test drop "array" ;
M: sequence big-mix-test drop "sequence" ;
M: rectangle big-mix-test drop "rectangle" ;
M: parallelogram big-mix-test drop "parallelogram" ;
M: circle big-mix-test drop "circle" ;
[ "integer" ] [ 3 big-mix-test ] unit-test
[ "float" ] [ 5.0 big-mix-test ] unit-test
[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
[ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test
[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
[ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test
[ "string" ] [ "hello" big-mix-test ] unit-test
[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
[ "tuple" ] [ H{ } big-mix-test ] unit-test
[ "object" ] [ \ + big-mix-test ] unit-test
GENERIC: small-lo-tag
M: fixnum small-lo-tag drop "fixnum" ;
M: string small-lo-tag drop "string" ;
M: array small-lo-tag drop "array" ;
M: float-array small-lo-tag drop "float-array" ;
M: byte-array small-lo-tag drop "byte-array" ;
[ "fixnum" ] [ 3 small-lo-tag ] unit-test
[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test
! Testing next-method
TUPLE: person ;
TUPLE: intern < person ;
TUPLE: employee < person ;
TUPLE: tape-monkey < employee ;
TUPLE: manager < employee ;
TUPLE: junior-manager < manager ;
TUPLE: middle-manager < manager ;
TUPLE: senior-manager < manager ;
TUPLE: executive < senior-manager ;
TUPLE: ceo < executive ;
GENERIC: salary ( person -- n )
M: intern salary
#! Intentional mistake.
call-next-method ;
M: employee salary drop 24000 ;
M: manager salary call-next-method 12000 + ;
M: middle-manager salary call-next-method 5000 + ;
M: senior-manager salary call-next-method 15000 + ;
M: executive salary call-next-method 2 * ;
M: ceo salary
#! Intentional error.
drop 5 call-next-method 3 * ;
[ salary ] must-infer
[ 24000 ] [ employee construct-boa salary ] unit-test
[ 24000 ] [ tape-monkey construct-boa salary ] unit-test
[ 36000 ] [ junior-manager construct-boa salary ] unit-test
[ 41000 ] [ middle-manager construct-boa salary ] unit-test
[ 51000 ] [ senior-manager construct-boa salary ] unit-test
[ 102000 ] [ executive construct-boa salary ] unit-test
[ ceo construct-boa salary ]
[ T{ inconsistent-next-method f 5 ceo salary } = ] must-fail-with
[ intern construct-boa salary ]
[ T{ no-next-method f intern salary } = ] must-fail-with
! Weird shit
TUPLE: a ;
TUPLE: b ;
TUPLE: c ;
UNION: x a b ;
UNION: y a c ;
UNION: z x y ;
GENERIC: funky* ( obj -- )
M: z funky* "z" , drop ;
M: x funky* "x" , call-next-method ;
M: y funky* "y" , call-next-method ;
M: a funky* "a" , call-next-method ;
M: b funky* "b" , call-next-method ;
M: c funky* "c" , call-next-method ;
: funky [ funky* ] { } make ;
[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
[ t ] [
T{ a } funky
{ { "a" "x" "z" } { "a" "y" "z" } } member?
] unit-test

262
core/generic/standard/standard.factor Executable file → Normal file
View File

@ -3,32 +3,27 @@
USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions
hashtables layouts combinators sequences.private generic
classes classes.algebra classes.private ;
classes classes.algebra classes.private generic.standard.engines
generic.standard.engines.tag generic.standard.engines.predicate
generic.standard.engines.tuple accessors ;
IN: generic.standard
TUPLE: standard-combination # ;
GENERIC: dispatch# ( word -- n )
C: <standard-combination> standard-combination
M: word dispatch# "combination" word-prop dispatch# ;
SYMBOL: (dispatch#)
: (picker) ( n -- quot )
: unpickers
{
{ 0 [ [ dup ] ] }
{ 1 [ [ over ] ] }
{ 2 [ [ pick ] ] }
[ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
} case ;
: picker ( -- quot ) \ (dispatch#) get (picker) ;
: unpickers { [ nip ] [ >r nip r> swap ] [ >r >r nip r> r> -rot ] } ; inline
[ nip ]
[ >r nip r> swap ]
[ >r >r nip r> r> -rot ]
} ; inline
: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
ERROR: no-method object generic ;
: error-method ( word -- quot )
: error-method ( word -- quot )
picker swap [ no-method ] curry append ;
: empty-method ( word -- quot )
@ -38,159 +33,138 @@ ERROR: no-method object generic ;
error-method \ drop prefix , \ if ,
] [ ] make ;
: class-predicates ( assoc -- assoc )
[
>r >r picker r> "predicate" word-prop append r>
] assoc-map ;
: (simplify-alist) ( class i assoc -- default assoc )
2dup length 1- = [
nth second { } rot drop
] [
3dup >r 1+ r> nth first class< [
>r 1+ r> (simplify-alist)
] [
[ nth second ] 2keep swap 1+ tail rot drop
] if
] if ;
: simplify-alist ( class assoc -- default assoc )
dup empty? [
2drop [ "Unreachable" throw ] { }
] [
0 swap (simplify-alist)
] if ;
: default-method ( word -- pair )
"default-method" word-prop
object bootstrap-word swap 2array ;
: method-alist>quot ( alist base-class -- quot )
bootstrap-word swap simplify-alist
class-predicates alist>quot ;
: small-generic ( methods -- def )
object method-alist>quot ;
: hash-methods ( methods -- buckets )
V{ } clone [
tuple bootstrap-word over class< [
drop t
] [
class-hashes
] if
] distribute-buckets ;
: class-hash-dispatch-quot ( methods quot picker -- quot )
>r >r hash-methods r> map
hash-dispatch-quot r> [ class-hash ] rot 3append ; inline
: big-generic ( methods -- quot )
[ small-generic ] picker class-hash-dispatch-quot ;
: vtable-class ( n -- class )
bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
: group-methods ( assoc -- vtable )
#! Input is a predicate -> method association.
#! n is vtable size (either num-types or num-tags).
num-tags get [
vtable-class
[ swap first classes-intersect? ] curry subset
] with map ;
: build-type-vtable ( alist-seq -- alist-seq )
dup length [
vtable-class
swap simplify-alist
class-predicates alist>quot
] 2map ;
: tag-generic ( methods -- quot )
: push-method ( method specializer atomic assoc -- )
[
picker %
\ tag ,
group-methods build-type-vtable ,
\ dispatch ,
] [ ] make ;
[ H{ } clone <predicate-dispatch-engine> ] unless*
[ methods>> set-at ] keep
] change-at ;
: flatten-method ( class body -- )
over members pick object bootstrap-word eq? not and [
>r members r> [ flatten-method ] curry each
] [
swap set
] if ;
: flatten-method ( class method assoc -- )
>r >r dup flatten-class keys swap r> r> [
>r spin r> push-method
] 3curry each ;
: flatten-methods ( methods -- newmethods )
[ [ flatten-method ] assoc-each ] V{ } make-assoc ;
: flatten-methods ( assoc -- assoc' )
H{ } clone [
[
flatten-method
] curry assoc-each
] keep ;
: dispatched-types ( methods -- seq )
keys object bootstrap-word swap remove prune ;
: <big-dispatch-engine> ( assoc -- engine )
flatten-methods
convert-tuple-methods
convert-hi-tag-methods
<lo-tag-dispatch-engine> ;
: single-combination ( methods -- quot )
dup length 4 <= [
small-generic
] [
flatten-methods
dup dispatched-types [ number class< ] all?
[ tag-generic ] [ big-generic ] if
] if ;
: find-default ( methods -- quot )
#! Side-effects methods.
object bootstrap-word swap delete-at* [
drop generic get "default-method" word-prop 1quotation
] unless ;
: standard-methods ( word -- alist )
dup methods swap default-method prefix
[ 1quotation ] assoc-map ;
GENERIC: mangle-method ( method generic -- quot )
M: standard-combination make-default-method
standard-combination-# (dispatch#)
[ empty-method ] with-variable ;
M: standard-combination perform-combination
standard-combination-# (dispatch#) [
[ standard-methods ] keep "inline" word-prop
[ small-generic ] [ single-combination ] if
] with-variable ;
TUPLE: hook-combination var ;
C: <hook-combination> hook-combination
: with-hook ( combination quot -- quot' )
0 (dispatch#) [
swap slip
hook-combination-var [ get ] curry
prepend
] with-variable ; inline
M: hook-combination make-default-method
[ error-method ] with-hook ;
M: hook-combination perform-combination
: single-combination ( word -- quot )
[
standard-methods
[ [ drop ] prepend ] assoc-map
single-combination
] with-hook ;
object bootstrap-word assumed set {
[ generic set ]
[ "engines" word-prop forget-all ]
[ V{ } clone "engines" set-word-prop ]
[
"methods" word-prop
[ generic get mangle-method ] assoc-map
[ find-default default set ]
[
generic get "inline" word-prop [
<predicate-dispatch-engine>
] [
<big-dispatch-engine>
] if
] bi
engine>quot
]
} cleave
] with-scope ;
: define-simple-generic ( word -- )
T{ standard-combination f 0 } define-generic ;
TUPLE: standard-combination # ;
C: <standard-combination> standard-combination
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
PREDICATE: simple-generic < standard-generic
"combination" word-prop standard-combination-# zero? ;
"combination" word-prop #>> zero? ;
: define-simple-generic ( word -- )
T{ standard-combination f 0 } define-generic ;
: with-standard ( combination quot -- quot' )
>r #>> (dispatch#) r> with-variable ; inline
M: standard-generic mangle-method
drop 1quotation ;
M: standard-combination make-default-method
[ empty-method ] with-standard ;
M: standard-combination perform-combination
[ drop ] [ [ single-combination ] with-standard ] 2bi define ;
M: standard-combination dispatch# #>> ;
M: standard-generic effective-method
[ dispatch# (picker) call ] keep
[ order [ instance? ] with find-last nip ] keep method ;
ERROR: inconsistent-next-method object class generic ;
ERROR: no-next-method class generic ;
M: standard-generic next-method-quot
[
[
[ [ instance? ] curry ]
[ dispatch# (picker) ] bi* prepend %
]
[
2dup next-method
[ 2nip 1quotation ]
[ [ no-next-method ] 2curry ] if* ,
]
[ [ inconsistent-next-method ] 2curry , ]
2tri
\ if ,
] [ ] make ;
TUPLE: hook-combination var ;
C: <hook-combination> hook-combination
PREDICATE: hook-generic < generic
"combination" word-prop hook-combination? ;
GENERIC: dispatch# ( word -- n )
M: word dispatch# "combination" word-prop dispatch# ;
M: standard-combination dispatch# standard-combination-# ;
: with-hook ( combination quot -- quot' )
0 (dispatch#) [
dip var>> [ get ] curry prepend
] with-variable ; inline
M: hook-combination dispatch# drop 0 ;
M: hook-generic mangle-method
drop 1quotation [ drop ] prepend ;
M: hook-combination make-default-method
[ error-method ] with-hook ;
M: hook-combination perform-combination
[ drop ] [ [ single-combination ] with-hook ] 2bi define ;
M: simple-generic definer drop \ GENERIC: f ;
M: standard-generic definer drop \ GENERIC# f ;

9
core/heaps/heaps-tests.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting ;
heaps heaps.private math.parser random assocs sequences sorting
accessors ;
IN: heaps.tests
[ <min-heap> heap-pop ] must-fail
@ -47,7 +48,7 @@ IN: heaps.tests
: test-entry-indices ( n -- ? )
random-alist
<min-heap> [ heap-push-all ] keep
heap-data dup length swap [ entry-index ] map sequence= ;
data>> dup length swap [ entry-index ] map sequence= ;
14 [
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
@ -63,9 +64,9 @@ IN: heaps.tests
[
random-alist
<min-heap> [ heap-push-all ] keep
dup heap-data clone swap
dup data>> clone swap
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
heap-data
data>>
[ [ entry-key ] map ] bi@
[ natural-sort ] bi@ ;

26
core/heaps/heaps.factor
View File

@ -17,10 +17,10 @@ GENERIC: heap-size ( heap -- n )
<PRIVATE
: heap-data delegate ; inline
TUPLE: heap data ;
: <heap> ( class -- heap )
>r V{ } clone r> construct-delegate ; inline
>r V{ } clone r> construct-boa ; inline
TUPLE: entry value key heap index ;
@ -28,11 +28,11 @@ TUPLE: entry value key heap index ;
PRIVATE>
TUPLE: min-heap ;
TUPLE: min-heap < heap ;
: <min-heap> ( -- min-heap ) min-heap <heap> ;
TUPLE: max-heap ;
TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ;
@ -40,10 +40,10 @@ INSTANCE: min-heap priority-queue
INSTANCE: max-heap priority-queue
M: priority-queue heap-empty? ( heap -- ? )
heap-data empty? ;
data>> empty? ;
M: priority-queue heap-size ( heap -- n )
heap-data length ;
data>> length ;
<PRIVATE
@ -54,7 +54,7 @@ M: priority-queue heap-size ( heap -- n )
: up ( n -- m ) 1- 2/ ; inline
: data-nth ( n heap -- entry )
heap-data nth-unsafe ; inline
data>> nth-unsafe ; inline
: up-value ( n heap -- entry )
>r up r> data-nth ; inline
@ -67,24 +67,24 @@ M: priority-queue heap-size ( heap -- n )
: data-set-nth ( entry n heap -- )
>r [ swap set-entry-index ] 2keep r>
heap-data set-nth-unsafe ;
data>> set-nth-unsafe ;
: data-push ( entry heap -- n )
dup heap-size [
swap 2dup heap-data ensure 2drop data-set-nth
swap 2dup data>> ensure 2drop data-set-nth
] keep ; inline
: data-pop ( heap -- entry )
heap-data pop ; inline
data>> pop ; inline
: data-pop* ( heap -- )
heap-data pop* ; inline
data>> pop* ; inline
: data-peek ( heap -- entry )
heap-data peek ; inline
data>> peek ; inline
: data-first ( heap -- entry )
heap-data first ; inline
data>> first ; inline
: data-exchange ( m n heap -- )
[ tuck data-nth >r data-nth r> ] 3keep

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

@ -3,14 +3,23 @@
USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors ;
continuations debugger assocs combinators compiler.errors
generic.standard.engines.tuple accessors ;
IN: inference.backend
: recursive-label ( word -- label/f )
recursive-state get at ;
: inline? ( word -- ? )
dup "method-generic" word-prop swap or "inline" word-prop ;
GENERIC: inline? ( word -- ? )
M: method-body inline?
"method-generic" word-prop inline? ;
M: tuple-dispatch-engine-word inline?
"tuple-dispatch-generic" word-prop inline? ;
M: word inline?
"inline" word-prop ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys
@ -23,18 +32,14 @@ IN: inference.backend
: recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] with contains? ;
TUPLE: inference-error rstate type ;
TUPLE: inference-error error type rstate ;
M: inference-error compiler-error-type
inference-error-type ;
M: inference-error compiler-error-type type>> ;
: (inference-error) ( ... class type -- * )
>r construct-boa r>
recursive-state get {
set-delegate
set-inference-error-type
set-inference-error-rstate
} \ inference-error construct throw ; inline
recursive-state get
\ inference-error construct-boa throw ; inline
: inference-error ( ... class -- * )
+error+ (inference-error) ; inline

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

@ -21,7 +21,7 @@ GENERIC: mynot ( x -- y )
M: f mynot drop t ;
M: general-t mynot drop f ;
M: object mynot drop f ;
GENERIC: detect-f ( x -- y )
@ -120,7 +120,7 @@ M: object xyz ;
[
[ no-cond ] 1
[ 1array dup quotation? [ >quotation ] unless ] times
] \ type inlined?
] \ quotation? inlined?
] unit-test
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
@ -233,6 +233,20 @@ M: fixnum annotate-entry-test-1 drop ;
\ >float inlined?
] unit-test
GENERIC: detect-float ( a -- b )
M: float detect-float ;
[ t ] [
[ { real float } declare + detect-float ]
\ detect-float inlined?
] unit-test
[ t ] [
[ { float real } declare + detect-float ]
\ detect-float inlined?
] unit-test
[ t ] [
[ 3 + = ] \ equal? inlined?
] unit-test
@ -297,3 +311,15 @@ cell-bits 32 = [
[ t ] [
[ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
] unit-test
[ t ] [
[
dup integer? [
dup fixnum? [
1 +
] [
2 +
] if
] when
] \ + inlined?
] unit-test

48
core/inference/class/class.factor
View File

@ -176,9 +176,18 @@ M: pair constraint-satisfied?
: predicate-constraints ( class #call -- )
[
0 `input class,
general-t 0 `output class,
] set-constraints ;
! If word outputs true, input is an instance of class
[
0 `input class,
\ f class-not 0 `output class,
] set-constraints
] [
! If word outputs false, input is not an instance of class
[
class-not 0 `input class,
\ f 0 `output class,
] set-constraints
] 2bi ;
: compute-constraints ( #call -- )
dup node-param "constraints" word-prop [
@ -209,7 +218,7 @@ M: #push infer-classes-before
M: #if child-constraints
[
general-t 0 `input class,
\ f class-not 0 `input class,
f 0 `input literal,
] make-constraints ;
@ -265,7 +274,7 @@ DEFER: (infer-classes)
(merge-intervals) r> set-intervals ;
: annotate-merge ( nodes #merge/#entry -- )
2dup merge-classes merge-intervals ;
[ merge-classes ] [ merge-intervals ] 2bi ;
: merge-children ( node -- )
dup node-successor dup #merge? [
@ -281,28 +290,31 @@ DEFER: (infer-classes)
M: #label infer-classes-before ( #label -- )
#! First, infer types under the hypothesis which hold on
#! entry to the recursive label.
dup 1array swap annotate-entry ;
[ 1array ] keep annotate-entry ;
M: #label infer-classes-around ( #label -- )
#! Now merge the types at every recursion point with the
#! entry types.
dup annotate-node
dup infer-classes-before
dup infer-children
dup collect-recursion over suffix
pick annotate-entry
node-child (infer-classes) ;
{
[ annotate-node ]
[ infer-classes-before ]
[ infer-children ]
[ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
[ node-child (infer-classes) ]
} cleave ;
M: object infer-classes-around
dup infer-classes-before
dup annotate-node
dup infer-children
merge-children ;
{
[ infer-classes-before ]
[ annotate-node ]
[ infer-children ]
[ merge-children ]
} cleave ;
: (infer-classes) ( node -- )
[
dup infer-classes-around
node-successor (infer-classes)
[ infer-classes-around ]
[ node-successor (infer-classes) ] bi
] when* ;
: infer-classes-with ( node classes literals intervals -- )

158
core/inference/dataflow/dataflow.factor
View File

@ -2,22 +2,20 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
inference.state ;
inference.state accessors combinators ;
IN: inference.dataflow
! Computed value
: <computed> \ <computed> counter ;
! Literal value
TUPLE: value literal uid recursion ;
TUPLE: value < identity-tuple literal uid recursion ;
: <value> ( obj -- value )
<computed> recursive-state get value construct-boa ;
M: value hashcode* nip value-uid ;
M: value equal? 2drop f ;
! Result of curry
TUPLE: curried obj quot ;
@ -30,24 +28,23 @@ C: <composed> composed
UNION: special curried composed ;
TUPLE: node param
TUPLE: node < identity-tuple
param
in-d out-d in-r out-r
classes literals intervals
history successor children ;
M: node equal? 2drop f ;
M: node hashcode* drop node hashcode* ;
GENERIC: flatten-curry ( value -- )
M: curried flatten-curry
dup curried-obj flatten-curry
curried-quot flatten-curry ;
[ obj>> flatten-curry ]
[ quot>> flatten-curry ] bi ;
M: composed flatten-curry
dup composed-quot1 flatten-curry
composed-quot2 flatten-curry ;
[ quot1>> flatten-curry ]
[ quot2>> flatten-curry ] bi ;
M: object flatten-curry , ;
@ -60,31 +57,27 @@ M: object flatten-curry , ;
meta-d get clone flatten-curries ;
: modify-values ( node quot -- )
[ swap [ node-in-d swap call ] keep set-node-in-d ] 2keep
[ swap [ node-in-r swap call ] keep set-node-in-r ] 2keep
[ swap [ node-out-d swap call ] keep set-node-out-d ] 2keep
swap [ node-out-r swap call ] keep set-node-out-r ; inline
{
[ change-in-d ]
[ change-in-r ]
[ change-out-d ]
[ change-out-r ]
} cleave drop ; inline
: node-shuffle ( node -- shuffle )
dup node-in-d swap node-out-d <effect> ;
: make-node ( slots class -- node )
>r node construct r> construct-delegate ; inline
: empty-node ( class -- node )
{ } swap make-node ; inline
[ in-d>> ] [ out-d>> ] bi <effect> ;
: param-node ( param class -- node )
{ set-node-param } swap make-node ; inline
construct-empty swap >>param ; inline
: in-node ( seq class -- node )
{ set-node-in-d } swap make-node ; inline
construct-empty swap >>in-d ; inline
: all-in-node ( class -- node )
flatten-meta-d swap in-node ; inline
: out-node ( seq class -- node )
{ set-node-out-d } swap make-node ; inline
construct-empty swap >>out-d ; inline
: all-out-node ( class -- node )
flatten-meta-d swap out-node ; inline
@ -97,81 +90,81 @@ M: object flatten-curry , ;
: node-child node-children first ;
TUPLE: #label word loop? ;
TUPLE: #label < node word loop? ;
: #label ( word label -- node )
\ #label param-node [ set-#label-word ] keep ;
\ #label param-node swap >>word ;
PREDICATE: #loop < #label #label-loop? ;
TUPLE: #entry ;
TUPLE: #entry < node ;
: #entry ( -- node ) \ #entry all-out-node ;
TUPLE: #call ;
TUPLE: #call < node ;
: #call ( word -- node ) \ #call param-node ;
TUPLE: #call-label ;
TUPLE: #call-label < node ;
: #call-label ( label -- node ) \ #call-label param-node ;
TUPLE: #push ;
TUPLE: #push < node ;
: #push ( -- node ) \ #push empty-node ;
: #push ( -- node ) \ #push construct-empty ;
TUPLE: #shuffle ;
TUPLE: #shuffle < node ;
: #shuffle ( -- node ) \ #shuffle empty-node ;
: #shuffle ( -- node ) \ #shuffle construct-empty ;
TUPLE: #>r ;
TUPLE: #>r < node ;
: #>r ( -- node ) \ #>r empty-node ;
: #>r ( -- node ) \ #>r construct-empty ;
TUPLE: #r> ;
TUPLE: #r> < node ;
: #r> ( -- node ) \ #r> empty-node ;
: #r> ( -- node ) \ #r> construct-empty ;
TUPLE: #values ;
TUPLE: #values < node ;
: #values ( -- node ) \ #values all-in-node ;
TUPLE: #return ;
TUPLE: #return < node ;
: #return ( label -- node )
\ #return all-in-node [ set-node-param ] keep ;
\ #return all-in-node swap >>param ;
TUPLE: #if ;
TUPLE: #branch < node ;
TUPLE: #if < #branch ;
: #if ( -- node ) peek-d 1array \ #if in-node ;
TUPLE: #dispatch ;
TUPLE: #dispatch < #branch ;
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
TUPLE: #merge ;
TUPLE: #merge < node ;
: #merge ( -- node ) \ #merge all-out-node ;
TUPLE: #terminate ;
TUPLE: #terminate < node ;
: #terminate ( -- node ) \ #terminate empty-node ;
: #terminate ( -- node ) \ #terminate construct-empty ;
TUPLE: #declare ;
TUPLE: #declare < node ;
: #declare ( classes -- node ) \ #declare param-node ;
UNION: #branch #if #dispatch ;
: node-inputs ( d-count r-count node -- )
tuck
>r r-tail flatten-curries r> set-node-in-r
>r d-tail flatten-curries r> set-node-in-d ;
[ swap d-tail flatten-curries >>in-d drop ]
[ swap r-tail flatten-curries >>in-r drop ] 2bi* ;
: node-outputs ( d-count r-count node -- )
tuck
>r r-tail flatten-curries r> set-node-out-r
>r d-tail flatten-curries r> set-node-out-d ;
[ swap d-tail flatten-curries >>out-d drop ]
[ swap r-tail flatten-curries >>out-r drop ] 2bi* ;
: node, ( node -- )
dataflow-graph get [
@ -181,17 +174,15 @@ UNION: #branch #if #dispatch ;
] if ;
: node-values ( node -- values )
dup node-in-d
over node-out-d
pick node-in-r
roll node-out-r 4array concat ;
{ [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
4array concat ;
: last-node ( node -- last )
dup node-successor [ last-node ] [ ] ?if ;
dup successor>> [ last-node ] [ ] ?if ;
: penultimate-node ( node -- penultimate )
dup node-successor dup [
dup node-successor
dup successor>> dup [
dup successor>>
[ nip penultimate-node ] [ drop ] if
] [
2drop f
@ -205,7 +196,7 @@ UNION: #branch #if #dispatch ;
2dup 2slip rot [
2drop t
] [
>r dup node-children swap node-successor suffix r>
>r [ children>> ] [ successor>> ] bi suffix r>
[ node-exists? ] curry contains?
] if
] [
@ -216,13 +207,13 @@ GENERIC: calls-label* ( label node -- ? )
M: node calls-label* 2drop f ;
M: #call-label calls-label* node-param eq? ;
M: #call-label calls-label* param>> eq? ;
: calls-label? ( label node -- ? )
[ calls-label* ] with node-exists? ;
: recursive-label? ( node -- ? )
dup node-param swap calls-label? ;
[ param>> ] keep calls-label? ;
SYMBOL: node-stack
@ -230,7 +221,7 @@ SYMBOL: node-stack
: node> node-stack get pop ;
: node@ node-stack get peek ;
: iterate-next ( -- node ) node@ node-successor ;
: iterate-next ( -- node ) node@ successor>> ;
: iterate-nodes ( node quot -- )
over [
@ -258,54 +249,55 @@ SYMBOL: node-stack
] iterate-nodes drop
] with-node-iterator ; inline
: change-children ( node quot -- )
: map-children ( node quot -- )
over [
>r dup node-children dup r>
[ map swap set-node-children ] curry
[ 2drop ] if
over children>> [
[ map ] curry change-children drop
] [
2drop
] if
] [
2drop
] if ; inline
: (transform-nodes) ( prev node quot -- )
dup >r call dup [
dup rot set-node-successor
dup node-successor r> (transform-nodes)
>>successor
successor>> dup successor>>
r> (transform-nodes)
] [
r> drop f swap set-node-successor drop
r> 2drop f >>successor drop
] if ; inline
: transform-nodes ( node quot -- new-node )
over [
[ call dup dup node-successor ] keep (transform-nodes)
[ call dup dup successor>> ] keep (transform-nodes)
] [ drop ] if ; inline
: node-literal? ( node value -- ? )
dup value? >r swap node-literals key? r> or ;
dup value? >r swap literals>> key? r> or ;
: node-literal ( node value -- obj )
dup value?
[ nip value-literal ] [ swap node-literals at ] if ;
[ nip value-literal ] [ swap literals>> at ] if ;
: node-interval ( node value -- interval )
swap node-intervals at ;
swap intervals>> at ;
: node-class ( node value -- class )
swap node-classes at object or ;
swap classes>> at object or ;
: node-input-classes ( node -- seq )
dup node-in-d [ node-class ] with map ;
dup in-d>> [ node-class ] with map ;
: node-input-intervals ( node -- seq )
dup node-in-d [ node-interval ] with map ;
dup in-d>> [ node-interval ] with map ;
: node-class-first ( node -- class )
dup node-in-d first node-class ;
dup in-d>> first node-class ;
: active-children ( node -- seq )
node-children
[ last-node ] map
[ #terminate? not ] subset ;
children>> [ last-node ] map [ #terminate? not ] subset ;
DEFER: #tail?
@ -320,5 +312,5 @@ UNION: #tail
#! We don't consider calls which do non-local exits to be
#! tail calls, because this gives better error traces.
node-stack get [
node-successor dup #tail? swap #terminate? not and
successor>> [ #tail? ] [ #terminate? not ] bi and
] all? ;

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

@ -1,15 +1,15 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! 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
assocs ;
assocs accessors ;
M: inference-error error.
dup inference-error-rstate
dup rstate>>
keys [ dup value? [ value-literal ] when ] map
dup empty? [ "Word: " write dup peek . ] unless
swap delegate error. "Nesting: " write . ;
swap error>> error. "Nesting: " write . ;
M: inference-error error-help drop f ;

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

@ -105,7 +105,7 @@ HELP: inference-error
{ $error-description
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
$nl
"This error always delegates to one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
"The " { $snippet "error" } " slot contains one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
{ $list
{ $link no-effect }
{ $link literal-expected }

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

@ -8,6 +8,9 @@ classes.predicate debugger threads.private io.streams.string
io.timeouts io.thread sequences.private ;
IN: inference.tests
[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as
@ -542,3 +545,5 @@ ERROR: custom-error ;
: missing->r-check >r ;
[ [ missing->r-check ] infer ] must-fail
{ 1 0 } [ [ ] map-children ] must-infer-as

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

@ -383,15 +383,9 @@ set-primitive-effect
\ millis { } { integer } <effect> set-primitive-effect
\ millis make-flushable
\ type { object } { fixnum } <effect> set-primitive-effect
\ type make-foldable
\ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable
\ class-hash { object } { fixnum } <effect> set-primitive-effect
\ class-hash make-foldable
\ cwd { } { string } <effect> set-primitive-effect
\ cd { string } { } <effect> set-primitive-effect

5
core/inference/transforms/transforms-tests.factor
View File

@ -1,6 +1,7 @@
IN: inference.transforms.tests
USING: sequences inference.transforms tools.test math kernel
quotations inference accessors combinators words arrays ;
quotations inference accessors combinators words arrays
classes ;
: compose-n-quot <repetition> >quotation ;
: compose-n compose-n-quot call ;
@ -56,3 +57,5 @@ C: <color> color
[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test
[ fixnum instance? ] must-infer

12
core/inference/transforms/transforms.factor
View File

@ -3,7 +3,7 @@
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state classes.tuple.private effects
inspector hashtables ;
inspector hashtables classes generic ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
@ -43,6 +43,8 @@ IN: inference.transforms
\ 2cleave [ 2cleave>quot ] 1 define-transform
\ 3cleave [ 3cleave>quot ] 1 define-transform
\ spread [ spread>quot ] 1 define-transform
! Bitfields
@ -96,3 +98,11 @@ M: duplicated-slots-error summary
\ construct-empty 1 1 <effect> make-call-node
] if
] "infer" set-word-prop
\ instance? [
[ +inlined+ depends-on ] [ "predicate" word-prop ] bi
] 1 define-transform
\ (call-next-method) [
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
] 2 define-transform

161
core/io/files/files-docs.factor
View File

@ -11,7 +11,9 @@ ARTICLE: "file-streams" "Reading and writing files"
{ $subsection with-file-reader }
{ $subsection with-file-writer }
{ $subsection with-file-appender }
{ $subsection set-file-contents }
{ $subsection file-contents }
{ $subsection set-file-lines }
{ $subsection file-lines } ;
ARTICLE: "pathnames" "Pathname manipulation"
@ -27,11 +29,21 @@ ARTICLE: "pathnames" "Pathname manipulation"
{ $subsection pathname }
{ $subsection <pathname> } ;
ARTICLE: "symbolic-links" "Symbolic links"
"Reading and creating links:"
{ $subsection read-link }
{ $subsection make-link }
"Copying links:"
{ $subsection copy-link }
"Not all operating systems support symbolic links."
{ $see-also link-info } ;
ARTICLE: "directories" "Directories"
"Current and home directories:"
{ $subsection cwd }
{ $subsection cd }
"Current directory:"
{ $subsection current-directory }
{ $subsection set-current-directory }
{ $subsection with-directory }
"Home directory:"
{ $subsection home }
"Directory listing:"
{ $subsection directory }
@ -40,18 +52,26 @@ ARTICLE: "directories" "Directories"
{ $subsection make-directory }
{ $subsection make-directories } ;
! ARTICLE: "file-types" "File Types"
! { $table { +directory+ "" } }
! ;
ARTICLE: "fs-meta" "File meta-data"
ARTICLE: "file-types" "File Types"
"Platform-independent types:"
{ $subsection +regular-file+ }
{ $subsection +directory+ }
"Platform-specific types:"
{ $subsection +character-device+ }
{ $subsection +block-device+ }
{ $subsection +fifo+ }
{ $subsection +symbolic-link+ }
{ $subsection +socket+ }
{ $subsection +unknown+ } ;
ARTICLE: "fs-meta" "File metadata"
"Querying file-system metadata:"
{ $subsection file-info }
{ $subsection link-info }
{ $subsection exists? }
{ $subsection directory? } ;
{ $subsection directory? }
"File types:"
{ $subsection "file-types" } ;
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
"Operations for deleting and copying files come in two forms:"
@ -120,39 +140,40 @@ HELP: file-name
! need a $class-description file-info
HELP: file-info
{ $values { "path" "a pathname string" }
{ "info" file-info } }
{ $description "Queries the file system for meta data. "
"If path refers to a symbolic link, it is followed."
"If the file does not exist, an exception is thrown." }
{ $class-description "File meta data" }
{ $table
{ "type" { "One of the following:"
{ $list { $link +regular-file+ }
{ $link +directory+ }
{ $link +symbolic-link+ } } } }
{ "size" "Size of the file in bytes" }
{ "modified" "Last modification timestamp." } }
;
! need a see also to link-info
{ $values { "path" "a pathname string" } { "info" file-info } }
{ $description "Queries the file system for metadata. If " { $snippet "path" } " refers to a symbolic link, it is followed. See the article " { $link "file-types" } " for a list of metadata symbols." }
{ $errors "Throws an error if the file does not exist." } ;
HELP: link-info
{ $values { "path" "a pathname string" }
{ "info" "a file-info tuple" } }
{ $description "Queries the file system for meta data. "
"If path refers to a symbolic link, information about "
"the symbolic link itself is returned."
"If the file does not exist, an exception is thrown." } ;
! need a see also to file-info
{ $values { "path" "a pathname string" } { "info" "a file-info tuple" } }
{ $description "Queries the file system for metadata. If path refers to a symbolic link, information about the symbolic link itself is returned. If the file does not exist, an exception is thrown." } ;
{ file-info link-info } related-words
HELP: +regular-file+
{ $description "A regular file. This type exists on all platforms. See " { $link "file-streams" } " for words operating on files." } ;
HELP: +directory+
{ $description "A directory. This type exists on all platforms. See " { $link "directories" } " for words operating on directories." } ;
HELP: +symbolic-link+
{ $description "A symbolic link file. This type is currently implemented on Unix platforms only. See " { $link "symbolic-links" } " for words operating on symbolic links." } ;
HELP: +character-device+
{ $description "A Unix character device file. This type exists on unix platforms only." } ;
HELP: +block-device+
{ $description "A Unix block device file. This type exists on unix platforms only." } ;
HELP: +fifo+
{ $description "A Unix fifo file. This type exists on unix platforms only." } ;
HELP: +socket+
{ $description "A Unix socket file. This type exists on unix platforms only." } ;
HELP: +unknown+
{ $description "A unknown file type." } ;
HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
{ "stream" "an input stream" } }
@ -184,37 +205,73 @@ HELP: with-file-appender
{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: set-file-lines
{ $values { "seq" "an array of strings" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
{ $description "Sets the contents of a file to the strings with the given encoding." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: file-lines
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" "an array of strings" } }
{ $description "Opens the file at the given path using the given encoding, and returns a list of the lines in that file." }
{ $errors "Throws an error if the file cannot be opened for reading." } ;
HELP: set-file-contents
{ $values { "str" "a string" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
{ $description "Sets the contents of a file to a string with the given encoding." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: file-contents
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } }
{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
{ $errors "Throws an error if the file cannot be opened for reading." } ;
{ set-file-lines file-lines set-file-contents file-contents } related-words
HELP: cwd
{ $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
HELP: cd
{ $values { "path" "a pathname string" } }
{ $description "Changes the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
{ cd cwd with-directory } related-words
{ cd cwd current-directory set-current-directory with-directory } related-words
HELP: current-directory
{ $description "A variable holding the current directory. Words that use the filesystem do so in relation to this variable. On startup, an init hook sets this word to the directory from which Factor was run." } ;
HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Changes the current working directory for the duration of a quotation's execution." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ;
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Concatenates two pathnames." } ;
HELP: prepend-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Concatenates two pathnames." } ;
{ append-path prepend-path } related-words
HELP: absolute-path?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if a pathname is absolute. Examples of absolute pathnames are " { $snippet "/foo/bar" } " on Unix and " { $snippet "c:\\foo\\bar" } " on Windows." } ;
HELP: windows-absolute-path?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if a pathname is absolute on Windows. Examples of absolute pathnames on Windows are " { $snippet "c:\\foo\\bar" } " and " { $snippet "\\\\?\\c:\\foo\\bar" } " for absolute Unicode pathnames." } ;
HELP: root-directory?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if a pathname is a root directory. Examples of root directory pathnames are " { $snippet "/" } " on Unix and " { $snippet "c:\\" } " on Windows." } ;
{ absolute-path? windows-absolute-path? root-directory? } related-words
HELP: exists?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if the file named by " { $snippet "path" } " exists." } ;
@ -260,6 +317,20 @@ HELP: <pathname> ( str -- pathname )
{ $values { "str" "a pathname string" } { "pathname" pathname } }
{ $description "Creates a new " { $link pathname } "." } ;
HELP: make-link
{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
{ $description "Creates a symbolic link." } ;
HELP: read-link
{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
{ $description "Reads the symbolic link and returns its target path." } ;
HELP: copy-link
{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } }
{ $description "Copies a symbolic link without following the link." } ;
{ make-link read-link copy-link } related-words
HELP: home
{ $values { "dir" string } }
{ $description "Outputs the user's home directory." } ;

6
core/io/files/files-tests.factor
View File

@ -1,7 +1,7 @@
IN: io.files.tests
USING: tools.test io.files io threads kernel continuations
io.encodings.ascii io.files.unique sequences strings accessors
io.encodings.utf8 ;
USING: tools.test io.files io.files.private io threads kernel
continuations io.encodings.ascii io.files.unique sequences
strings accessors io.encodings.utf8 ;
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test

29
core/io/files/files.factor
View File

@ -43,9 +43,9 @@ HOOK: (file-appender) io-backend ( path -- stream )
>r <file-appender> r> with-stream ; inline
! Pathnames
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
: path-separator ( -- string ) windows? "\\" "/" ? ;
: path-separator ( -- string ) os windows? "\\" "/" ? ;
: right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ;
@ -112,7 +112,7 @@ PRIVATE>
{
{ [ dup empty? ] [ f ] }
{ [ dup "resource:" head? ] [ t ] }
{ [ windows? ] [ windows-absolute-path? ] }
{ [ os windows? ] [ windows-absolute-path? ] }
{ [ dup first path-separator? ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;
@ -153,19 +153,19 @@ HOOK: file-info io-backend ( path -- info )
! Symlinks
HOOK: link-info io-backend ( path -- info )
HOOK: make-link io-backend ( path1 path2 -- )
HOOK: make-link io-backend ( target symlink -- )
HOOK: read-link io-backend ( path -- info )
HOOK: read-link io-backend ( symlink -- path )
: copy-link ( path1 path2 -- )
: copy-link ( target symlink -- )
>r read-link r> make-link ;
SYMBOL: +regular-file+
SYMBOL: +directory+
SYMBOL: +symbolic-link+
SYMBOL: +character-device+
SYMBOL: +block-device+
SYMBOL: +fifo+
SYMBOL: +symbolic-link+
SYMBOL: +socket+
SYMBOL: +unknown+
@ -176,15 +176,18 @@ SYMBOL: +unknown+
: directory? ( path -- ? )
file-info file-info-type +directory+ = ;
! Current working directory
<PRIVATE
HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path )
SYMBOL: current-directory
M: object cwd ( -- path ) "." ;
PRIVATE>
SYMBOL: current-directory
[ cwd current-directory set-global ] "io.files" add-init-hook
: resource-path ( path -- newpath )
@ -322,7 +325,7 @@ M: pathname <=> [ pathname-string ] compare ;
! Home directory
: home ( -- dir )
{
{ [ winnt? ] [ "USERPROFILE" os-env ] }
{ [ wince? ] [ "" resource-path ] }
{ [ unix? ] [ "HOME" os-env ] }
{ [ os winnt? ] [ "USERPROFILE" os-env ] }
{ [ os wince? ] [ "" resource-path ] }
{ [ os unix? ] [ "HOME" os-env ] }
} cond ;

2
core/io/streams/duplex/duplex-docs.factor
View File

@ -10,7 +10,7 @@ ARTICLE: "io.streams.duplex" "Duplex streams"
ABOUT: "io.streams.duplex"
HELP: duplex-stream
{ $class-description "A bidirectional stream delegating to a pair of streams, sending input to one delegate and output to another." } ;
{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }

69
core/io/streams/nested/nested.factor
View File

@ -1,30 +1,59 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.nested
USING: arrays generic assocs kernel namespaces strings
quotations io continuations ;
quotations io continuations accessors sequences ;
IN: io.streams.nested
TUPLE: ignore-close-stream ;
TUPLE: filter-writer stream ;
: <ignore-close-stream> ignore-close-stream construct-delegate ;
M: filter-writer stream-format
stream>> stream-format ;
M: filter-writer stream-write
stream>> stream-write ;
M: filter-writer stream-write1
stream>> stream-write1 ;
M: filter-writer make-span-stream
stream>> make-span-stream ;
M: filter-writer make-block-stream
stream>> make-block-stream ;
M: filter-writer make-cell-stream
stream>> make-cell-stream ;
M: filter-writer stream-flush
stream>> stream-flush ;
M: filter-writer stream-nl
stream>> stream-nl ;
M: filter-writer stream-write-table
stream>> stream-write-table ;
M: filter-writer dispose
stream>> dispose ;
TUPLE: ignore-close-stream < filter-writer ;
M: ignore-close-stream dispose drop ;
TUPLE: style-stream style ;
C: <ignore-close-stream> ignore-close-stream
: do-nested-style ( style stream -- style delegate )
[ style-stream-style swap union ] keep
delegate ; inline
TUPLE: style-stream < filter-writer style ;
: <style-stream> ( style delegate -- stream )
{ set-style-stream-style set-delegate }
style-stream construct ;
: do-nested-style ( style style-stream -- style stream )
[ style>> swap union ] [ stream>> ] bi ; inline
C: <style-stream> style-stream
M: style-stream stream-format
do-nested-style stream-format ;
M: style-stream stream-write
dup style-stream-style swap delegate stream-format ;
[ style>> ] [ stream>> ] bi stream-format ;
M: style-stream stream-write1
>r 1string r> stream-write ;
@ -33,15 +62,13 @@ M: style-stream make-span-stream
do-nested-style make-span-stream ;
M: style-stream make-block-stream
[ do-nested-style make-block-stream ] keep
style-stream-style swap <style-stream> ;
[ do-nested-style make-block-stream ] [ style>> ] bi
<style-stream> ;
M: style-stream make-cell-stream
[ do-nested-style make-cell-stream ] keep
style-stream-style swap <style-stream> ;
[ do-nested-style make-cell-stream ] [ style>> ] bi
<style-stream> ;
TUPLE: block-stream ;
: <block-stream> block-stream construct-delegate ;
M: block-stream dispose drop ;
M: style-stream stream-write-table
[ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
stream-write-table ;

2
core/io/streams/plain/plain.factor
View File

@ -12,7 +12,7 @@ M: plain-writer stream-format
nip stream-write ;
M: plain-writer make-span-stream
<style-stream> <ignore-close-stream> ;
swap <style-stream> <ignore-close-stream> ;
M: plain-writer make-block-stream
nip <ignore-close-stream> ;

2
core/io/streams/string/string-docs.factor
View File

@ -13,7 +13,7 @@ ABOUT: "io.streams.string"
HELP: <string-writer>
{ $values { "stream" "an output stream" } }
{ $description "Creates an output stream that collects text into a delegate string buffer. The contents of the buffer can be recovered by executing " { $link >string } ", and indeed all other sequence operations are permitted by virtue of the delegation." } ;
{ $description "Creates an output stream that collects text into a string buffer. The contents of the buffer can be obtained by executing " { $link >string } "." } ;
HELP: with-string-writer
{ $values { "quot" quotation } { "str" string } }

77
core/kernel/kernel-docs.factor
View File

@ -217,9 +217,7 @@ $nl
{ $example "\\ f class ." "word" }
"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
{ $example "t \\ t eq? ." "t" }
"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "."
$nl
"A tuple cannot delegate to " { $link f } " at all, since a delegate of " { $link f } " actually denotes that no delegate is set. See " { $link set-delegate } "." ;
"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
ARTICLE: "conditionals" "Conditionals and logic"
"The basic conditionals:"
@ -250,8 +248,9 @@ $nl
{ $subsection eq? }
"Value comparison:"
{ $subsection = }
"Generic words for custom value comparison methods:"
"Custom value comparison methods:"
{ $subsection equal? }
{ $subsection identity-tuple }
"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
{ $subsection <=> }
{ $subsection compare }
@ -275,9 +274,11 @@ ARTICLE: "dataflow" "Data and control flow"
{ $subsection "apply-combinators" }
{ $subsection "slip-keep-combinators" }
{ $subsection "conditionals" }
{ $subsection "compositional-combinators" }
{ $subsection "combinators" }
"Advanced topics:"
{ $subsection "implementing-combinators" }
{ $subsection "errors" }
{ $subsection "continuations" } ;
ABOUT: "dataflow"
@ -340,6 +341,9 @@ HELP: set-callstack ( cs -- )
HELP: clear
{ $description "Clears the data stack." } ;
HELP: build
{ $description "The current build number. Factor increments this number whenever a new boot image is created." } ;
HELP: hashcode*
{ $values { "depth" integer } { "obj" object } { "code" fixnum } }
{ $contract "Outputs the hashcode of an object. The hashcode operation must satisfy the following properties:"
@ -377,10 +381,13 @@ HELP: equal?
}
$nl
"If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word."
}
} ;
HELP: identity-tuple
{ $class-description "A class defining an " { $link equal? } " method which always returns f." }
{ $examples
"To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
{ $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" }
"To define a tuple class such that two instances are only equal if they are both the same instance, inherit from the " { $link identity-tuple } " class. This class defines a method on " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
{ $code "TUPLE: foo < identity-tuple ;" }
"By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:"
{ $unchecked-example "T{ foo } dup = ." "t" }
{ $unchecked-example "T{ foo } dup clone = ." "f" }
@ -389,7 +396,7 @@ HELP: equal?
HELP: <=>
{ $values { "obj1" object } { "obj2" object } { "n" real } }
{ $contract
"Compares two objects using an intrinsic partial order, for example, the natural order for real numbers and lexicographic order for strings."
"Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
$nl
"The output value is one of the following:"
{ $list
@ -413,12 +420,6 @@ HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
HELP: type ( object -- n )
{ $values { "object" object } { "n" "a type number" } }
{ $description "Outputs an object's type number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
{ type tag type>class } related-words
HELP: ? ( ? true false -- true/false )
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
@ -671,6 +672,11 @@ HELP: bi@
"[ p ] bi@"
">r p r> p"
}
"The following two lines are also equivalent:"
{ $code
"[ p ] bi@"
"[ p ] [ p ] bi*"
}
} ;
HELP: 2bi@
@ -682,6 +688,11 @@ HELP: 2bi@
"[ p ] 2bi@"
">r >r p r> r> p"
}
"The following two lines are also equivalent:"
{ $code
"[ p ] 2bi@"
"[ p ] [ p ] 2bi*"
}
} ;
HELP: tri@
@ -693,6 +704,11 @@ HELP: tri@
"[ p ] tri@"
">r >r p r> p r> p"
}
"The following two lines are also equivalent:"
{ $code
"[ p ] tri@"
"[ p ] [ p ] [ p ] tri*"
}
} ;
HELP: if ( cond true false -- )
@ -791,19 +807,6 @@ HELP: null
"The canonical empty class with no instances."
} ;
HELP: general-t
{ $class-description
"The class of all objects not equal to " { $link f } "."
}
{ $examples
"Here is an implementation of " { $link if } " using generic words:"
{ $code
"GENERIC# my-if 2 ( ? true false -- )"
"M: f my-if 2nip call ;"
"M: general-t my-if drop nip call ;"
}
} ;
HELP: most
{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
{ $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;
@ -846,11 +849,15 @@ HELP: with
{ $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
} ;
HELP: compose
{ $values { "quot1" callable } { "quot2" callable } { "curry" curry } }
HELP: compose ( quot1 quot2 -- compose )
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes
"The following two lines are equivalent:"
"The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:"
{ $code
"[ 3 >r ] [ r> . ] compose"
}
"Except for this restriction, the following two lines are equivalent:"
{ $code
"compose call"
"append call"
@ -862,7 +869,15 @@ HELP: 3compose
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "curry" curry } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes
"The following two lines are equivalent:"
"The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"
{ $code
"[ >r ] swap [ r> ] 3compose"
}
"The correct way to achieve the effect of the above is the following:"
{ $code
"[ dip ] curry"
}
"Excepting the retain stack restriction, the following two lines are equivalent:"
{ $code
"3compose call"
"3append call"

48
core/kernel/kernel.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel.private ;
USING: kernel.private slots.private classes.tuple.private ;
IN: kernel
! Stack stuff
@ -99,14 +99,14 @@ DEFER: if
! Appliers
: bi@ ( x y quot -- )
tuck 2slip call ; inline
dup bi* ; inline
: tri@ ( x y z quot -- )
tuck >r bi@ r> call ; inline
dup dup tri* ; inline
! Double appliers
: 2bi@ ( w x y z quot -- )
dup -roll 3slip call ; inline
dup 2bi* ; inline
: while ( pred body tail -- )
>r >r dup slip r> r> roll
@ -114,12 +114,6 @@ DEFER: if
[ 2nip call ] if ; inline
! Object protocol
GENERIC: delegate ( obj -- delegate )
M: object delegate drop f ;
GENERIC: set-delegate ( delegate tuple -- )
GENERIC: hashcode* ( depth obj -- code )
M: object hashcode* 2drop 0 ;
@ -130,6 +124,10 @@ GENERIC: equal? ( obj1 obj2 -- ? )
M: object equal? 2drop f ;
TUPLE: identity-tuple ;
M: identity-tuple equal? 2drop f ;
: = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [ equal? ] if ; inline
@ -142,18 +140,11 @@ M: object clone ;
M: callstack clone (clone) ;
! Tuple construction
GENERIC# get-slots 1 ( tuple slots -- ... )
: construct-empty ( class -- tuple )
tuple-layout <tuple> ;
GENERIC# set-slots 1 ( ... tuple slots -- )
GENERIC: construct-empty ( class -- tuple )
GENERIC: construct ( ... slots class -- tuple ) inline
GENERIC: construct-boa ( ... class -- tuple )
: construct-delegate ( delegate class -- tuple )
>r { set-delegate } r> construct ; inline
: construct-boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;
! Quotation building
: 2curry ( obj1 obj2 quot -- curry )
@ -194,8 +185,23 @@ GENERIC: construct-boa ( ... class -- tuple )
<PRIVATE
: hi-tag ( obj -- n ) 0 slot ; inline
: declare ( spec -- ) drop ;
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>
! Deprecated
M: object delegate drop f ;
GENERIC# get-slots 1 ( tuple slots -- ... )
GENERIC# set-slots 1 ( ... tuple slots -- )
: construct ( ... slots class -- tuple )
construct-empty [ swap set-slots ] keep ; inline
: construct-delegate ( delegate class -- tuple )
>r { set-delegate } r> construct ; inline

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

@ -1,6 +1,6 @@
USING: generic help.markup help.syntax kernel math
memory namespaces sequences kernel.private classes
sequences.private ;
classes.builtin sequences.private ;
IN: layouts
HELP: tag-bits
@ -14,7 +14,7 @@ HELP: tag-mask
{ $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
HELP: num-types
{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link type } " primitive." } ;
{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
HELP: tag-number
{ $values { "class" class } { "n" "an integer or " { $link f } } }
@ -76,7 +76,7 @@ HELP: bootstrap-cell-bits
ARTICLE: "layouts-types" "Type numbers"
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
{ $subsection type }
{ $subsection hi-tag }
"Built-in type numbers can be converted to classes, and vice versa:"
{ $subsection type>class }
{ $subsection type-number }

4
core/listener/listener.factor
View File

@ -3,7 +3,7 @@
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles
io.streams.duplex vectors words generic system combinators
continuations debugger definitions compiler.units ;
continuations debugger definitions compiler.units accessors ;
IN: listener
SYMBOL: quit-flag
@ -19,7 +19,7 @@ GENERIC: stream-read-quot ( stream -- quot/f )
: read-quot-step ( lines -- quot/f )
[ parse-lines-interactive ] [
dup delegate unexpected-eof?
dup error>> unexpected-eof?
[ 2drop f ] [ rethrow ] if
] recover ;

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

@ -83,6 +83,29 @@ HELP: >=
{ $values { "x" real } { "y" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
HELP: before?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: before=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
{ before? after? before=? after=? } related-words
HELP: +
{ $values { "x" number } { "y" number } { "z" number } }
{ $description

3
core/memory/memory-tests.factor
View File

@ -1,5 +1,6 @@
USING: generic kernel kernel.private math memory prettyprint
sequences tools.test words namespaces layouts classes ;
sequences tools.test words namespaces layouts classes
classes.builtin ;
IN: memory.tests
TUPLE: testing x y z ;

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

@ -7,9 +7,6 @@ $nl
"A mirror provides such a view of a tuple:"
{ $subsection mirror }
{ $subsection <mirror> }
"An enum provides such a view of a sequence:"
{ $subsection enum }
{ $subsection <enum> }
"Utility word used by developer tools which inspect objects:"
{ $subsection make-mirror }
{ $see-also "slots" } ;
@ -44,11 +41,6 @@ HELP: >mirror<
{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
{ $description "Pushes the object being viewed in the mirror together with its slots." } ;
HELP: enum
{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
$nl
"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
HELP: make-mirror
{ $values { "obj" object } { "assoc" assoc } }
{ $description "Creates an assoc which reflects the internal structure of the object." } ;

21
core/mirrors/mirrors.factor
View File

@ -48,27 +48,6 @@ M: mirror assoc-size mirror-slots length ;
INSTANCE: mirror assoc
TUPLE: enum seq ;
C: <enum> enum
M: enum at*
enum-seq 2dup bounds-check?
[ nth t ] [ 2drop f f ] if ;
M: enum set-at enum-seq set-nth ;
M: enum delete-at enum-seq delete-nth ;
M: enum >alist ( enum -- alist )
enum-seq dup length swap 2array flip ;
M: enum assoc-size enum-seq length ;
M: enum clear-assoc enum-seq delete-all ;
INSTANCE: enum assoc
: sort-assoc ( assoc -- alist )
>alist
[ dup first unparse-short swap ] { } map>assoc

2
core/optimizer/backend/backend.factor
View File

@ -51,7 +51,7 @@ GENERIC: optimize-node* ( node -- node/t changed? )
DEFER: optimize-nodes
: optimize-children ( node -- )
[ optimize-nodes ] change-children ;
[ optimize-nodes ] map-children ;
: optimize-node ( node -- node )
dup [

2
core/optimizer/control/control.factor
View File

@ -154,7 +154,7 @@ SYMBOL: potential-loops
] [
node-class {
{ [ dup null class< ] [ drop f f ] }
{ [ dup general-t class< ] [ drop t t ] }
{ [ dup \ f class-not class< ] [ drop t t ] }
{ [ dup \ f class< ] [ drop f t ] }
{ [ t ] [ drop f f ] }
} cond

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