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

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

db4
Alex Chapman 2008-04-03 23:42:28 +11:00
parent e8abcf8d85 b096395e6c
commit 76c8f02238
260 changed files with 2515 additions and 1987 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 >>"
}

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

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

@ -45,7 +45,7 @@ GENERIC: c-type ( name -- type ) foldable
: parse-array-type ( name -- array )
"[" split unclip
>r [ "]" ?tail drop string>number ] map r> add* ;
>r [ "]" ?tail drop string>number ] map r> prefix ;
M: string c-type ( name -- type )
CHAR: ] over member? [
@ -162,7 +162,7 @@ DEFER: >c-ushort-array
>r >c-ushort-array r> byte-array>memory ;
: (define-nth) ( word type quot -- )
>r heap-size [ rot * ] swap add* r> append define-inline ;
>r heap-size [ rot * ] swap prefix r> append define-inline ;
: nth-word ( name vocab -- word )
>r "-nth" append r> create ;
@ -199,12 +199,12 @@ M: long-long-type box-return ( type -- )
f swap box-parameter ;
: define-deref ( name vocab -- )
>r dup CHAR: * add* r> create
swap c-getter 0 add* define-inline ;
>r dup CHAR: * prefix r> create
swap c-getter 0 prefix define-inline ;
: define-out ( name vocab -- )
over [ <c-object> tuck 0 ] over c-setter append swap
>r >r constructor-word r> r> add* define-inline ;
>r >r constructor-word r> r> prefix define-inline ;
: c-bool> ( int -- ? )
zero? not ;
@ -257,7 +257,7 @@ M: long-long-type box-return ( type -- )
#! staging violations
dup array? [
unclip >r [ dup word? [ word-def call ] when ] map
r> add*
r> prefix
] when ;
: malloc-file-contents ( path -- alien len )
@ -388,6 +388,6 @@ M: long-long-type box-return ( 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

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

@ -18,7 +18,7 @@ IN: alien.compiler
: alien-node-parameters* ( node -- seq )
dup parameters>>
swap return>> large-struct? [ "void*" add* ] when ;
swap return>> large-struct? [ "void*" prefix ] when ;
: alien-node-return* ( node -- ctype )
return>> dup large-struct? [ drop "void" ] when ;

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

@ -8,7 +8,7 @@ kernel words slots assocs namespaces ;
dup ?word-name swap 2array
over slot-spec-name
rot slot-spec-type 2array 2array
[ { $instance } swap add ] assoc-map ;
[ { $instance } swap suffix ] assoc-map ;
: $spec-reader-values ( slot-spec class -- )
($spec-reader-values) $values ;
@ -16,9 +16,9 @@ kernel words slots assocs namespaces ;
: $spec-reader-description ( slot-spec class -- )
[
"Outputs the value stored in the " ,
{ $snippet } rot slot-spec-name add ,
{ $snippet } rot slot-spec-name suffix ,
" slot of " ,
{ $instance } swap add ,
{ $instance } swap suffix ,
" instance." ,
] { } make $description ;
@ -43,9 +43,9 @@ M: word slot-specs "slots" word-prop ;
: $spec-writer-description ( slot-spec class -- )
[
"Stores a new value to the " ,
{ $snippet } rot slot-spec-name add ,
{ $snippet } rot slot-spec-name suffix ,
" slot of " ,
{ $instance } swap add ,
{ $instance } swap suffix ,
" instance." ,
] { } make $description ;

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

@ -16,7 +16,7 @@ IN: alien.structs
] reduce ;
: define-struct-slot-word ( spec word quot -- )
rot slot-spec-offset add* define-inline ;
rot slot-spec-offset prefix define-inline ;
: define-getter ( type spec -- )
[ set-reader-props ] keep

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

8
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

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

@ -12,7 +12,8 @@ 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 ;
@ -305,7 +306,7 @@ M: float-array ' float-array emit-dummy-array ;
! Tuples
: (emit-tuple) ( tuple -- pointer )
[ tuple>array 1 tail-slice ]
[ class transfer-word tuple-layout ] bi add* [ ' ] map
[ class transfer-word tuple-layout ] bi prefix [ ' ] map
tuple type-number dup [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer )

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 }

136
core/bootstrap/primitives.factor
View File

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

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

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
;
kernel.private ;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )
@ -138,10 +138,10 @@ C: <anonymous-complement> anonymous-complement
members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class )
>r members>> r> add <anonymous-intersection> ;
>r members>> r> suffix <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class )
members>> swap add <anonymous-intersection> ;
members>> swap suffix <anonymous-intersection> ;
: (class-and) ( first second -- class )
{
@ -158,10 +158,10 @@ C: <anonymous-complement> anonymous-complement
} cond ;
: left-anonymous-union-or ( first second -- class )
>r members>> r> add <anonymous-union> ;
>r members>> r> suffix <anonymous-union> ;
: right-anonymous-union-or ( first second -- class )
members>> swap add <anonymous-union> ;
members>> swap suffix <anonymous-union> ;
: (class-or) ( first second -- class )
{
@ -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 ;

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

@ -21,7 +21,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 }
@ -47,6 +46,7 @@ $nl
"Other sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
{ $subsection "singletons" }
{ $subsection "mixins" }
{ $subsection "predicates" }
"Classes can be inspected and operated upon:"

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

59
core/classes/classes.factor
View File

@ -25,9 +25,11 @@ 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
PREDICATE: class < word
"class" word-prop ;
SYMBOL: builtins
PREDICATE: builtin-class < class
@ -58,7 +60,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 +74,7 @@ M: word reset-class drop ;
! update-map
: class-uses ( class -- seq )
dup members swap superclass [ add ] when* ;
[ members ] [ superclass ] bi [ suffix ] when* ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
@ -83,7 +85,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 +94,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 +111,28 @@ 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 ;
M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;
: instance? ( obj class -- ? )
"predicate" word-prop call ;

4
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
@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ;
swap redefine-mixin-class ; inline
: add-mixin-instance ( class mixin -- )
[ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ;
[ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;

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/singleton/authors.txt → core/classes/singleton/authors.txt
View File

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

@ -0,0 +1,28 @@
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. Methods may dispatch off of singleton classes."
{ $subsection POSTPONE: SINGLETON: }
{ $subsection define-singleton-class } ;
HELP: SINGLETON:
{ $syntax "SINGLETON: class"
} { $values
{ "class" "a new singleton to define" }
} { $description
"Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton."
} { $examples
{ $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
} { $see-also
POSTPONE: PREDICATE:
} ;
HELP: define-singleton-class
{ $values { "word" "a new word" } }
{ $description
"Defines a newly created word to be a singleton class." } ;
{ POSTPONE: SINGLETON: define-singleton-class } related-words
ABOUT: "singletons"

12
core/classes/singleton/singleton-tests.factor Normal file
View File

@ -0,0 +1,12 @@
USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
[ t ] [ bzzt bzzt? ] unit-test
[ t ] [ bzzt bzzt eq? ] unit-test
GENERIC: zammo ( obj -- str )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] 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 ;

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

@ -153,14 +153,6 @@ HELP: tuple=
{ $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

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

@ -62,13 +62,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
@ -394,7 +394,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 +511,45 @@ USE: vocabs
define-tuple-class
] with-compilation-unit
] unit-test
[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] 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

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

@ -19,7 +19,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 +40,9 @@ PRIVATE>
[ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array )
prepare-tuple>array >r copy-tuple-slots r> layout-class add* ;
prepare-tuple>array
>r copy-tuple-slots r>
layout-class prefix ;
: tuple-slots ( tuple -- array )
prepare-tuple>array drop copy-tuple-slots ;
@ -120,17 +122,8 @@ 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 add* ;
superclasses [ slot-names ] map concat \ class prefix ;
: compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ;
@ -161,25 +154,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 +182,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 +204,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 +233,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

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 ;

18
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 ;
@ -43,7 +49,7 @@ ERROR: no-case ;
: with-datastack ( stack quot -- newstack )
datastack >r
>r >array set-datastack r> call
datastack r> swap add set-datastack 2nip ; inline
datastack r> swap suffix set-datastack 2nip ; inline
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
@ -66,7 +72,7 @@ M: hashtable hashcode*
reverse [ no-cond ] swap alist>quot ;
: linear-case-quot ( default assoc -- quot )
[ >r [ dupd = ] curry r> \ drop add* ] assoc-map
[ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
alist>quot ;
: (distribute-buckets) ( buckets pair keys -- )

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

8
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

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

@ -5,8 +5,6 @@ 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 ;
@ -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

100
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,25 +122,25 @@ 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 ;
@ -166,19 +164,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 +186,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 +195,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 +203,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 +213,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 +228,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 +238,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 +262,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 +270,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

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

@ -94,14 +94,14 @@ IN: cpu.ppc.intrinsics
} define-intrinsics
: fixnum-register-op ( op -- pair )
[ "out" operand "y" operand "x" operand ] swap add H{
[ "out" operand "y" operand "x" operand ] swap suffix H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} 2array ;
: fixnum-value-op ( op -- pair )
[ "out" operand "x" operand "y" operand ] swap add H{
[ "out" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
@ -205,11 +205,11 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
: fixnum-register-jump ( op -- pair )
[ "x" operand 0 "y" operand CMP ] swap add
[ "x" operand 0 "y" operand CMP ] swap suffix
{ { f "x" } { f "y" } } 2array ;
: fixnum-value-jump ( op -- pair )
[ 0 "x" operand "y" operand CMPI ] swap add
[ 0 "x" operand "y" operand CMPI ] swap suffix
{ { f "x" } { [ small-tagged? ] "y" } } 2array ;
: define-fixnum-jump ( word op -- )
@ -336,7 +336,7 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
: define-float-op ( word op -- )
[ "z" operand "x" operand "y" operand ] swap add H{
[ "z" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +scratch+ { { float "z" } } }
{ +output+ { "z" } }
@ -352,7 +352,7 @@ IN: cpu.ppc.intrinsics
] each
: define-float-jump ( word op -- )
[ "x" operand 0 "y" operand FCMPU ] swap add
[ "x" operand 0 "y" operand FCMPU ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
@ -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

64
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 ;
@ -165,12 +162,12 @@ M: x86-32-backend %box ( n reg-class func -- )
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? [

63
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 -- )
M: x86.64 %unbox-long-long ( n func -- )
T{ 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 -- )
M: x86.64 %box-long-long ( n func -- )
T{ 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,8 +168,6 @@ 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 >>

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

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

@ -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 [+] ;
@ -33,34 +31,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 +68,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 +81,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 +103,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 +141,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

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

@ -230,7 +230,7 @@ UNION: operand register indirect ;
: opcode-or ( opcode mask -- opcode' )
swap dup array?
[ 1 cut* first rot bitor add ] [ bitor ] if ;
[ 1 cut* first rot bitor suffix ] [ bitor ] if ;
: 1-operand ( op reg rex.w opcode -- )
#! The 'reg' is not really a register, but a value for the

56
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
@ -156,7 +104,7 @@ IN: cpu.x86.intrinsics
! Fixnums
: fixnum-op ( op hash -- pair )
>r [ "x" operand "y" operand ] swap add r> 2array ;
>r [ "x" operand "y" operand ] swap suffix r> 2array ;
: fixnum-value-op ( op -- pair )
H{
@ -251,7 +199,7 @@ IN: cpu.x86.intrinsics
\ fixnum- \ SUB overflow-template
: fixnum-jump ( op inputs -- pair )
>r [ "x" operand "y" operand CMP ] swap add r> 2array ;
>r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
: fixnum-value-jump ( op -- pair )
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;

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

@ -8,7 +8,7 @@ math.floats.private layouts quotations ;
IN: cpu.x86.sse2
: define-float-op ( word op -- )
[ "x" operand "y" operand ] swap add H{
[ "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +output+ { "x" } }
} define-intrinsic ;
@ -23,7 +23,7 @@ IN: cpu.x86.sse2
] each
: define-float-jump ( word op -- )
[ "x" operand "y" operand UCOMISD ] swap add
[ "x" operand "y" operand UCOMISD ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{

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

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

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

@ -37,7 +37,6 @@ $nl
{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
{ $subsection methods }
"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,15 +62,6 @@ 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: "generic" "Generic words and methods"
@ -129,10 +119,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 +146,4 @@ 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

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

75
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,17 @@ 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 ;
: 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 +61,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 +106,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 +114,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 +135,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 +157,15 @@ M: assoc update-methods ( assoc -- )
] if ;
M: generic subwords
dup "methods" word-prop values
swap "default-method" word-prop add ;
[
[ "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 ;

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

@ -12,9 +12,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 +71,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 ;

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

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

@ -3,194 +3,164 @@
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 # ;
C: <standard-combination> standard-combination
SYMBOL: (dispatch#)
: (picker) ( n -- quot )
{
{ 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
: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
ERROR: no-method object generic ;
: error-method ( word -- quot )
picker swap [ no-method ] curry append ;
: empty-method ( word -- quot )
[
picker % [ delegate dup ] %
unpicker over add ,
error-method \ drop add* , \ 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 )
[
picker %
\ tag ,
group-methods build-type-vtable ,
\ dispatch ,
] [ ] make ;
: flatten-method ( class body -- )
over members pick object bootstrap-word eq? not and [
>r members r> [ flatten-method ] curry each
] [
swap set
] if ;
: flatten-methods ( methods -- newmethods )
[ [ flatten-method ] assoc-each ] V{ } make-assoc ;
: dispatched-types ( methods -- seq )
keys object bootstrap-word swap remove prune ;
: single-combination ( methods -- quot )
dup length 4 <= [
small-generic
] [
flatten-methods
dup dispatched-types [ number class< ] all?
[ tag-generic ] [ big-generic ] if
] if ;
: standard-methods ( word -- alist )
dup methods swap default-method add*
[ 1quotation ] assoc-map ;
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
[
standard-methods
[ [ drop ] prepend ] assoc-map
single-combination
] with-hook ;
: define-simple-generic ( word -- )
T{ standard-combination f 0 } define-generic ;
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
PREDICATE: simple-generic < standard-generic
"combination" word-prop standard-combination-# zero? ;
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-# ;
: unpickers
{
[ 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 )
picker swap [ no-method ] curry append ;
: empty-method ( word -- quot )
[
picker % [ delegate dup ] %
unpicker over suffix ,
error-method \ drop prefix , \ if ,
] [ ] make ;
: default-method ( word -- pair )
"default-method" word-prop
object bootstrap-word swap 2array ;
: push-method ( method specializer atomic assoc -- )
[
[ H{ } clone <predicate-dispatch-engine> ] unless*
[ methods>> set-at ] keep
] change-at ;
: flatten-method ( class method assoc -- )
>r >r dup flatten-class keys swap r> r> [
>r spin r> push-method
] 3curry each ;
: flatten-methods ( assoc -- assoc' )
H{ } clone [
[
flatten-method
] curry assoc-each
] keep ;
: <big-dispatch-engine> ( assoc -- engine )
flatten-methods
convert-tuple-methods
convert-hi-tag-methods
<lo-tag-dispatch-engine> ;
: find-default ( methods -- quot )
#! Side-effects methods.
object bootstrap-word swap delete-at* [
drop generic get "default-method" word-prop 1quotation
] unless ;
GENERIC: mangle-method ( method generic -- quot )
: single-combination ( word -- quot )
[
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 ;
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 #>> 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# #>> ;
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? ;
: 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 ;

21
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 ;
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
@ -92,7 +101,7 @@ M: wrapper apply-object
r> recursive-state set ;
: infer-quot-recursive ( quot word label -- )
recursive-state get -rot 2array add* infer-quot ;
recursive-state get -rot 2array prefix infer-quot ;
: time-bomb ( error -- )
[ throw ] curry recursive-state get infer-quot ;
@ -109,7 +118,7 @@ TUPLE: recursive-quotation-error quot ;
dup value-literal callable? [
dup value-literal
over value-recursion
rot f 2array add* infer-quot
rot f 2array prefix infer-quot
] [
drop bad-call
] if
@ -430,7 +439,7 @@ M: #call-label collect-recursion*
[ [ swap collect-recursion* ] curry each-node ] { } make ;
: join-values ( node -- )
collect-recursion [ node-in-d ] map meta-d get add
collect-recursion [ node-in-d ] map meta-d get suffix
unify-lengths unify-stacks
meta-d [ length tail* ] change ;

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

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

@ -9,15 +9,13 @@ IN: inference.dataflow
: <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,13 +28,12 @@ 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 -- )
@ -205,7 +202,7 @@ UNION: #branch #if #dispatch ;
2dup 2slip rot [
2drop t
] [
>r dup node-children swap node-successor add r>
>r dup node-children swap node-successor suffix r>
[ node-exists? ] curry contains?
] if
] [

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

14
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
@ -56,7 +58,7 @@ M: pair (bitfield-quot) ( spec -- quot )
[ shift bitor ] append 2curry ;
: bitfield-quot ( spec -- quot )
[ (bitfield-quot) ] map [ 0 ] add* concat ;
[ (bitfield-quot) ] map [ 0 ] prefix concat ;
\ bitfield [ bitfield-quot ] 1 define-transform
@ -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

8
core/io/backend/backend-tests.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
IN: io.backend.tests
USING: tools.test io.backend kernel ;
[ ] [ "a" normalize-pathname drop ] unit-test
IN: io.backend.tests
USING: tools.test io.backend kernel ;
[ ] [ "a" normalize-path drop ] unit-test

6
core/io/backend/backend.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings
io.encodings.utf8 init assocs ;
io.encodings.utf8 init assocs splitting ;
IN: io.backend
SYMBOL: io-backend
@ -18,9 +18,9 @@ HOOK: io-multiplex io-backend ( ms -- )
HOOK: normalize-directory io-backend ( str -- newstr )
HOOK: normalize-pathname io-backend ( str -- newstr )
HOOK: normalize-path io-backend ( str -- newstr )
M: object normalize-directory normalize-pathname ;
M: object normalize-directory normalize-path ;
: set-io-backend ( io-backend -- )
io-backend set-global init-io init-stdio

2
core/io/encodings/encodings.factor
View File

@ -59,7 +59,7 @@ M: tuple <decoder> f decoder construct-boa ;
over decoder-cr [
over cr-
"\n" ?head [
over stream-read1 [ add ] when*
over stream-read1 [ suffix ] when*
] when
] when nip ;

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

@ -252,7 +252,7 @@ HELP: normalize-directory
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
HELP: normalize-pathname
HELP: normalize-path
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;

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

@ -220,8 +220,6 @@ io.encodings.utf8 ;
[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
@ -239,9 +237,6 @@ io.encodings.utf8 ;
[ "lib" ] [ "" "lib" append-path ] unit-test
[ "lib" ] [ "" "./lib" append-path ] unit-test
[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
[ "foo/bar/." parent-directory ] must-fail
[ "foo/bar/./" parent-directory ] must-fail
[ "foo/bar/baz/.." parent-directory ] must-fail
@ -263,5 +258,4 @@ io.encodings.utf8 ;
[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
[ t ] [ "resource:core" absolute-path? ] unit-test
[ t ] [ "/foo" absolute-path? ] unit-test
[ f ] [ "" absolute-path? ] unit-test

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

@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream )
HOOK: (file-appender) io-backend ( path -- stream )
: <file-reader> ( path encoding -- stream )
swap normalize-pathname (file-reader) swap <decoder> ;
swap normalize-path (file-reader) swap <decoder> ;
: <file-writer> ( path encoding -- stream )
swap normalize-pathname (file-writer) swap <encoder> ;
swap normalize-path (file-writer) swap <encoder> ;
: <file-appender> ( path encoding -- stream )
swap normalize-pathname (file-appender) swap <encoder> ;
swap normalize-path (file-appender) swap <encoder> ;
: file-lines ( path encoding -- seq )
<file-reader> lines ;
@ -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 ;
@ -102,6 +102,7 @@ PRIVATE>
: windows-absolute-path? ( path -- path ? )
{
{ [ dup "\\\\?\\" head? ] [ t ] }
{ [ dup length 2 < ] [ f ] }
{ [ dup second CHAR: : = ] [ t ] }
{ [ t ] [ f ] }
@ -111,8 +112,8 @@ PRIVATE>
{
{ [ dup empty? ] [ f ] }
{ [ dup "resource:" head? ] [ t ] }
{ [ os windows? ] [ windows-absolute-path? ] }
{ [ dup first path-separator? ] [ t ] }
{ [ windows? ] [ windows-absolute-path? ] }
{ [ t ] [ f ] }
} cond nip ;
@ -126,6 +127,9 @@ PRIVATE>
2 tail left-trim-separators
>r parent-directory r> append-path
] }
{ [ over absolute-path? over first path-separator? and ] [
>r 2 head r> append
] }
{ [ t ] [
>r right-trim-separators "/" r>
left-trim-separators 3append
@ -167,7 +171,7 @@ SYMBOL: +unknown+
! File metadata
: exists? ( path -- ? )
normalize-pathname (exists?) ;
normalize-path (exists?) ;
: directory? ( path -- ? )
file-info file-info-type +directory+ = ;
@ -183,18 +187,33 @@ M: object cwd ( -- path ) "." ;
[ cwd current-directory set-global ] "io.files" add-init-hook
: resource-path ( path -- newpath )
"resource-path" get [ image parent-directory ] unless*
prepend-path ;
: (normalize-path) ( path -- path' )
"resource:" ?head [
left-trim-separators resource-path
(normalize-path)
] [
current-directory get prepend-path
] if ;
M: object normalize-path ( path -- path' )
(normalize-path) ;
: with-directory ( path quot -- )
>r normalize-pathname r>
>r (normalize-path) r>
current-directory swap with-variable ; inline
: set-current-directory ( path -- )
normalize-pathname current-directory set ;
normalize-path current-directory set ;
! Creating directories
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
normalize-pathname right-trim-separators {
normalize-path right-trim-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
@ -267,7 +286,7 @@ M: object copy-file
DEFER: copy-tree-into
: copy-tree ( from to -- )
normalize-pathname
normalize-path
over link-info type>>
{
{ +symbolic-link+ [ copy-link ] }
@ -286,9 +305,6 @@ DEFER: copy-tree-into
[ copy-tree-into ] curry each ;
! Special paths
: resource-path ( path -- newpath )
"resource-path" get [ image parent-directory ] unless*
prepend-path ;
: temp-directory ( -- path )
"temp" resource-path dup make-directories ;
@ -296,14 +312,6 @@ DEFER: copy-tree-into
: temp-file ( name -- path )
temp-directory prepend-path ;
M: object normalize-pathname ( path -- path' )
"resource:" ?head [
left-trim-separators resource-path
normalize-pathname
] [
current-directory get prepend-path
] if ;
! Pathname presentations
TUPLE: pathname string ;
@ -314,7 +322,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 ;

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

@ -250,8 +250,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 }
@ -377,10 +378,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" }
@ -413,12 +417,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 +669,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 +685,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 +701,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 +804,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" } "." } ;

52
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,27 @@ 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
GENERIC: delegate ( obj -- delegate )
M: object delegate drop f ;
GENERIC: set-delegate ( delegate tuple -- )
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

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

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

2
core/math/intervals/intervals-tests.factor
View File

@ -188,7 +188,7 @@ IN: math.intervals.tests
{ max interval-max }
}
"math.ratios.private" vocab [
{ / interval/ } add
{ / interval/ } suffix
] when
random ;

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

17
core/optimizer/inlining/inlining.factor
View File

@ -70,12 +70,25 @@ DEFER: (flat-length)
] if ;
! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' )
{
fixnum bignum integer
ratio rational
float real
complex number
object
} [ class< ] with find nip ;
: math-both-known? ( word left right -- ? )
math-class-max swap specific-method ;
: inline-math-method ( #call word -- node )
over node-input-classes first2 3dup math-both-known?
[ math-method f splice-quot ] [ 2drop 2drop t ] if ;
over node-input-classes
[ first normalize-math-class ]
[ second normalize-math-class ] bi
3dup math-both-known?
[ math-method f splice-quot ]
[ 2drop 2drop t ] if ;
: inline-method ( #call -- node )
dup node-param {

27
core/optimizer/known-words/known-words.factor
View File

@ -60,7 +60,7 @@ sequences.private combinators ;
[ value-literal sequence? ] [ drop f ] if ;
: member-quot ( seq -- newquot )
[ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
[ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot f splice-quot ;
@ -75,7 +75,7 @@ sequences.private combinators ;
dup node-in-d second dup value? [
swap [
value-literal 0 `input literal,
general-t 0 `output class,
\ f class-not 0 `output class,
] set-constraints
] [
2drop
@ -87,29 +87,6 @@ sequences.private combinators ;
{ { @ @ } [ 2drop t ] }
} define-identities
! type applied to an object of a known type can be folded
: known-type? ( node -- ? )
node-class-first class-types length 1 number= ;
: fold-known-type ( node -- node )
dup node-class-first class-types inline-literals ;
\ type [
{ [ dup known-type? ] [ fold-known-type ] }
] define-optimizers
! if the result of type is n, then the object has type n
{ tag type } [
[
num-types get swap [
[
[ type>class object or 0 `input class, ] keep
0 `output literal,
] set-constraints
] curry each
] "constraints" set-word-prop
] each
! Specializers
{ 1+ 1- sq neg recip sgn } [
{ number } "specializer" set-word-prop

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

@ -269,7 +269,7 @@ generic.standard system ;
: comparison-constraints ( node true false -- )
>r >r dup node set intervals dup [
2dup
r> general-t (comparison-constraints)
r> \ f class-not (comparison-constraints)
r> \ f (comparison-constraints)
] [
r> r> 2drop 2drop

5
core/optimizer/specializers/specializers.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 vectors words strings layouts combinators
sequences.private classes generic.standard assocs ;
sequences.private classes generic.standard
generic.standard.engines assocs ;
IN: optimizer.specializers
: (make-specializer) ( class picker -- quot )
@ -32,7 +33,7 @@ IN: optimizer.specializers
: method-declaration ( method -- quot )
dup "method-generic" word-prop dispatch# object <array>
swap "method-class" word-prop add* ;
swap "method-class" word-prop prefix ;
: specialize-method ( quot method -- quot' )
method-declaration [ declare ] curry prepend ;

43
core/parser/parser.factor
View File

@ -294,7 +294,7 @@ M: no-word-error summary
scan {
{ ";" [ tuple f ] }
{ "<" [ scan-word ";" parse-tokens ] }
[ >r tuple ";" parse-tokens r> add* ]
[ >r tuple ";" parse-tokens r> prefix ]
} case ;
ERROR: staging-violation word ;
@ -365,7 +365,17 @@ ERROR: bad-number ;
: (:) CREATE-WORD parse-definition ;
: (M:) CREATE-METHOD parse-definition ;
SYMBOL: current-class
SYMBOL: current-generic
: (M:)
CREATE-METHOD
[
[ "method-class" word-prop current-class set ]
[ "method-generic" word-prop current-generic set ]
[ ] tri
parse-definition
] with-scope ;
: scan-object ( -- object )
scan-word dup parsing?
@ -467,18 +477,22 @@ SYMBOL: interactive-vocabs
nl
] when 2drop ;
: filter-moved ( assoc -- newassoc )
[
: filter-moved ( assoc1 assoc2 -- seq )
diff [
drop where dup [ first ] when
file get source-file-path =
] assoc-subset ;
] assoc-subset keys ;
: removed-definitions ( -- definitions )
: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions
[ get first2 union ] bi@ diff ;
[ get first2 union ] bi@ ;
: removed-classes ( -- assoc1 assoc2 )
new-definitions old-definitions
[ get second ] bi@ ;
: smudged-usage ( -- usages referenced removed )
removed-definitions filter-moved keys [
removed-definitions filter-moved [
outside-usages
[
empty? [ drop f ] [
@ -495,8 +509,10 @@ SYMBOL: interactive-vocabs
: fix-class-words ( -- )
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2 diff
[ nip dup reset-generic define-symbol ] assoc-each ;
new-definitions get first2
filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each
removed-classes
filter-moved [ class? ] subset [ reset-class ] each ;
: forget-smudged ( -- )
smudged-usage forget-all
@ -505,9 +521,10 @@ SYMBOL: interactive-vocabs
: finish-parsing ( lines quot -- )
file get
[ record-form ] keep
[ record-definitions ] keep
record-checksum ;
[ record-form ]
[ record-definitions ]
[ record-checksum ]
tri ;
: parse-stream ( stream name -- quot )
[

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

@ -57,8 +57,6 @@ unit-test
[ ] [ \ integer see ] unit-test
[ ] [ \ general-t see ] unit-test
[ ] [ \ generic see ] unit-test
[ ] [ \ duplex-stream see ] unit-test
@ -192,7 +190,7 @@ unit-test
"IN: prettyprint.tests"
": another-soft-break-layout ( node -- quot )"
" parse-error-file"
" [ <reversed> \"hello world foo\" add ] [ ] make ;"
" [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
} ;
[ t ] [

5
core/prettyprint/prettyprint.factor
View File

@ -7,7 +7,7 @@ vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
definitions effects classes.tuple io.files classes continuations
hashtables classes.mixin classes.union classes.predicate
combinators quotations ;
classes.singleton combinators quotations ;
: make-pprint ( obj quot -- block in use )
[
@ -254,6 +254,9 @@ M: predicate-class see-class*
"predicate-definition" word-prop pprint-elements
pprint-; block> block> ;
M: singleton-class see-class* ( class -- )
\ SINGLETON: pprint-word pprint-word ;
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word

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

@ -10,8 +10,8 @@ IN: quotations.tests
] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 ] [ 3 4 ] append ] unit-test
[ [ 1 2 3 ] ] [ [ 1 2 ] 3 add ] unit-test
[ [ 3 1 2 ] ] [ [ 1 2 ] 3 add* ] unit-test
[ [ 1 2 3 ] ] [ [ 1 2 ] 3 suffix ] unit-test
[ [ 3 1 2 ] ] [ [ 1 2 ] 3 prefix ] unit-test
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test

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

@ -61,8 +61,8 @@ ARTICLE: "sequences-access" "Accessing sequence elements"
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
{ $subsection add }
{ $subsection add* }
{ $subsection prefix }
{ $subsection suffix }
"Removing elements:"
{ $subsection remove }
{ $subsection seq-diff } ;
@ -641,22 +641,22 @@ HELP: push-new
}
{ $side-effects "seq" } ;
{ push push-new add add* } related-words
{ push push-new prefix suffix } related-words
HELP: add
HELP: suffix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the end of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" }
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 suffix ." "{ 1 2 3 4 }" }
} ;
HELP: add*
HELP: prefix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" }
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 prefix ." "{ 0 1 2 3 }" }
} ;
HELP: seq-diff
@ -940,7 +940,7 @@ HELP: unclip
{ $values { "seq" sequence } { "rest" sequence } { "first" object } }
{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first." }
{ $examples
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip add ." "{ 2 3 1 }" }
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip suffix ." "{ 2 3 1 }" }
} ;
HELP: unclip-slice

17
core/sequences/sequences.factor
View File

@ -416,6 +416,9 @@ PRIVATE>
swap >r [ push ] curry compose r> while
] keep { } like ; inline
: follow ( obj quot -- seq )
>r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
: index ( obj seq -- n )
[ = ] with find drop ;
@ -478,18 +481,18 @@ M: sequence <=>
: push-new ( elt seq -- ) [ delete ] 2keep push ;
: add ( seq elt -- newseq )
over >r over length 1+ r> [
[ >r over length r> set-nth-unsafe ] keep
[ 0 swap copy ] keep
] new-like ;
: add* ( seq elt -- newseq )
: prefix ( seq elt -- newseq )
over >r over length 1+ r> [
[ 0 swap set-nth-unsafe ] keep
[ 1 swap copy ] keep
] new-like ;
: suffix ( seq elt -- newseq )
over >r over length 1+ r> [
[ >r over length r> set-nth-unsafe ] keep
[ 0 swap copy ] keep
] new-like ;
: seq-diff ( seq1 seq2 -- newseq )
swap [ member? not ] curry subset ;

2
core/slots/slots.factor
View File

@ -14,7 +14,7 @@ C: <slot-spec> slot-spec
>r create-method r> define ;
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;
rot >fixnum prefix define-typecheck ;
: reader-quot ( decl -- quot )
[

2
core/splitting/splitting.factor
View File

@ -76,5 +76,5 @@ INSTANCE: groups sequence
1 head-slice* [
"\r" ?tail drop "\r" split
] map
] keep peek "\r" split add concat
] keep peek "\r" split suffix concat
] if ;

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

@ -243,7 +243,7 @@ HELP: flushable
HELP: t
{ $syntax "t" }
{ $values { "t" "the canonical truth value" } }
{ $description "The canonical instance of " { $link general-t } ". It is just a symbol." } ;
{ $class-description "The canonical truth value, which is an instance of itself." } ;
HELP: f
{ $syntax "f" }

17
core/syntax/syntax.factor
View File

@ -5,8 +5,8 @@ byte-vectors definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays float-vectors
classes.union classes.mixin classes.predicate compiler.units
combinators debugger ;
classes.union classes.mixin classes.predicate classes.singleton
compiler.units combinators debugger ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@ -55,7 +55,7 @@ IN: bootstrap.syntax
"BIN:" [ 2 parse-base ] define-syntax
"f" [ f parsed ] define-syntax
"t" "syntax" lookup define-symbol
"t" "syntax" lookup define-singleton-class
"CHAR:" [
scan {
@ -154,6 +154,11 @@ IN: bootstrap.syntax
parse-definition define-predicate-class
] define-syntax
"SINGLETON:" [
scan create-class-in
dup save-location define-singleton-class
] define-syntax
"TUPLE:" [
parse-tuple-definition define-tuple-class
] define-syntax
@ -185,4 +190,10 @@ IN: bootstrap.syntax
[ \ >> parse-until >quotation ] with-compilation-unit
call
] define-syntax
"call-next-method" [
current-class get literalize parsed
current-generic get literalize parsed
\ (call-next-method) parsed
] define-syntax
] with-compilation-unit

108
core/system/system-docs.factor
View File

@ -1,20 +1,12 @@
USING: generic help.markup help.syntax kernel math memory
namespaces sequences kernel.private strings ;
namespaces sequences kernel.private strings classes.singleton ;
IN: system
ARTICLE: "os" "System interface"
"Operating system detection:"
{ $subsection os }
{ $subsection unix? }
{ $subsection macosx? }
{ $subsection solaris? }
{ $subsection windows? }
{ $subsection winnt? }
{ $subsection win32? }
{ $subsection win64? }
{ $subsection wince? }
"Processor detection:"
{ $subsection cpu }
ABOUT: "system"
ARTICLE: "system" "System interface"
{ $subsection "cpu" }
{ $subsection "os" }
"Reading environment variables:"
{ $subsection os-env }
{ $subsection os-envs }
@ -27,63 +19,51 @@ ARTICLE: "os" "System interface"
{ $subsection exit }
{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ;
ABOUT: "os"
ARTICLE: "cpu" "Processor Detection"
"Processor detection:"
{ $subsection cpu }
"Supported processors:"
{ $subsection x86.32 }
{ $subsection x86.64 }
{ $subsection ppc }
{ $subsection arm }
"Processor families:"
{ $subsection x86 } ;
ARTICLE: "os" "Operating System Detection"
"Operating system detection:"
{ $subsection os }
"Supported operating systems:"
{ $subsection freebsd }
{ $subsection linux }
{ $subsection macosx }
{ $subsection openbsd }
{ $subsection netbsd }
{ $subsection solaris }
{ $subsection wince }
{ $subsection winnt }
"Operating system families:"
{ $subsection bsd }
{ $subsection unix }
{ $subsection windows } ;
HELP: cpu
{ $values { "cpu" string } }
{ $values { "class" singleton-class } }
{ $description
"Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:"
{ $code "x86.32" "x86.64" "ppc" "arm" }
"Outputs a singleton class with the name of the current CPU architecture."
} ;
HELP: os
{ $values { "os" string } }
{ $values { "class" singleton-class } }
{ $description
"Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:"
{ $code
"freebsd"
"linux"
"macosx"
"openbsd"
"netbsd"
"solaris"
"wince"
"winnt"
}
"Outputs a singleton class with the name of the current operating system family."
} ;
HELP: embedded?
{ $values { "?" "a boolean" } }
{ $description "Tests if this Factor instance is embedded in another application." } ;
HELP: windows?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on Windows." } ;
HELP: winnt?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on Windows XP or Vista." } ;
HELP: wince?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on Windows CE." } ;
HELP: macosx?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on Mac OS X." } ;
HELP: linux?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on Linux." } ;
HELP: solaris?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on Solaris." } ;
HELP: bsd?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on FreeBSD/OpenBSD/NetBSD." } ;
HELP: exit ( n -- )
{ $values { "n" "an integer exit code" } }
{ $description "Exits the Factor process." } ;
@ -120,14 +100,6 @@ HELP: set-os-envs
{ os-env os-envs set-os-envs } related-words
HELP: win32?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on 32-bit Windows." } ;
HELP: win64?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on 64-bit Windows." } ;
HELP: image
{ $values { "path" "a pathname string" } }
{ $description "Outputs the pathname of the currently running Factor image." } ;
@ -135,7 +107,3 @@ HELP: image
HELP: vm
{ $values { "path" "a pathname string" } }
{ $description "Outputs the pathname of the currently running Factor VM." } ;
HELP: unix?
{ $values { "?" "a boolean" } }
{ $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ;

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

@ -1,11 +1,11 @@
USING: math tools.test system prettyprint namespaces kernel ;
IN: system.tests
wince? [
os wince? [
[ ] [ os-envs . ] unit-test
] unless
unix? [
os unix? [
[ ] [ os-envs "envs" set ] unit-test
[ ] [ { { "A" "B" } } set-os-envs ] unit-test
[ "B" ] [ "A" os-env ] unit-test

89
core/system/system.factor
View File

@ -2,49 +2,70 @@
! See http://factorcode.org/license.txt for BSD license.
IN: system
USING: kernel kernel.private sequences math namespaces
splitting assocs system.private layouts ;
init splitting assocs system.private layouts words ;
: cpu ( -- cpu ) 8 getenv ; foldable
SINGLETON: x86.32
SINGLETON: x86.64
SINGLETON: arm
SINGLETON: ppc
: os ( -- os ) 9 getenv ; foldable
UNION: x86 x86.32 x86.64 ;
: cpu ( -- class ) \ cpu get ;
SINGLETON: winnt
SINGLETON: wince
UNION: windows winnt wince ;
SINGLETON: freebsd
SINGLETON: netbsd
SINGLETON: openbsd
SINGLETON: solaris
SINGLETON: macosx
SINGLETON: linux
UNION: bsd freebsd netbsd openbsd macosx ;
UNION: unix bsd solaris linux ;
: os ( -- class ) \ os get ;
<PRIVATE
: string>cpu ( str -- class )
H{
{ "x86.32" x86.32 }
{ "x86.64" x86.64 }
{ "arm" arm }
{ "ppc" ppc }
} at ;
: string>os ( str -- class )
H{
{ "winnt" winnt }
{ "wince" wince }
{ "freebsd" freebsd }
{ "netbsd" netbsd }
{ "openbsd" openbsd }
{ "solaris" solaris }
{ "macosx" macosx }
{ "linux" linux }
} at ;
PRIVATE>
[
8 getenv string>cpu \ cpu set-global
9 getenv string>os \ os set-global
] "system" add-init-hook
: image ( -- path ) 13 getenv ;
: vm ( -- path ) 14 getenv ;
: wince? ( -- ? )
os "wince" = ; foldable
: winnt? ( -- ? )
os "winnt" = ; foldable
: windows? ( -- ? )
wince? winnt? or ; foldable
: win32? ( -- ? )
winnt? cell 4 = and ; foldable
: win64? ( -- ? )
winnt? cell 8 = and ; foldable
: macosx? ( -- ? ) os "macosx" = ; foldable
: embedded? ( -- ? ) 15 getenv ;
: unix? ( -- ? )
os {
"freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris"
} member? ;
: bsd? ( -- ? )
os { "freebsd" "openbsd" "netbsd" "macosx" } member? ;
: linux? ( -- ? )
os "linux" = ;
: solaris? ( -- ? )
os "solaris" = ;
: os-envs ( -- assoc )
(os-envs) [ "=" split1 ] H{ } map>assoc ;

2
core/vocabs/loader/loader.factor
View File

@ -20,7 +20,7 @@ V{
: vocab-dir+ ( vocab str/f -- path )
>r vocab-name "." split r>
[ >r dup peek r> append add ] when*
[ >r dup peek r> append suffix ] when*
"/" join ;
: vocab-dir? ( root name -- ? )

10
core/vocabs/vocabs.factor
View File

@ -6,13 +6,11 @@ IN: vocabs
SYMBOL: dictionary
TUPLE: vocab
TUPLE: vocab < identity-tuple
name words
main help
source-loaded? docs-loaded? ;
M: vocab equal? 2drop f ;
: <vocab> ( name -- vocab )
H{ } clone
{ set-vocab-name set-vocab-words }
@ -82,7 +80,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
: child-vocab? ( prefix name -- ? )
2dup = pick empty? or
[ 2drop t ] [ swap CHAR: . add head? ] if ;
[ 2drop t ] [ swap CHAR: . suffix head? ] if ;
: child-vocabs ( vocab -- seq )
vocab-name vocabs [ child-vocab? ] with subset ;
@ -92,10 +90,6 @@ TUPLE: vocab-link name ;
: <vocab-link> ( name -- vocab-link )
vocab-link construct-boa ;
M: vocab-link equal?
over vocab-link?
[ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ;
M: vocab-link hashcode*
vocab-link-name hashcode* ;

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

@ -324,11 +324,7 @@ HELP: constructor-word
{ $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." }
{ $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "<salmon>" } } ;
HELP: forget-word
{ $values { "word" word } }
{ $description "Removes a word from its vocabulary. User code should call " { $link forget } " instead, since it also does the right thing when forgetting class words." } ;
{ POSTPONE: FORGET: forget forget-word forget-vocab } related-words
{ POSTPONE: FORGET: forget forget* forget-vocab } related-words
HELP: target-word
{ $values { "word" word } { "target" word } }

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