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 } ":" { $examples "Here is a typical usage of " { $link add-library } ":"
{ $code { $code
"<< \"freetype\" {" "<< \"freetype\" {"
" { [ macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
" { [ windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }" " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
" { [ t ] [ drop ] }" " { [ t ] [ drop ] }"
"} cond >>" "} 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 f <displaced-alien> { simple-c-ptr } declare ; inline
: alien>native-string ( alien -- string ) : 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 ( dll -- string )
(dll-path) alien>native-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 ) : parse-array-type ( name -- array )
"[" split unclip "[" split unclip
>r [ "]" ?tail drop string>number ] map r> add* ; >r [ "]" ?tail drop string>number ] map r> prefix ;
M: string c-type ( name -- type ) M: string c-type ( name -- type )
CHAR: ] over member? [ CHAR: ] over member? [
@ -162,7 +162,7 @@ DEFER: >c-ushort-array
>r >c-ushort-array r> byte-array>memory ; >r >c-ushort-array r> byte-array>memory ;
: (define-nth) ( word type quot -- ) : (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 ) : nth-word ( name vocab -- word )
>r "-nth" append r> create ; >r "-nth" append r> create ;
@ -199,12 +199,12 @@ M: long-long-type box-return ( type -- )
f swap box-parameter ; f swap box-parameter ;
: define-deref ( name vocab -- ) : define-deref ( name vocab -- )
>r dup CHAR: * add* r> create >r dup CHAR: * prefix r> create
swap c-getter 0 add* define-inline ; swap c-getter 0 prefix define-inline ;
: define-out ( name vocab -- ) : define-out ( name vocab -- )
over [ <c-object> tuck 0 ] over c-setter append swap 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 -- ? ) : c-bool> ( int -- ? )
zero? not ; zero? not ;
@ -257,7 +257,7 @@ M: long-long-type box-return ( type -- )
#! staging violations #! staging violations
dup array? [ dup array? [
unclip >r [ dup word? [ word-def call ] when ] map unclip >r [ dup word? [ word-def call ] when ] map
r> add* r> prefix
] when ; ] when ;
: malloc-file-contents ( path -- alien len ) : 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 [ 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 ] with-compilation-unit

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

@ -18,7 +18,7 @@ IN: alien.compiler
: alien-node-parameters* ( node -- seq ) : alien-node-parameters* ( node -- seq )
dup parameters>> dup parameters>>
swap return>> large-struct? [ "void*" add* ] when ; swap return>> large-struct? [ "void*" prefix ] when ;
: alien-node-return* ( node -- ctype ) : alien-node-return* ( node -- ctype )
return>> dup large-struct? [ drop "void" ] when ; 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 dup ?word-name swap 2array
over slot-spec-name over slot-spec-name
rot slot-spec-type 2array 2array 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 ( slot-spec class -- )
($spec-reader-values) $values ; ($spec-reader-values) $values ;
@ -16,9 +16,9 @@ kernel words slots assocs namespaces ;
: $spec-reader-description ( slot-spec class -- ) : $spec-reader-description ( slot-spec class -- )
[ [
"Outputs the value stored in the " , "Outputs the value stored in the " ,
{ $snippet } rot slot-spec-name add , { $snippet } rot slot-spec-name suffix ,
" slot of " , " slot of " ,
{ $instance } swap add , { $instance } swap suffix ,
" instance." , " instance." ,
] { } make $description ; ] { } make $description ;
@ -43,9 +43,9 @@ M: word slot-specs "slots" word-prop ;
: $spec-writer-description ( slot-spec class -- ) : $spec-writer-description ( slot-spec class -- )
[ [
"Stores a new value to the " , "Stores a new value to the " ,
{ $snippet } rot slot-spec-name add , { $snippet } rot slot-spec-name suffix ,
" slot of " , " slot of " ,
{ $instance } swap add , { $instance } swap suffix ,
" instance." , " instance." ,
] { } make $description ; ] { } make $description ;

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

@ -16,7 +16,7 @@ IN: alien.structs
] reduce ; ] reduce ;
: define-struct-slot-word ( spec word quot -- ) : 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 -- ) : define-getter ( type spec -- )
[ set-reader-props ] keep [ set-reader-props ] keep

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

@ -16,6 +16,22 @@ $nl
"To make an assoc into an alist:" "To make an assoc into an alist:"
{ $subsection >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" ARTICLE: "assocs-protocol" "Associative mapping protocol"
"All associative mappings must be instances of a mixin class:" "All associative mappings must be instances of a mixin class:"
{ $subsection assoc } { $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. ! 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 IN: assocs
MIXIN: assoc MIXIN: assoc
@ -189,3 +190,24 @@ M: f clear-assoc drop ;
M: f assoc-like drop dup assoc-empty? [ drop f ] when ; M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
INSTANCE: sequence assoc 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 "alien.remote-control" require
] unless ] unless
"cpu." cpu append require "cpu." cpu word-name append require
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
enable-compiler enable-compiler

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

@ -12,7 +12,8 @@ io.encodings.binary ;
IN: bootstrap.image IN: bootstrap.image
: my-arch ( -- arch ) : 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-image-name ( arch -- string )
"boot." swap ".image" 3append ; "boot." swap ".image" 3append ;
@ -305,7 +306,7 @@ M: float-array ' float-array emit-dummy-array ;
! Tuples ! Tuples
: (emit-tuple) ( tuple -- pointer ) : (emit-tuple) ( tuple -- pointer )
[ tuple>array 1 tail-slice ] [ 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 ; tuple type-number dup [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer ) : 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. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-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 BIN: 111 tag-mask set
8 num-tags set 8 num-tags set
@ -15,6 +16,7 @@ H{
{ bignum BIN: 001 } { bignum BIN: 001 }
{ tuple BIN: 010 } { tuple BIN: 010 }
{ object BIN: 011 } { object BIN: 011 }
{ hi-tag BIN: 011 }
{ ratio BIN: 100 } { ratio BIN: 100 }
{ float BIN: 101 } { float BIN: 101 }
{ complex BIN: 110 } { complex BIN: 110 }

136
core/bootstrap/primitives.factor
View File

@ -31,6 +31,7 @@ crossref off
"syntax" vocab vocab-words bootstrap-syntax set "syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set H{ } clone dictionary set
H{ } clone changed-words set H{ } clone changed-words set
H{ } clone forgotten-definitions set
H{ } clone root-cache set H{ } clone root-cache set
H{ } clone source-files set H{ } clone source-files set
H{ } clone update-map set H{ } clone update-map set
@ -101,17 +102,24 @@ num-types get f <array> builtins set
} [ create-vocab drop ] each } [ create-vocab drop ] each
! Builtin classes ! 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 [ dup tag ] % \ hi-tag tag-number , \ eq? ,
[ tag-mask get < \ tag \ type ? , ] [ , ] bi [ [ hi-tag ] % , \ eq? , ] [ ] make ,
\ eq? , [ drop f ] ,
\ if ,
] [ ] make ; ] [ ] 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 -- ) : define-builtin-predicate ( class -- )
[ dup builtin-predicate-quot define-predicate ] dup builtin-predicate-quot define-predicate ;
[ predicate-word make-inline ]
bi ;
: lookup-type-number ( word -- n ) : lookup-type-number ( word -- n )
global [ target-word ] bind type-number ; global [ target-word ] bind type-number ;
@ -119,27 +127,56 @@ num-types get f <array> builtins set
: register-builtin ( class -- ) : register-builtin ( class -- )
[ dup lookup-type-number "type" set-word-prop ] [ dup lookup-type-number "type" set-word-prop ]
[ dup "type" word-prop builtins get set-nth ] [ dup "type" word-prop builtins get set-nth ]
bi ; [ f f builtin-class define-class ]
tri ;
: define-builtin-slots ( symbol slotspec -- ) : define-builtin-slots ( symbol slotspec -- )
[ drop ] [ 1 simple-slots ] 2bi [ drop ] [ 1 simple-slots ] 2bi
[ "slots" set-word-prop ] [ define-slots ] 2bi ; [ "slots" set-word-prop ] [ define-slots ] 2bi ;
: define-builtin ( symbol slotspec -- ) : define-builtin ( symbol slotspec -- )
>r >r [ define-builtin-predicate ] keep
{
[ register-builtin ]
[ f f builtin-class define-class ]
[ define-builtin-predicate ]
[ ]
} cleave
r> define-builtin-slots ; r> define-builtin-slots ;
! Forward definitions "fixnum" "math" create register-builtin
"object" "kernel" create t "class" set-word-prop "bignum" "math" create register-builtin
"object" "kernel" create union-class "metaclass" set-word-prop "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 { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
@ -328,47 +365,28 @@ define-builtin
} }
} define-builtin } define-builtin
"tuple" "kernel" create { } define-builtin "tuple" "kernel" create {
[ { } define-builtin ]
"tuple" "kernel" lookup [ { "delegate" } "slot-names" set-word-prop ]
{ [ define-tuple-layout ]
{ [
{ "object" "kernel" } {
"delegate" {
{ "delegate" "kernel" } { "object" "kernel" }
{ "set-delegate" "kernel" } "delegate"
} { "delegate" "kernel" }
} { "set-delegate" "kernel" }
[ drop ] [ generate-tuple-slots ] 2bi }
[ [ name>> ] map "slot-names" set-word-prop ] }
[ "slots" set-word-prop ] [ drop ] [ generate-tuple-slots ] 2bi
[ define-slots ] 2tri [ "slots" set-word-prop ]
[ define-slots ]
"tuple" "kernel" lookup define-tuple-layout 2bi
]
! Define general-t type, which is any object that is not f. } cleave
"general-t" "kernel" create
f "f" "syntax" lookup builtins get remove [ ] subset union-class
define-class
"f" "syntax" create [ not ] "predicate" set-word-prop "f" "syntax" create [ not ] "predicate" set-word-prop
"f?" "syntax" create "syntax" vocab-words delete-at "f?" "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
! Create special tombstone values ! Create special tombstone values
"tombstone" "hashtables.private" create "tombstone" "hashtables.private" create
@ -638,7 +656,6 @@ f builtins get num-tags get tail union-class define-class
{ "code-room" "memory" } { "code-room" "memory" }
{ "os-env" "system" } { "os-env" "system" }
{ "millis" "system" } { "millis" "system" }
{ "type" "kernel.private" }
{ "tag" "kernel.private" } { "tag" "kernel.private" }
{ "modify-code-heap" "compiler.units" } { "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" } { "dlopen" "alien" }
@ -710,7 +727,6 @@ f builtins get num-tags get tail union-class define-class
{ "(sleep)" "threads.private" } { "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" } { "<float-array>" "float-arrays" }
{ "<tuple-boa>" "classes.tuple.private" } { "<tuple-boa>" "classes.tuple.private" }
{ "class-hash" "kernel.private" }
{ "callstack>array" "kernel" } { "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" } { "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "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 ! Rehash hashtables, since bootstrap.image creates them
! using the host image's hashing algorithms ! using the host image's hashing algorithms
[ hashtable? ] instances [ rehash ] each [ hashtable? ] instances [ rehash ] each
boot boot
] % ] %

6
core/bootstrap/stage2.factor
View File

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

2
core/bootstrap/syntax.factor
View File

@ -43,6 +43,7 @@ IN: bootstrap.syntax
"PRIMITIVE:" "PRIMITIVE:"
"PRIVATE>" "PRIVATE>"
"SBUF\"" "SBUF\""
"SINGLETON:"
"SYMBOL:" "SYMBOL:"
"TUPLE:" "TUPLE:"
"T{" "T{"
@ -66,6 +67,7 @@ IN: bootstrap.syntax
"CS{" "CS{"
"<<" "<<"
">>" ">>"
"call-next-method"
} [ "syntax" create drop ] each } [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol "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 tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable vectors definitions source-files compiler.units growable
random inference effects ; random inference effects kernel.private ;
: class= [ class< ] 2keep swap class< and ; : class= [ class< ] 2keep swap class< and ;
@ -23,8 +23,8 @@ random inference effects ;
[ t ] [ number object number class-and* ] unit-test [ t ] [ number object number class-and* ] unit-test
[ t ] [ object number number class-and* ] unit-test [ t ] [ object number number class-and* ] unit-test
[ t ] [ slice reversed null class-and* ] unit-test [ t ] [ slice reversed null class-and* ] unit-test
[ t ] [ general-t \ f null class-and* ] unit-test [ t ] [ \ f class-not \ f null class-and* ] unit-test
[ t ] [ general-t \ f object class-or* ] unit-test [ t ] [ \ f class-not \ f object class-or* ] unit-test
TUPLE: first-one ; TUPLE: first-one ;
TUPLE: second-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 ] [ 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 ] [ [ t ] [
growable tuple sequence class-and class< 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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables vectors assocs namespaces words sorting layouts math hashtables
; kernel.private ;
IN: classes.algebra IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value ) : 2cache ( key1 key2 assoc quot -- value )
@ -138,10 +138,10 @@ C: <anonymous-complement> anonymous-complement
members>> [ class-and ] with map <anonymous-union> ; members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class ) : 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 ) : right-anonymous-intersection-and ( first second -- class )
members>> swap add <anonymous-intersection> ; members>> swap suffix <anonymous-intersection> ;
: (class-and) ( first second -- class ) : (class-and) ( first second -- class )
{ {
@ -158,10 +158,10 @@ C: <anonymous-complement> anonymous-complement
} cond ; } cond ;
: left-anonymous-union-or ( first second -- class ) : 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 ) : right-anonymous-union-or ( first second -- class )
members>> swap add <anonymous-union> ; members>> swap suffix <anonymous-union> ;
: (class-or) ( first second -- class ) : (class-or) ( first second -- class )
{ {
@ -211,12 +211,6 @@ C: <anonymous-complement> anonymous-complement
: flatten-class ( class -- assoc ) : flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-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-builtin-class ( class -- assoc )
flatten-class [ flatten-class [
dup tuple class< [ 2drop tuple tuple ] when dup tuple class< [ 2drop tuple tuple ] when
@ -229,5 +223,5 @@ C: <anonymous-complement> anonymous-complement
: class-tags ( class -- tag/f ) : class-tags ( class -- tag/f )
class-types [ class-types [
dup num-tags get >= dup num-tags get >=
[ drop object tag-number ] when [ drop \ hi-tag tag-number ] when
] map prune ; ] 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 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 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 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:" "The set of class predicate words is a class:"
{ $subsection predicate } { $subsection predicate }
@ -47,6 +46,7 @@ $nl
"Other sorts of classes:" "Other sorts of classes:"
{ $subsection "builtin-classes" } { $subsection "builtin-classes" }
{ $subsection "unions" } { $subsection "unions" }
{ $subsection "singletons" }
{ $subsection "mixins" } { $subsection "mixins" }
{ $subsection "predicates" } { $subsection "predicates" }
"Classes can be inspected and operated upon:" "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 tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files classes.algebra vectors definitions source-files
compiler.units ; compiler.units kernel.private ;
IN: classes.tests IN: classes.tests
! DEFER: bah ! DEFER: bah
@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
! Test generic see and parsing ! Test generic see and parsing
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] [ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test [ [ \ 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-and-cache get clear-assoc
class-or-cache get clear-assoc ; class-or-cache get clear-assoc ;
PREDICATE: class < word ( obj -- ? ) "class" word-prop ;
SYMBOL: update-map SYMBOL: update-map
PREDICATE: class < word
"class" word-prop ;
SYMBOL: builtins SYMBOL: builtins
PREDICATE: builtin-class < class PREDICATE: builtin-class < class
@ -58,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
dup class? [ "superclass" word-prop ] [ drop f ] if ; dup class? [ "superclass" word-prop ] [ drop f ] if ;
: superclasses ( class -- supers ) : superclasses ( class -- supers )
[ dup ] [ dup superclass swap ] [ ] unfold reverse nip ; [ superclass ] follow reverse ;
: members ( class -- seq ) : members ( class -- seq )
#! Output f for non-classes to work with algebra code #! Output f for non-classes to work with algebra code
@ -72,7 +74,7 @@ M: word reset-class drop ;
! update-map ! update-map
: class-uses ( class -- seq ) : class-uses ( class -- seq )
dup members swap superclass [ add ] when* ; [ members ] [ superclass ] bi [ suffix ] when* ;
: class-usages ( class -- assoc ) : class-usages ( class -- assoc )
[ update-map get at ] closure ; [ update-map get at ] closure ;
@ -83,7 +85,7 @@ M: word reset-class drop ;
: update-map- ( class -- ) : update-map- ( class -- )
dup class-uses update-map get remove-vertex ; 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 ] [ dup [ bootstrap-word ] when "superclass" set ]
[ [ bootstrap-word ] map "members" set ] [ [ bootstrap-word ] map "members" set ]
@ -92,12 +94,16 @@ M: word reset-class drop ;
] H{ } make-assoc ; ] H{ } make-assoc ;
: (define-class) ( word props -- ) : (define-class) ( word props -- )
over reset-class >r
over deferred? [ over define-symbol ] when dup reset-class
>r dup word-props r> union over set-word-props dup deferred? [ dup define-symbol ] when
dup predicate-word 2dup 1quotation "predicate" set-word-prop dup word-props
over "predicating" set-word-prop r> union over set-word-props
t "class" set-word-prop ; dup predicate-word
[ 1quotation "predicate" set-word-prop ]
[ swap "predicating" set-word-prop ]
[ drop t "class" set-word-prop ]
2tri ;
PRIVATE> PRIVATE>
@ -105,25 +111,28 @@ GENERIC: update-class ( class -- )
M: class update-class drop ; M: class update-class drop ;
: update-classes ( assoc -- )
[ drop update-class ] assoc-each ;
GENERIC: update-methods ( assoc -- ) GENERIC: update-methods ( assoc -- )
: update-classes ( class -- )
class-usages
[ [ drop update-class ] assoc-each ]
[ update-methods ]
bi ;
: define-class ( word superclass members metaclass -- ) : define-class ( word superclass members metaclass -- )
#! If it was already a class, update methods after. #! If it was already a class, update methods after.
reset-caches reset-caches
define-class-props make-class-props
[ drop update-map- ] [ drop update-map- ]
[ (define-class) ] [ [ (define-class) ]
drop [ drop update-map+ ]
[ update-map+ ] [ 2tri ;
class-usages
[ update-classes ]
[ update-methods ] bi
] bi
] 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 ; PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class M: mixin-class reset-class
{ "metaclass" "members" "mixin" } reset-props ; { "class" "metaclass" "members" "mixin" } reset-props ;
: redefine-mixin-class ( class members -- ) : redefine-mixin-class ( class members -- )
dupd define-union-class dupd define-union-class
@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ;
swap redefine-mixin-class ; inline swap redefine-mixin-class ; inline
: add-mixin-instance ( class mixin -- ) : 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 -- ) : remove-mixin-instance ( class mixin -- )
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ; [ [ 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 ; ] [ ] make ;
: define-predicate-class ( class superclass definition -- ) : define-predicate-class ( class superclass definition -- )
>r dupd f predicate-class define-class [ drop f predicate-class define-class ]
r> dupd "predicate-definition" set-word-prop [ nip "predicate-definition" set-word-prop ]
dup predicate-quot define-predicate ; [
2drop
[ dup predicate-quot define-predicate ]
[ update-classes ]
bi
] 3tri ;
M: predicate-class reset-class M: predicate-class reset-class
{ {
"metaclass" "predicate-definition" "superclass" "class"
"metaclass"
"predicate-definition"
"superclass"
} reset-props ; } 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." } { $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." } ; { $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 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." { $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 $nl

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

@ -62,13 +62,13 @@ C: <point> point
[ 200 ] [ "p" get y>> ] unit-test [ 200 ] [ "p" get y>> ] unit-test
[ f ] [ "p" get "z>>" "accessors" lookup execute ] 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 [ 4 ] [ "p" get tuple-size ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] 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 [ 3 ] [ "p" get tuple-size ] unit-test
@ -394,7 +394,9 @@ test-server-slot-values
! Reshape crash ! Reshape crash
TUPLE: test1 a ; TUPLE: test2 < test1 b ; 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 : test-a/b
[ "a" ] [ "test" get a>> ] unit-test [ "a" ] [ "test" get a>> ] unit-test
@ -509,3 +511,45 @@ USE: vocabs
define-tuple-class define-tuple-class
] with-compilation-unit ] with-compilation-unit
] unit-test ] 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 ) 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 ; M: tuple tuple-layout 1 slot ;
@ -40,7 +40,9 @@ PRIVATE>
[ drop ] [ no-tuple-class ] if ; [ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array ) : 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 ) : tuple-slots ( tuple -- array )
prepare-tuple>array drop copy-tuple-slots ; prepare-tuple>array drop copy-tuple-slots ;
@ -120,17 +122,8 @@ PRIVATE>
: define-tuple-layout ( class -- ) : define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ; 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 ) : 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 ) : compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ; >r all-slot-names r> [ index ] curry map ;
@ -161,25 +154,23 @@ PRIVATE>
: update-tuples-after ( class -- ) : update-tuples-after ( class -- )
outdated-tuples get [ all-slot-names ] cache drop ; outdated-tuples get [ all-slot-names ] cache drop ;
: subclasses ( class -- classes ) M: tuple-class update-class
class-usages keys [ tuple-class? ] subset ;
: each-subclass ( class quot -- )
>r subclasses r> each ; inline
: define-tuple-shape ( class -- )
[ define-tuple-slots ]
[ define-tuple-layout ] [ define-tuple-layout ]
[ define-tuple-slots ]
[ define-tuple-predicate ] [ define-tuple-predicate ]
tri ; tri ;
: define-new-tuple-class ( class superclass slots -- ) : define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ] [ drop f tuple-class define-class ]
[ nip "slot-names" set-word-prop ] [ nip "slot-names" set-word-prop ]
[ [ 2drop update-classes ]
2drop 3tri ;
[ define-tuple-shape ] each-subclass
] 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 -- ) : redefine-tuple-class ( class superclass slots -- )
[ [
@ -191,9 +182,8 @@ PRIVATE>
tri tri
] each-subclass ] each-subclass
] ]
[ nip forget-removed-slots ]
[ define-new-tuple-class ] [ define-new-tuple-class ]
3tri ; 3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? ) : tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
@ -214,6 +204,22 @@ M: tuple-class define-tuple-class
[ define-tuple-class ] [ 2drop ] 3bi [ define-tuple-class ] [ 2drop ] 3bi
dup [ construct-boa throw ] curry define ; 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 M: tuple clone
(clone) dup delegate clone over set-delegate ; (clone) dup delegate clone over set-delegate ;
@ -227,26 +233,13 @@ M: tuple hashcode*
] 2curry reduce ] 2curry reduce
] recursive-hashcode ; ] recursive-hashcode ;
M: tuple-class reset-class ! Deprecated
{ "metaclass" "superclass" "slots" "layout" } reset-props ;
M: object get-slots ( obj slots -- ... ) M: object get-slots ( obj slots -- ... )
[ execute ] with each ; [ 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 -- ) M: object set-slots ( ... obj slots -- )
<reversed> get-slots ; <reversed> get-slots ;
M: object construct ( ... slots class -- tuple ) : delegates ( obj -- seq ) [ delegate ] follow ;
construct-empty [ swap set-slots ] keep ;
: delegates ( obj -- seq )
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline : 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. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes USING: words sequences kernel assocs combinators classes
generic.standard namespaces arrays math quotations ; namespaces arrays math quotations ;
IN: classes.union IN: classes.union
PREDICATE: union-class < class PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ; "metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes. ! Union classes for dispatch on multiple classes.
: small-union-predicate-quot ( members -- quot ) : union-predicate-quot ( members -- quot )
dup empty? [ dup empty? [
drop [ drop f ] drop [ drop f ]
] [ ] [
unclip first "predicate" word-prop swap unclip "predicate" word-prop swap [
[ >r "predicate" word-prop [ dup ] prepend r> ] "predicate" word-prop [ dup ] prepend
assoc-map alist>quot [ drop t ]
] if ; ] { } map>assoc alist>quot
: 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
] if ; ] if ;
: define-union-predicate ( class -- ) : define-union-predicate ( class -- )
@ -36,7 +24,9 @@ PREDICATE: union-class < class
M: union-class update-class define-union-predicate ; M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- ) : 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 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 ; [ call ] with each ;
: cleave>quot ( seq -- quot ) : cleave>quot ( seq -- quot )
[ [ keep ] curry ] map concat [ drop ] append ; [ [ keep ] curry ] map concat [ drop ] append [ ] like ;
: 2cleave ( x seq -- ) : 2cleave ( x seq -- )
[ [ call ] 3keep drop ] each 2drop ; [ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot ) : 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 ) : spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ] [ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi [ [ [ r> ] prepend ] map concat ] bi
append ; append [ ] like ;
: spread ( objs... seq -- ) : spread ( objs... seq -- )
spread>quot call ; spread>quot call ;
@ -43,7 +49,7 @@ ERROR: no-case ;
: with-datastack ( stack quot -- newstack ) : with-datastack ( stack quot -- newstack )
datastack >r datastack >r
>r >array set-datastack r> call >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 ) : recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
@ -66,7 +72,7 @@ M: hashtable hashcode*
reverse [ no-cond ] swap alist>quot ; reverse [ no-cond ] swap alist>quot ;
: linear-case-quot ( default assoc -- 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 ; alist>quot ;
: (distribute-buckets) ( buckets pair keys -- ) : (distribute-buckets) ( buckets pair keys -- )

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

@ -47,7 +47,7 @@ SYMBOL: main-vocab-hook
] bind ; ] bind ;
: ignore-cli-args? ( -- ? ) : ignore-cli-args? ( -- ? )
macosx? "run" get "ui" = and ; os macosx? "run" get "ui" = and ;
: script-mode ( -- ) : script-mode ( -- )
t "quiet" set-global 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 ; assocs words.private sequences compiler.units ;
IN: compiler 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" 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." "Normally, new word definitions are recompiled automatically. This can be changed:"
$nl { $subsection disable-compiler }
"The main entry point to the optimizing compiler:" { $subsection enable-compiler }
"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
{ $subsection optimized-recompile-hook } { $subsection optimized-recompile-hook }
"Removing a word's optimized definition:" "Removing a word's optimized definition:"
{ $subsection decompile } { $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" ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:" "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 compiled get >alist
] with-scope ; ] with-scope ;
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
: recompile-all ( -- ) : recompile-all ( -- )
forget-errors all-words compile ; 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
[ -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 [ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 2 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 [ 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 [ 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 ! regression
[ 3 ] [ [ 3 ] [
100001 f <array> 3 100000 pick set-nth 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 ] [ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test 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 ! Test literals in either side of a shuffle
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
@ -176,14 +172,14 @@ TUPLE: my-tuple ;
[ 1 t ] [ [ 1 t ] [
B{ 1 2 3 4 } [ B{ 1 2 3 4 } [
{ c-ptr } declare { c-ptr } declare
[ 0 alien-unsigned-1 ] keep type [ 0 alien-unsigned-1 ] keep hi-tag
] compile-call byte-array type-number = ] compile-call byte-array type-number =
] unit-test ] unit-test
[ t ] [ [ t ] [
B{ 1 2 3 4 } [ B{ 1 2 3 4 } [
{ c-ptr } declare { c-ptr } declare
0 alien-cell type 0 alien-cell hi-tag
] compile-call alien type-number = ] compile-call alien type-number =
] unit-test ] 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 ; byte-arrays bit-arrays float-arrays combinators words ;
IN: cpu.architecture IN: cpu.architecture
SYMBOL: compiler-backend
! A pseudo-register class for parameters spilled on the stack ! A pseudo-register class for parameters spilled on the stack
TUPLE: stack-params ; TUPLE: stack-params ;
@ -26,122 +24,122 @@ GENERIC: vregs ( register-class -- regs )
! Load a literal (immediate or indirect) ! Load a literal (immediate or indirect)
GENERIC# load-literal 1 ( obj vreg -- ) 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* ( -- n )
\ stack-frame get stack-frame ; \ stack-frame get stack-frame ;
! Set up caller stack frame ! Set up caller stack frame
HOOK: %prologue compiler-backend ( n -- ) HOOK: %prologue cpu ( n -- )
: %prologue-later \ %prologue-later , ; : %prologue-later \ %prologue-later , ;
! Tear down stack frame ! Tear down stack frame
HOOK: %epilogue compiler-backend ( n -- ) HOOK: %epilogue cpu ( n -- )
: %epilogue-later \ %epilogue-later , ; : %epilogue-later \ %epilogue-later , ;
! Store word XT in stack frame ! Store word XT in stack frame
HOOK: %save-word-xt compiler-backend ( -- ) HOOK: %save-word-xt cpu ( -- )
! Store dispatch branch XT in stack frame ! 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 ; M: object %save-dispatch-xt %save-word-xt ;
! Call another word ! Call another word
HOOK: %call compiler-backend ( word -- ) HOOK: %call cpu ( word -- )
! Local jump for branches ! Local jump for branches
HOOK: %jump-label compiler-backend ( label -- ) HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not ! 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 ! Return to caller
HOOK: %return compiler-backend ( -- ) HOOK: %return cpu ( -- )
! Change datastack height ! Change datastack height
HOOK: %inc-d compiler-backend ( n -- ) HOOK: %inc-d cpu ( n -- )
! Change callstack height ! Change callstack height
HOOK: %inc-r compiler-backend ( n -- ) HOOK: %inc-r cpu ( n -- )
! Load stack into vreg ! Load stack into vreg
HOOK: %peek compiler-backend ( vreg loc -- ) HOOK: %peek cpu ( vreg loc -- )
! Store vreg to stack ! Store vreg to stack
HOOK: %replace compiler-backend ( vreg loc -- ) HOOK: %replace cpu ( vreg loc -- )
! Box and unbox floats ! Box and unbox floats
HOOK: %unbox-float compiler-backend ( dst src -- ) HOOK: %unbox-float cpu ( dst src -- )
HOOK: %box-float compiler-backend ( dst src -- ) HOOK: %box-float cpu ( dst src -- )
! FFI stuff ! FFI stuff
! Is this integer small enough to appear in value template ! Is this integer small enough to appear in value template
! slots? ! slots?
HOOK: small-enough? compiler-backend ( n -- ? ) HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers? ! 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? ! 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 ! 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: %save-param-reg ( stack reg reg-class -- )
GENERIC: %load-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 ; 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) ! 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 ; M: stack-params param-reg drop ;
@ -179,15 +177,15 @@ PREDICATE: inline-array < integer 32 < ;
] if-small-struct ; ] if-small-struct ;
! Alien accessors ! 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 : 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 12 11 float tag-number ORI
f fresh-object ; f fresh-object ;
M: ppc-backend %box-float ( dst src -- ) M: ppc %box-float ( dst src -- )
[ v>operand ] bi@ %allot-float 12 MR ; [ v>operand ] bi@ %allot-float 12 MR ;
: %allot-bignum ( #digits -- ) : %allot-bignum ( #digits -- )
@ -78,7 +78,7 @@ M: ppc-backend %box-float ( dst src -- )
"end" resolve-label "end" resolve-label
] with-scope ; ] with-scope ;
M: ppc-backend %box-alien ( dst src -- ) M: ppc %box-alien ( dst src -- )
{ "end" "f" } [ define-label ] each { "end" "f" } [ define-label ] each
0 over v>operand 0 CMPI 0 over v>operand 0 CMPI
"f" get BEQ "f" get BEQ

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

@ -7,8 +7,6 @@ layouts classes words.private alien combinators
compiler.constants ; compiler.constants ;
IN: cpu.ppc.architecture IN: cpu.ppc.architecture
TUPLE: ppc-backend ;
! PowerPC register assignments ! PowerPC register assignments
! r3-r10, r16-r31: integer vregs ! r3-r10, r16-r31: integer vregs
! f0-f13: float vregs ! f0-f13: float vregs
@ -21,14 +19,14 @@ TUPLE: ppc-backend ;
: reserved-area-size : reserved-area-size
os { os {
{ "linux" [ 2 ] } { linux [ 2 ] }
{ "macosx" [ 6 ] } { macosx [ 6 ] }
} case cells ; foldable } case cells ; foldable
: lr-save : lr-save
os { os {
{ "linux" [ 1 ] } { linux [ 1 ] }
{ "macosx" [ 2 ] } { macosx [ 2 ] }
} case cells ; foldable } case cells ; foldable
: param@ ( n -- x ) reserved-area-size + ; inline : param@ ( n -- x ) reserved-area-size + ; inline
@ -44,7 +42,7 @@ TUPLE: ppc-backend ;
: xt-save ( n -- i ) 2 cells - ; : 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 ; local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ; 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 return-reg drop 1 ;
M: float-regs param-regs M: float-regs param-regs
drop os H{ drop os H{
{ "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } } { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
{ "linux" { 1 2 3 4 5 6 7 8 } } { linux { 1 2 3 4 5 6 7 8 } }
} at ; } at ;
M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; 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 M: immediate load-literal
[ v>operand ] bi@ LOAD ; [ 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 [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
dup 0 LWZ ; dup 0 LWZ ;
M: ppc-backend %save-word-xt ( -- ) M: ppc %save-word-xt ( -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ; 0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
M: ppc-backend %prologue ( n -- ) M: ppc %prologue ( n -- )
0 MFLR 0 MFLR
1 1 pick neg ADDI 1 1 pick neg ADDI
11 1 pick xt-save STW 11 1 pick xt-save STW
@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- )
11 1 pick next-save STW 11 1 pick next-save STW
0 1 rot lr-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 #! At the end of each word that calls a subroutine, we store
#! the previous link register value in r0 by popping it off #! the previous link register value in r0 by popping it off
#! the stack, set the link register to the contents of r0, #! 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 -- ) : %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ; 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 ; 0 "flag" operand f v>operand CMPI BNE ;
M: ppc-backend %dispatch ( -- ) M: ppc %dispatch ( -- )
[ [
%epilogue-later %epilogue-later
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
@ -124,25 +122,25 @@ M: ppc-backend %dispatch ( -- )
{ +scratch+ { { f "offset" } } } { +scratch+ { { f "offset" } } }
} with-template ; } with-template ;
M: ppc-backend %dispatch-label ( word -- ) M: ppc %dispatch-label ( word -- )
0 , rc-absolute-cell rel-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 ; >r v>operand r> loc>operand LWZ ;
M: ppc-backend %replace M: ppc %replace
>r v>operand r> loc>operand STW ; >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 ; [ v>operand ] bi@ float-offset LFD ;
M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ; M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ; M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
M: int-regs %save-param-reg drop 1 rot local@ STW ; M: int-regs %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 param@ stack-frame* + LWZ
0 1 rot local@ STW ; 0 1 rot local@ STW ;
M: ppc-backend %prepare-unbox ( -- ) M: ppc %prepare-unbox ( -- )
! First parameter is top of stack ! First parameter is top of stack
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg dup cell SUBI ; 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 ! Value must be in r3
! Call the unboxer ! Call the unboxer
f %alien-invoke f %alien-invoke
! Store the return value on the C stack ! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; 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 ! Value must be in r3:r4
! Call the unboxer ! Call the unboxer
f %alien-invoke f %alien-invoke
@ -188,7 +186,7 @@ M: ppc-backend %unbox-long-long ( n func -- )
4 1 rot cell + local@ STW 4 1 rot cell + local@ STW
] when* ; ] when* ;
M: ppc-backend %unbox-large-struct ( n size -- ) M: ppc %unbox-large-struct ( n size -- )
! Value must be in r3 ! Value must be in r3
! Compute destination address ! Compute destination address
4 1 roll local@ ADDI 4 1 roll local@ ADDI
@ -197,7 +195,7 @@ M: ppc-backend %unbox-large-struct ( n size -- )
! Call the function ! Call the function
"to_value_struct" f %alien-invoke ; "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 a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in ! If the source is f, then we assume the value is already in
! freg #0. ! 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 over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
r> f %alien-invoke ; r> f %alien-invoke ;
M: ppc-backend %box-long-long ( n func -- ) M: ppc %box-long-long ( n func -- )
>r [ >r [
3 1 pick local@ LWZ 3 1 pick local@ LWZ
4 1 rot cell + 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 ; : 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 #! Compute target address for value struct return
3 1 rot f struct-return@ ADDI 3 1 rot f struct-return@ ADDI
3 1 0 local@ STW ; 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 #! If n = f, then we're boxing a returned struct
[ swap struct-return@ ] keep [ swap struct-return@ ] keep
! Compute destination address ! Compute destination address
@ -230,7 +228,7 @@ M: ppc-backend %box-large-struct ( n size -- )
! Call the function ! Call the function
"box_value_struct" f %alien-invoke ; "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 #! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace #! callback which does a GC, which must reliably trace
#! all roots. #! all roots.
@ -240,20 +238,20 @@ M: ppc-backend %prepare-alien-invoke
ds-reg 11 8 STW ds-reg 11 8 STW
rs-reg 11 12 STW ; rs-reg 11 12 STW ;
M: ppc-backend %alien-invoke ( symbol dll -- ) M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym (%call) ; 11 %load-dlsym (%call) ;
M: ppc-backend %alien-callback ( quot -- ) M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ; 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 "unbox_alien" f %alien-invoke
3 1 cell temp@ STW ; 3 1 cell temp@ STW ;
M: ppc-backend %alien-indirect ( -- ) M: ppc %alien-indirect ( -- )
11 1 cell temp@ LWZ (%call) ; 11 1 cell temp@ LWZ (%call) ;
M: ppc-backend %callback-value ( ctype -- ) M: ppc %callback-value ( ctype -- )
! Save top of data stack ! Save top of data stack
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
3 1 0 local@ STW 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 former top of data stack to return registers
unbox-return ; 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 ; : %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 ; : %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 #! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first. #! 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 ; drop "No small structs" throw ;
M: ppc-backend %unbox-small-struct M: ppc %unbox-small-struct
drop "No small structs" throw ; drop "No small structs" throw ;
! Alien intrinsics ! Alien intrinsics
M: ppc-backend %unbox-byte-array ( dst src -- ) M: ppc %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset ADDI ; [ 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 ; [ 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 ; 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 { "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in R12 ! Address is computed in R12
0 12 LI 0 12 LI

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

@ -94,14 +94,14 @@ IN: cpu.ppc.intrinsics
} define-intrinsics } define-intrinsics
: fixnum-register-op ( op -- pair ) : 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" } } } { +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } } { +scratch+ { { f "out" } } }
{ +output+ { "out" } } { +output+ { "out" } }
} 2array ; } 2array ;
: fixnum-value-op ( op -- pair ) : 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" } } } { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
{ +scratch+ { { f "out" } } } { +scratch+ { { f "out" } } }
{ +output+ { "out" } } { +output+ { "out" } }
@ -205,11 +205,11 @@ IN: cpu.ppc.intrinsics
} define-intrinsic } define-intrinsic
: fixnum-register-jump ( op -- pair ) : 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 ; { { f "x" } { f "y" } } 2array ;
: fixnum-value-jump ( op -- pair ) : 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 ; { { f "x" } { [ small-tagged? ] "y" } } 2array ;
: define-fixnum-jump ( word op -- ) : define-fixnum-jump ( word op -- )
@ -336,7 +336,7 @@ IN: cpu.ppc.intrinsics
} define-intrinsic } define-intrinsic
: define-float-op ( word op -- ) : 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" } } } { +input+ { { float "x" } { float "y" } } }
{ +scratch+ { { float "z" } } } { +scratch+ { { float "z" } } }
{ +output+ { "z" } } { +output+ { "z" } }
@ -352,7 +352,7 @@ IN: cpu.ppc.intrinsics
] each ] each
: define-float-jump ( word op -- ) : 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 ; { { float "x" } { float "y" } } define-if-intrinsic ;
{ {
@ -402,55 +402,6 @@ IN: cpu.ppc.intrinsics
{ +output+ { "out" } } { +output+ { "out" } }
} define-intrinsic } 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 -- ) : userenv ( reg -- )
#! Load the userenv pointer in a register. #! Load the userenv pointer in a register.
"userenv" f rot %load-dlsym ; "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 ; namespaces alien.c-types kernel system combinators ;
{ {
{ [ macosx? ] [ { [ os macosx? ] [
4 "longlong" c-type set-c-type-align 4 "longlong" c-type set-c-type-align
4 "ulonglong" 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 "longlong" c-type set-c-type-stack-align?
t "ulonglong" c-type set-c-type-stack-align? t "ulonglong" c-type set-c-type-stack-align?
] } ] }
} cond } 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 ; compiler compiler.units io vocabs.loader accessors ;
IN: cpu.x86.32 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. ! 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 ! OS X requires that the stack be 16-byte aligned, and we do
! this on all platforms, sacrificing some stack space for ! this on all platforms, sacrificing some stack space for
! code simplicity. ! code simplicity.
M: x86-32-backend ds-reg ESI ; M: x86.32 ds-reg ESI ;
M: x86-32-backend rs-reg EDI ; M: x86.32 rs-reg EDI ;
M: x86-32-backend stack-reg ESP ; M: x86.32 stack-reg ESP ;
M: x86-32-backend xt-reg ECX ; M: x86.32 xt-reg ECX ;
M: x86-32-backend stack-save-reg EDX ; M: x86.32 stack-save-reg EDX ;
M: temp-reg v>operand drop EBX ; 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 ; (CALL) rel-dlsym ;
! On x86, parameters are never passed in registers. ! 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 ! On x86, we can always use an address as an operand
! directly. ! 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 ; 0 [] MOV rc-absolute-cell rel-literal ;
M: object %load-param-reg 3drop ; M: object %load-param-reg 3drop ;
M: object %save-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. #! Move top of data stack to EAX.
EAX ESI [] MOV EAX ESI [] MOV
ESI 4 SUB ; ESI 4 SUB ;
@ -87,7 +84,7 @@ M: x86-32-backend %prepare-unbox ( -- )
f %alien-invoke f %alien-invoke
] with-aligned-stack ; ] 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. #! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be #! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing #! 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 ! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ; over [ store-return-reg ] [ 2drop ] if ;
M: x86-32-backend %unbox-long-long ( n func -- ) M: x86.32 %unbox-long-long ( n func -- )
(%unbox) (%unbox)
! Store the return value on the C stack ! 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 cell + stack@ EDX MOV
] when* ; ] when* ;
M: x86-32-backend %unbox-struct-2 M: x86.32 %unbox-struct-2
#! Alien must be in EAX. #! Alien must be in EAX.
4 [ 4 [
EAX PUSH EAX PUSH
@ -115,7 +112,7 @@ M: x86-32-backend %unbox-struct-2
EAX EAX [] MOV EAX EAX [] MOV
] with-aligned-stack ; ] 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. #! Alien must be in EAX.
! Compute destination address ! Compute destination address
ECX ESP roll [+] LEA 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 over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
push-return-reg ; push-return-reg ;
M: x86-32-backend %box ( n reg-class func -- ) M: x86.32 %box ( n reg-class func -- )
over reg-size [ over reg-size [
>r (%box) r> f %alien-invoke >r (%box) r> f %alien-invoke
] with-aligned-stack ; ] with-aligned-stack ;
@ -165,12 +162,12 @@ M: x86-32-backend %box ( n reg-class func -- )
EDX PUSH EDX PUSH
EAX PUSH ; EAX PUSH ;
M: x86-32-backend %box-long-long ( n func -- ) M: x86.32 %box-long-long ( n func -- )
8 [ 8 [
>r (%box-long-long) r> f %alien-invoke >r (%box-long-long) r> f %alien-invoke
] with-aligned-stack ; ] with-aligned-stack ;
M: x86-32-backend %box-large-struct ( n size -- ) M: x86.32 %box-large-struct ( n size -- )
! Compute destination address ! Compute destination address
[ swap struct-return@ ] keep [ swap struct-return@ ] keep
ECX ESP roll [+] LEA ECX ESP roll [+] LEA
@ -183,13 +180,13 @@ M: x86-32-backend %box-large-struct ( n size -- )
"box_value_struct" f %alien-invoke "box_value_struct" f %alien-invoke
] with-aligned-stack ; ] 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 ! Compute target address for value struct return
EAX ESP rot f struct-return@ [+] LEA EAX ESP rot f struct-return@ [+] LEA
! Store it as the first parameter ! Store it as the first parameter
ESP [] EAX MOV ; ESP [] EAX MOV ;
M: x86-32-backend %unbox-struct-1 M: x86.32 %unbox-struct-1
#! Alien must be in EAX. #! Alien must be in EAX.
4 [ 4 [
EAX PUSH EAX PUSH
@ -198,7 +195,7 @@ M: x86-32-backend %unbox-struct-1
EAX EAX [] MOV EAX EAX [] MOV
] with-aligned-stack ; ] 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. #! Box a <= 8-byte struct returned in EAX:DX. OS X only.
12 [ 12 [
PUSH PUSH
@ -207,21 +204,21 @@ M: x86-32-backend %box-small-struct ( size -- )
"box_small_struct" f %alien-invoke "box_small_struct" f %alien-invoke
] with-aligned-stack ; ] with-aligned-stack ;
M: x86-32-backend %prepare-alien-indirect ( -- ) M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke "unbox_alien" f %alien-invoke
cell temp@ EAX MOV ; cell temp@ EAX MOV ;
M: x86-32-backend %alien-indirect ( -- ) M: x86.32 %alien-indirect ( -- )
cell temp@ CALL ; cell temp@ CALL ;
M: x86-32-backend %alien-callback ( quot -- ) M: x86.32 %alien-callback ( quot -- )
4 [ 4 [
EAX load-indirect EAX load-indirect
EAX PUSH EAX PUSH
"c_to_factor" f %alien-invoke "c_to_factor" f %alien-invoke
] with-aligned-stack ; ] with-aligned-stack ;
M: x86-32-backend %callback-value ( ctype -- ) M: x86.32 %callback-value ( ctype -- )
! Align C stack ! Align C stack
ESP 12 SUB ESP 12 SUB
! Save top of data stack ! Save top of data stack
@ -236,7 +233,7 @@ M: x86-32-backend %callback-value ( ctype -- )
! Unbox EAX ! Unbox EAX
unbox-return ; 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 #! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that #! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue. #! so we 'undo' the cleanup since we do that in %epilogue.
@ -254,19 +251,14 @@ M: x86-32-backend %cleanup ( alien-node -- )
} }
} cond ; } 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 "longlong" c-type set-c-type-align
cell "ulonglong" c-type set-c-type-align cell "ulonglong" c-type set-c-type-align
] unless
windows? [
4 "double" c-type set-c-type-align 4 "double" c-type set-c-type-align
] unless ] unless
T{ x86-backend f 4 } compiler-backend set-global
: sse2? "Intrinsic" throw ; : sse2? "Intrinsic" throw ;
\ sse2? [ \ 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 ; splitting assocs ;
IN: cpu.x86.64 IN: cpu.x86.64
PREDICATE: amd64-backend < x86-backend M: x86.64 ds-reg R14 ;
x86-backend-cell 8 = ; M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: amd64-backend ds-reg R14 ; M: x86.64 xt-reg RCX ;
M: amd64-backend rs-reg R15 ; M: x86.64 stack-save-reg RSI ;
M: amd64-backend stack-reg RSP ;
M: amd64-backend xt-reg RCX ;
M: amd64-backend stack-save-reg RSI ;
M: temp-reg v>operand drop RBX ; M: temp-reg v>operand drop RBX ;
@ -34,18 +31,18 @@ M: float-regs vregs
M: float-regs param-regs M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; 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 #! On AMD64, we have to load 64-bit addresses into a
#! scratch register first. The usage of R11 here is a hack. #! scratch register first. The usage of R11 here is a hack.
#! This word can only be called right before a subroutine #! This word can only be called right before a subroutine
#! call, where all vregs have been flushed anyway. #! call, where all vregs have been flushed anyway.
temp-reg v>operand [ swap MOV ] keep ; 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 ; 0 [] MOV rc-relative rel-literal ;
M: stack-params %load-param-reg M: stack-params %load-param-reg
@ -56,27 +53,27 @@ M: stack-params %load-param-reg
M: stack-params %save-param-reg M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-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 ! First parameter is top of stack
RDI R14 [] MOV RDI R14 [] MOV
R14 cell SUB ; R14 cell SUB ;
M: amd64-backend %unbox ( n reg-class func -- ) M: x86.64 %unbox ( n reg-class func -- )
! Call the unboxer ! Call the unboxer
f %alien-invoke f %alien-invoke
! Store the return value on the C stack ! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ; 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 ; T{ int-regs } swap %unbox ;
M: amd64-backend %unbox-struct-1 ( -- ) M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI. #! Alien must be in RDI.
"alien_offset" f %alien-invoke "alien_offset" f %alien-invoke
! Load first cell ! Load first cell
RAX RAX [] MOV ; RAX RAX [] MOV ;
M: amd64-backend %unbox-struct-2 ( -- ) M: x86.64 %unbox-struct-2 ( -- )
#! Alien must be in RDI. #! Alien must be in RDI.
"alien_offset" f %alien-invoke "alien_offset" f %alien-invoke
! Load second cell ! Load second cell
@ -84,7 +81,7 @@ M: amd64-backend %unbox-struct-2 ( -- )
! Load first cell ! Load first cell
RAX RAX [] MOV ; RAX RAX [] MOV ;
M: amd64-backend %unbox-large-struct ( n size -- ) M: x86.64 %unbox-large-struct ( n size -- )
! Source is in RDI ! Source is in RDI
! Load destination address ! Load destination address
RSI RSP roll [+] LEA RSI RSP roll [+] LEA
@ -97,7 +94,7 @@ M: amd64-backend %unbox-large-struct ( n size -- )
0 over param-reg swap return-reg 0 over param-reg swap return-reg
2dup eq? [ 2drop ] [ MOV ] if ; 2dup eq? [ 2drop ] [ MOV ] if ;
M: amd64-backend %box ( n reg-class func -- ) M: x86.64 %box ( n reg-class func -- )
rot [ rot [
rot [ 0 swap param-reg ] keep %load-param-reg rot [ 0 swap param-reg ] keep %load-param-reg
] [ ] [
@ -105,19 +102,19 @@ M: amd64-backend %box ( n reg-class func -- )
] if* ] if*
f %alien-invoke ; f %alien-invoke ;
M: amd64-backend %box-long-long ( n func -- ) M: x86.64 %box-long-long ( n func -- )
T{ int-regs } swap %box ; 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. #! Box a <= 16-byte struct returned in RAX:RDX.
RDI RAX MOV RDI RAX MOV
RSI RDX MOV RSI RDX MOV
RDX swap MOV RDX swap MOV
"box_small_struct" f %alien-invoke ; "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 ! Struct size is parameter 2
RSI over MOV RSI over MOV
! Compute destination address ! Compute destination address
@ -125,27 +122,27 @@ M: amd64-backend %box-large-struct ( n size -- )
! Copy the struct from the C stack ! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ; "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 ! Compute target address for value struct return
RAX RSP rot f struct-return@ [+] LEA RAX RSP rot f struct-return@ [+] LEA
RSP 0 [+] RAX MOV ; 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 ; 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 "unbox_alien" f %alien-invoke
cell temp@ RAX MOV ; cell temp@ RAX MOV ;
M: amd64-backend %alien-indirect ( -- ) M: x86.64 %alien-indirect ( -- )
cell temp@ CALL ; cell temp@ CALL ;
M: amd64-backend %alien-callback ( quot -- ) M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ; 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 ! Save top of data stack
%prepare-unbox %prepare-unbox
! Put former top of data stack in RDI ! 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 former top of data stack to return registers
unbox-return ; 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 USE: cpu.x86.intrinsics
@ -171,8 +168,6 @@ USE: cpu.x86.intrinsics
\ alien-signed-4 small-reg-32 define-signed-getter \ alien-signed-4 small-reg-32 define-signed-getter
\ set-alien-signed-4 small-reg-32 define-setter \ 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 ! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type << "void*" c-type clone "__stack_value" define-primitive-type
T{ stack-params } "__stack_value" c-type set-c-type-reg-class >> 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 swap tag-number OR
allot-reg MOV ; allot-reg MOV ;
M: x86-backend %box-float ( dst src -- ) M: x86 %box-float ( dst src -- )
#! Only called by pentium4 backend, uses SSE2 instruction #! Only called by pentium4 backend, uses SSE2 instruction
#! dest is a loc or a vreg #! dest is a loc or a vreg
float 16 [ float 16 [
@ -86,7 +86,7 @@ M: x86-backend %box-float ( dst src -- )
"end" resolve-label "end" resolve-label
] with-scope ; ] with-scope ;
M: x86-backend %box-alien ( dst src -- ) M: x86 %box-alien ( dst src -- )
[ [
{ "end" "f" } [ define-label ] each { "end" "f" } [ define-label ] each
dup v>operand 0 CMP 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 ; generator.fixup system layouts combinators compiler.constants ;
IN: cpu.x86.architecture IN: cpu.x86.architecture
TUPLE: x86-backend cell ; HOOK: ds-reg cpu
HOOK: rs-reg cpu
HOOK: ds-reg compiler-backend HOOK: stack-reg cpu
HOOK: rs-reg compiler-backend HOOK: xt-reg cpu
HOOK: stack-reg compiler-backend HOOK: stack-save-reg cpu
HOOK: xt-reg compiler-backend
HOOK: stack-save-reg compiler-backend
: stack@ stack-reg swap [+] ; : stack@ stack-reg swap [+] ;
@ -33,34 +31,34 @@ GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( stack@ reg-class -- ) GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-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: 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 - ; 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 ; xt-reg 0 MOV rc-absolute-cell rel-this ;
: factor-area-size 4 cells ; : factor-area-size 4 cells ;
M: x86-backend %prologue ( n -- ) M: x86 %prologue ( n -- )
dup cell + PUSH dup cell + PUSH
xt-reg PUSH xt-reg PUSH
stack-reg swap 2 cells - SUB ; stack-reg swap 2 cells - SUB ;
M: x86-backend %epilogue ( n -- ) M: x86 %epilogue ( n -- )
stack-reg swap ADD ; stack-reg swap ADD ;
: %alien-global ( symbol dll register -- ) : %alien-global ( symbol dll register -- )
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ; [ 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 #! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace #! callback which does a GC, which must reliably trace
#! all roots. #! 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 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-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 ; "flag" operand f v>operand CMP JNE ;
: code-alignment ( -- n ) : code-alignment ( -- n )
@ -83,7 +81,7 @@ M: x86-backend %jump-t ( label -- )
: align-code ( n -- ) : align-code ( n -- )
0 <repetition> % ; 0 <repetition> % ;
M: x86-backend %dispatch ( -- ) M: x86 %dispatch ( -- )
[ [
%epilogue-later %epilogue-later
! Load jump table base. We use a temporary register ! Load jump table base. We use a temporary register
@ -105,27 +103,27 @@ M: x86-backend %dispatch ( -- )
{ +clobber+ { "n" } } { +clobber+ { "n" } }
} with-template ; } with-template ;
M: x86-backend %dispatch-label ( word -- ) M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-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 ; [ 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 ; : (%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? ; HEX: -80000000 HEX: 7fffffff between? ;
: %untag ( reg -- ) tag-mask get bitnot AND ; : %untag ( reg -- ) tag-mask get bitnot AND ;
@ -143,34 +141,34 @@ M: x86-backend small-enough? ( n -- ? )
\ stack-frame get swap - \ stack-frame get swap -
] ?if ; ] ?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. #! Alien must be in EAX.
cell align cell /i { cell align cell /i {
{ 1 [ %unbox-struct-1 ] } { 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] } { 2 [ %unbox-struct-2 ] }
} case ; } case ;
M: x86-backend struct-small-enough? ( size -- ? ) M: x86 struct-small-enough? ( size -- ? )
{ 1 2 4 8 } member? { 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 ! Alien intrinsics
M: x86-backend %unbox-byte-array ( dst src -- ) M: x86 %unbox-byte-array ( dst src -- )
[ v>operand ] bi@ byte-array-offset [+] LEA ; [ 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 ; [ v>operand ] bi@ alien-offset [+] MOV ;
M: x86-backend %unbox-f ( dst src -- ) M: x86 %unbox-f ( dst src -- )
drop v>operand 0 MOV ; 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 { "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in ds-reg ! Address is computed in ds-reg
ds-reg PUSH 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' ) : opcode-or ( opcode mask -- opcode' )
swap dup array? 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 -- ) : 1-operand ( op reg rex.w opcode -- )
#! The 'reg' is not really a register, but a value for the #! 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" } } { +output+ { "in" } }
} define-intrinsic } 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 ! Slots
: %slot-literal-known-tag : %slot-literal-known-tag
"obj" operand "obj" operand
@ -156,7 +104,7 @@ IN: cpu.x86.intrinsics
! Fixnums ! Fixnums
: fixnum-op ( op hash -- pair ) : 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 ) : fixnum-value-op ( op -- pair )
H{ H{
@ -251,7 +199,7 @@ IN: cpu.x86.intrinsics
\ fixnum- \ SUB overflow-template \ fixnum- \ SUB overflow-template
: fixnum-jump ( op inputs -- pair ) : 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 ) : fixnum-value-jump ( op -- pair )
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ; { { 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 IN: cpu.x86.sse2
: define-float-op ( word op -- ) : define-float-op ( word op -- )
[ "x" operand "y" operand ] swap add H{ [ "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } } { +input+ { { float "x" } { float "y" } } }
{ +output+ { "x" } } { +output+ { "x" } }
} define-intrinsic ; } define-intrinsic ;
@ -23,7 +23,7 @@ IN: cpu.x86.sse2
] each ] each
: define-float-jump ( word op -- ) : 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 ; { { 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 ; 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 ] ; 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* ; : add-literal ( obj -- n ) literal-table get push-new* ;
: string>symbol ( str -- alien ) : 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 ; over string? [ call ] [ map ] if ;
: add-dlsym-literals ( symbol dll -- ) : add-dlsym-literals ( symbol dll -- )

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

@ -37,7 +37,6 @@ $nl
{ $subsection create-method } { $subsection create-method }
"Method definitions can be looked up:" "Method definitions can be looked up:"
{ $subsection method } { $subsection method }
{ $subsection methods }
"A generic word contains methods; the list of methods specializing on a class can also be obtained:" "A generic word contains methods; the list of methods specializing on a class can also be obtained:"
{ $subsection implementors } { $subsection implementors }
"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:" "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." "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 $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." "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" } ; { $see-also "generic-introspection" } ;
ARTICLE: "generic" "Generic words and methods" ARTICLE: "generic" "Generic words and methods"
@ -129,10 +119,6 @@ HELP: <method>
{ $values { "class" class } { "generic" generic } { "method" "a new method definition" } } { $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
{ $description "Creates a new method." } ; { $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 HELP: order
{ $values { "generic" generic } { "seq" "a sequence of classes" } } { $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." } ; { $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 } } { $values { "class" class } }
{ $description "Remove all method definitions which specialize on the 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 [ "Hello world" ] [ 4 foobar foobar ] unit-test
[ "Goodbye cruel world" ] [ 4 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 ! Testing unions
UNION: funnies quotation float complex ; UNION: funnies quotation float complex ;
@ -51,16 +38,6 @@ M: very-funny gooey sq ;
[ 0.25 ] [ 0.5 gooey ] unit-test [ 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 ) GENERIC: empty-method-test ( x -- y )
M: object empty-method-test ; M: object empty-method-test ;
TUPLE: for-arguments-sake ; TUPLE: for-arguments-sake ;
@ -171,37 +148,6 @@ M: f tag-and-f 4 ;
[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test [ 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 ! Issues with forget
GENERIC: generic-forget-test-1 GENERIC: generic-forget-test-1

75
core/generic/generic.factor
View File

@ -6,16 +6,7 @@ classes.algebra quotations arrays vocabs effects ;
IN: generic IN: generic
! Method combination protocol ! Method combination protocol
GENERIC: perform-combination ( word combination -- quot ) GENERIC: perform-combination ( word combination -- )
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: make-default-method ( generic combination -- method ) GENERIC: make-default-method ( generic combination -- method )
@ -25,8 +16,9 @@ PREDICATE: generic < word
M: generic definition drop f ; M: generic definition drop f ;
: make-generic ( word -- ) : make-generic ( word -- )
dup { "unannotated-def" } reset-props [ { "unannotated-def" } reset-props ]
dup dup "combination" word-prop perform-combination define ; [ dup "combination" word-prop perform-combination ]
bi ;
: method ( class generic -- method/f ) : method ( class generic -- method/f )
"methods" word-prop at ; "methods" word-prop at ;
@ -37,10 +29,17 @@ PREDICATE: method-spec < pair
: order ( generic -- seq ) : order ( generic -- seq )
"methods" word-prop keys sort-classes ; "methods" word-prop keys sort-classes ;
: methods ( word -- assoc ) : next-method-class ( class generic -- class/f )
"methods" word-prop order [ class< ] with subset reverse dup length 1 =
[ keys sort-classes ] keep [ drop f ] [ second ] if ;
[ dupd at ] curry { } map>assoc ;
: 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 ; TUPLE: check-method class generic ;
@ -62,6 +61,9 @@ PREDICATE: method-body < word
M: method-body stack-effect M: method-body stack-effect
"method-generic" word-prop stack-effect ; "method-generic" word-prop stack-effect ;
M: method-body crossref?
drop t ;
: method-word-props ( class generic -- assoc ) : method-word-props ( class generic -- assoc )
[ [
"method-generic" set "method-generic" set
@ -104,14 +106,6 @@ M: method-spec definer
M: method-spec definition M: method-spec definition
first2 method definition ; first2 method definition ;
: forget-method ( class generic -- )
dup generic? [
[ delete-at* ] with-methods
[ forget-word ] [ drop ] if
] [
2drop
] if ;
M: method-spec forget* M: method-spec forget*
first2 method forget* ; first2 method forget* ;
@ -120,9 +114,15 @@ M: method-body definer
M: method-body forget* M: method-body forget*
dup "forgotten" word-prop [ drop ] [ dup "forgotten" word-prop [ drop ] [
dup "method-class" word-prop [
over "method-generic" word-prop forget-method [ "method-class" word-prop ]
t "forgotten" set-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 ; ] if ;
: implementors* ( classes -- words ) : implementors* ( classes -- words )
@ -135,12 +135,13 @@ M: method-body forget*
dup associate implementors* ; dup associate implementors* ;
: forget-methods ( class -- ) : forget-methods ( class -- )
[ implementors ] keep [ swap 2array ] curry map forget-all ; [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- ) M: class forget* ( class -- )
dup forget-methods [ forget-methods ]
dup update-map- [ update-map- ]
forget-word ; [ call-next-method ]
tri ;
M: assoc update-methods ( assoc -- ) M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ; implementors* [ make-generic ] each ;
@ -156,11 +157,15 @@ M: assoc update-methods ( assoc -- )
] if ; ] if ;
M: generic subwords 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 M: generic forget*
dup subwords [ forget ] each (forget-word) ; [ subwords forget-all ] [ call-next-method ] bi ;
: xref-generics ( -- ) : xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ; 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< number bootstrap-word class<
] if ; ] 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 null class< ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] } { [ dup math-class? ] [ class-types last/first ] }
@ -71,13 +71,15 @@ M: math-combination make-default-method
M: math-combination perform-combination M: math-combination perform-combination
drop drop
dup
\ over [ \ over [
dup math-class? [ dup math-class? [
\ dup [ >r 2dup r> math-method ] math-vtable \ dup [ >r 2dup r> math-method ] math-vtable
] [ ] [
over object-method over object-method
] if nip ] if nip
] math-vtable nip ; ] math-vtable nip
define ;
PREDICATE: math-generic < generic ( word -- ? ) PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ; "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 USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions namespaces sequences vectors words quotations definitions
hashtables layouts combinators sequences.private generic 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 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 ) GENERIC: dispatch# ( word -- n )
M: word dispatch# "combination" word-prop dispatch# ; 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-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: simple-generic definer drop \ GENERIC: f ;
M: standard-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 USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes 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 IN: inference.backend
: recursive-label ( word -- label/f ) : recursive-label ( word -- label/f )
recursive-state get at ; recursive-state get at ;
: inline? ( word -- ? ) GENERIC: inline? ( word -- ? )
dup "method-generic" word-prop swap or "inline" word-prop ;
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 ) : local-recursive-state ( -- assoc )
recursive-state get dup keys recursive-state get dup keys
@ -92,7 +101,7 @@ M: wrapper apply-object
r> recursive-state set ; r> recursive-state set ;
: infer-quot-recursive ( quot word label -- ) : 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 -- ) : time-bomb ( error -- )
[ throw ] curry recursive-state get infer-quot ; [ throw ] curry recursive-state get infer-quot ;
@ -109,7 +118,7 @@ TUPLE: recursive-quotation-error quot ;
dup value-literal callable? [ dup value-literal callable? [
dup value-literal dup value-literal
over value-recursion over value-recursion
rot f 2array add* infer-quot rot f 2array prefix infer-quot
] [ ] [
drop bad-call drop bad-call
] if ] if
@ -430,7 +439,7 @@ M: #call-label collect-recursion*
[ [ swap collect-recursion* ] curry each-node ] { } make ; [ [ swap collect-recursion* ] curry each-node ] { } make ;
: join-values ( node -- ) : 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 unify-lengths unify-stacks
meta-d [ length tail* ] change ; 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: f mynot drop t ;
M: general-t mynot drop f ; M: object mynot drop f ;
GENERIC: detect-f ( x -- y ) GENERIC: detect-f ( x -- y )
@ -120,7 +120,7 @@ M: object xyz ;
[ [
[ no-cond ] 1 [ no-cond ] 1
[ 1array dup quotation? [ >quotation ] unless ] times [ 1array dup quotation? [ >quotation ] unless ] times
] \ type inlined? ] \ quotation? inlined?
] unit-test ] unit-test
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test [ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
@ -233,6 +233,20 @@ M: fixnum annotate-entry-test-1 drop ;
\ >float inlined? \ >float inlined?
] unit-test ] 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 ] [ [ t ] [
[ 3 + = ] \ equal? inlined? [ 3 + = ] \ equal? inlined?
] unit-test ] unit-test
@ -297,3 +311,15 @@ cell-bits 32 = [
[ t ] [ [ t ] [
[ { vector } declare nth-unsafe ] \ nth-unsafe inlined? [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
] unit-test ] 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 -- ) : predicate-constraints ( class #call -- )
[ [
0 `input class, ! If word outputs true, input is an instance of class
general-t 0 `output class, [
] set-constraints ; 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 -- ) : compute-constraints ( #call -- )
dup node-param "constraints" word-prop [ dup node-param "constraints" word-prop [
@ -209,7 +218,7 @@ M: #push infer-classes-before
M: #if child-constraints M: #if child-constraints
[ [
general-t 0 `input class, \ f class-not 0 `input class,
f 0 `input literal, f 0 `input literal,
] make-constraints ; ] make-constraints ;
@ -265,7 +274,7 @@ DEFER: (infer-classes)
(merge-intervals) r> set-intervals ; (merge-intervals) r> set-intervals ;
: annotate-merge ( nodes #merge/#entry -- ) : annotate-merge ( nodes #merge/#entry -- )
2dup merge-classes merge-intervals ; [ merge-classes ] [ merge-intervals ] 2bi ;
: merge-children ( node -- ) : merge-children ( node -- )
dup node-successor dup #merge? [ dup node-successor dup #merge? [
@ -281,28 +290,31 @@ DEFER: (infer-classes)
M: #label infer-classes-before ( #label -- ) M: #label infer-classes-before ( #label -- )
#! First, infer types under the hypothesis which hold on #! First, infer types under the hypothesis which hold on
#! entry to the recursive label. #! entry to the recursive label.
dup 1array swap annotate-entry ; [ 1array ] keep annotate-entry ;
M: #label infer-classes-around ( #label -- ) M: #label infer-classes-around ( #label -- )
#! Now merge the types at every recursion point with the #! Now merge the types at every recursion point with the
#! entry types. #! entry types.
dup annotate-node {
dup infer-classes-before [ annotate-node ]
dup infer-children [ infer-classes-before ]
dup collect-recursion over add [ infer-children ]
pick annotate-entry [ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
node-child (infer-classes) ; [ node-child (infer-classes) ]
} cleave ;
M: object infer-classes-around M: object infer-classes-around
dup infer-classes-before {
dup annotate-node [ infer-classes-before ]
dup infer-children [ annotate-node ]
merge-children ; [ infer-children ]
[ merge-children ]
} cleave ;
: (infer-classes) ( node -- ) : (infer-classes) ( node -- )
[ [
dup infer-classes-around [ infer-classes-around ]
node-successor (infer-classes) [ node-successor (infer-classes) ] bi
] when* ; ] when* ;
: infer-classes-with ( node classes literals intervals -- ) : 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 ; : <computed> \ <computed> counter ;
! Literal value ! Literal value
TUPLE: value literal uid recursion ; TUPLE: value < identity-tuple literal uid recursion ;
: <value> ( obj -- value ) : <value> ( obj -- value )
<computed> recursive-state get value construct-boa ; <computed> recursive-state get value construct-boa ;
M: value hashcode* nip value-uid ; M: value hashcode* nip value-uid ;
M: value equal? 2drop f ;
! Result of curry ! Result of curry
TUPLE: curried obj quot ; TUPLE: curried obj quot ;
@ -30,13 +28,12 @@ C: <composed> composed
UNION: special curried composed ; UNION: special curried composed ;
TUPLE: node param TUPLE: node < identity-tuple
param
in-d out-d in-r out-r in-d out-d in-r out-r
classes literals intervals classes literals intervals
history successor children ; history successor children ;
M: node equal? 2drop f ;
M: node hashcode* drop node hashcode* ; M: node hashcode* drop node hashcode* ;
GENERIC: flatten-curry ( value -- ) GENERIC: flatten-curry ( value -- )
@ -205,7 +202,7 @@ UNION: #branch #if #dispatch ;
2dup 2slip rot [ 2dup 2slip rot [
2drop t 2drop t
] [ ] [
>r dup node-children swap node-successor add r> >r dup node-children swap node-successor suffix r>
[ node-exists? ] curry contains? [ node-exists? ] curry contains?
] if ] 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 { } { integer } <effect> set-primitive-effect
\ millis make-flushable \ millis make-flushable
\ type { object } { fixnum } <effect> set-primitive-effect
\ type make-foldable
\ tag { object } { fixnum } <effect> set-primitive-effect \ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable \ tag make-foldable
\ class-hash { object } { fixnum } <effect> set-primitive-effect
\ class-hash make-foldable
\ cwd { } { string } <effect> set-primitive-effect \ cwd { } { string } <effect> set-primitive-effect
\ cd { 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 IN: inference.transforms.tests
USING: sequences inference.transforms tools.test math kernel 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-quot <repetition> >quotation ;
: compose-n compose-n-quot call ; : 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 ] unit-test
[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] 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 USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend quotations assocs combinators math.bitfields inference.backend
inference.dataflow inference.state classes.tuple.private effects inference.dataflow inference.state classes.tuple.private effects
inspector hashtables ; inspector hashtables classes generic ;
IN: inference.transforms IN: inference.transforms
: pop-literals ( n -- rstate seq ) : pop-literals ( n -- rstate seq )
@ -43,6 +43,8 @@ IN: inference.transforms
\ 2cleave [ 2cleave>quot ] 1 define-transform \ 2cleave [ 2cleave>quot ] 1 define-transform
\ 3cleave [ 3cleave>quot ] 1 define-transform
\ spread [ spread>quot ] 1 define-transform \ spread [ spread>quot ] 1 define-transform
! Bitfields ! Bitfields
@ -56,7 +58,7 @@ M: pair (bitfield-quot) ( spec -- quot )
[ shift bitor ] append 2curry ; [ shift bitor ] append 2curry ;
: bitfield-quot ( spec -- quot ) : bitfield-quot ( spec -- quot )
[ (bitfield-quot) ] map [ 0 ] add* concat ; [ (bitfield-quot) ] map [ 0 ] prefix concat ;
\ bitfield [ bitfield-quot ] 1 define-transform \ bitfield [ bitfield-quot ] 1 define-transform
@ -96,3 +98,11 @@ M: duplicated-slots-error summary
\ construct-empty 1 1 <effect> make-call-node \ construct-empty 1 1 <effect> make-call-node
] if ] if
] "infer" set-word-prop ] "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

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

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

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

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings USING: init kernel system namespaces io io.encodings
io.encodings.utf8 init assocs ; io.encodings.utf8 init assocs splitting ;
IN: io.backend IN: io.backend
SYMBOL: io-backend SYMBOL: io-backend
@ -18,9 +18,9 @@ HOOK: io-multiplex io-backend ( ms -- )
HOOK: normalize-directory io-backend ( str -- newstr ) 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 -- ) : set-io-backend ( io-backend -- )
io-backend set-global init-io init-stdio 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 decoder-cr [
over cr- over cr-
"\n" ?head [ "\n" ?head [
over stream-read1 [ add ] when* over stream-read1 [ suffix ] when*
] when ] when
] when nip ; ] 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" } } { $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." } ; { $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" } } { $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." } ; { $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
[ "/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
[ "/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
@ -239,9 +237,6 @@ io.encodings.utf8 ;
[ "lib" ] [ "" "lib" append-path ] unit-test [ "lib" ] [ "" "lib" append-path ] unit-test
[ "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/./" parent-directory ] must-fail [ "foo/bar/./" parent-directory ] must-fail
[ "foo/bar/baz/.." 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 [ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
[ t ] [ "resource:core" absolute-path? ] unit-test [ t ] [ "resource:core" absolute-path? ] unit-test
[ t ] [ "/foo" absolute-path? ] unit-test
[ f ] [ "" 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 ) HOOK: (file-appender) io-backend ( path -- stream )
: <file-reader> ( path encoding -- 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 ) : <file-writer> ( path encoding -- stream )
swap normalize-pathname (file-writer) swap <encoder> ; swap normalize-path (file-writer) swap <encoder> ;
: <file-appender> ( path encoding -- stream ) : <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-lines ( path encoding -- seq )
<file-reader> lines ; <file-reader> lines ;
@ -43,9 +43,9 @@ HOOK: (file-appender) io-backend ( path -- stream )
>r <file-appender> r> with-stream ; inline >r <file-appender> r> with-stream ; inline
! Pathnames ! 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 ) : right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ; [ path-separator? ] right-trim ;
@ -102,6 +102,7 @@ PRIVATE>
: windows-absolute-path? ( path -- path ? ) : windows-absolute-path? ( path -- path ? )
{ {
{ [ dup "\\\\?\\" head? ] [ t ] }
{ [ dup length 2 < ] [ f ] } { [ dup length 2 < ] [ f ] }
{ [ dup second CHAR: : = ] [ t ] } { [ dup second CHAR: : = ] [ t ] }
{ [ t ] [ f ] } { [ t ] [ f ] }
@ -111,8 +112,8 @@ PRIVATE>
{ {
{ [ dup empty? ] [ f ] } { [ dup empty? ] [ f ] }
{ [ dup "resource:" head? ] [ t ] } { [ dup "resource:" head? ] [ t ] }
{ [ os windows? ] [ windows-absolute-path? ] }
{ [ dup first path-separator? ] [ t ] } { [ dup first path-separator? ] [ t ] }
{ [ windows? ] [ windows-absolute-path? ] }
{ [ t ] [ f ] } { [ t ] [ f ] }
} cond nip ; } cond nip ;
@ -126,6 +127,9 @@ PRIVATE>
2 tail left-trim-separators 2 tail left-trim-separators
>r parent-directory r> append-path >r parent-directory r> append-path
] } ] }
{ [ over absolute-path? over first path-separator? and ] [
>r 2 head r> append
] }
{ [ t ] [ { [ t ] [
>r right-trim-separators "/" r> >r right-trim-separators "/" r>
left-trim-separators 3append left-trim-separators 3append
@ -167,7 +171,7 @@ SYMBOL: +unknown+
! File metadata ! File metadata
: exists? ( path -- ? ) : exists? ( path -- ? )
normalize-pathname (exists?) ; normalize-path (exists?) ;
: directory? ( path -- ? ) : directory? ( path -- ? )
file-info file-info-type +directory+ = ; file-info file-info-type +directory+ = ;
@ -183,18 +187,33 @@ M: object cwd ( -- path ) "." ;
[ cwd current-directory set-global ] "io.files" add-init-hook [ 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 -- ) : with-directory ( path quot -- )
>r normalize-pathname r> >r (normalize-path) r>
current-directory swap with-variable ; inline current-directory swap with-variable ; inline
: set-current-directory ( path -- ) : set-current-directory ( path -- )
normalize-pathname current-directory set ; normalize-path current-directory set ;
! Creating directories ! Creating directories
HOOK: make-directory io-backend ( path -- ) HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- ) : make-directories ( path -- )
normalize-pathname right-trim-separators { normalize-path right-trim-separators {
{ [ dup "." = ] [ ] } { [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] } { [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] } { [ dup empty? ] [ ] }
@ -267,7 +286,7 @@ M: object copy-file
DEFER: copy-tree-into DEFER: copy-tree-into
: copy-tree ( from to -- ) : copy-tree ( from to -- )
normalize-pathname normalize-path
over link-info type>> over link-info type>>
{ {
{ +symbolic-link+ [ copy-link ] } { +symbolic-link+ [ copy-link ] }
@ -286,9 +305,6 @@ DEFER: copy-tree-into
[ copy-tree-into ] curry each ; [ copy-tree-into ] curry each ;
! Special paths ! Special paths
: resource-path ( path -- newpath )
"resource-path" get [ image parent-directory ] unless*
prepend-path ;
: temp-directory ( -- path ) : temp-directory ( -- path )
"temp" resource-path dup make-directories ; "temp" resource-path dup make-directories ;
@ -296,14 +312,6 @@ DEFER: copy-tree-into
: temp-file ( name -- path ) : temp-file ( name -- path )
temp-directory prepend-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 ! Pathname presentations
TUPLE: pathname string ; TUPLE: pathname string ;
@ -314,7 +322,7 @@ M: pathname <=> [ pathname-string ] compare ;
! Home directory ! Home directory
: home ( -- dir ) : home ( -- dir )
{ {
{ [ winnt? ] [ "USERPROFILE" os-env ] } { [ os winnt? ] [ "USERPROFILE" os-env ] }
{ [ wince? ] [ "" resource-path ] } { [ os wince? ] [ "" resource-path ] }
{ [ unix? ] [ "HOME" os-env ] } { [ os unix? ] [ "HOME" os-env ] }
} cond ; } cond ;

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

@ -250,8 +250,9 @@ $nl
{ $subsection eq? } { $subsection eq? }
"Value comparison:" "Value comparison:"
{ $subsection = } { $subsection = }
"Generic words for custom value comparison methods:" "Custom value comparison methods:"
{ $subsection equal? } { $subsection equal? }
{ $subsection identity-tuple }
"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":" "Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
{ $subsection <=> } { $subsection <=> }
{ $subsection compare } { $subsection compare }
@ -377,10 +378,13 @@ HELP: equal?
} }
$nl $nl
"If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word." "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 { $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:" "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 ;" "M: foo equal? 2drop f ;" } { $code "TUPLE: foo < identity-tuple ;" }
"By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:" "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 = ." "t" }
{ $unchecked-example "T{ foo } dup clone = ." "f" } { $unchecked-example "T{ foo } dup clone = ." "f" }
@ -413,12 +417,6 @@ HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } } { $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." } ; { $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 ) HELP: ? ( ? true false -- true/false )
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } } { $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" } "." } ; { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
@ -671,6 +669,11 @@ HELP: bi@
"[ p ] bi@" "[ p ] bi@"
">r p r> p" ">r p r> p"
} }
"The following two lines are also equivalent:"
{ $code
"[ p ] bi@"
"[ p ] [ p ] bi*"
}
} ; } ;
HELP: 2bi@ HELP: 2bi@
@ -682,6 +685,11 @@ HELP: 2bi@
"[ p ] 2bi@" "[ p ] 2bi@"
">r >r p r> r> p" ">r >r p r> r> p"
} }
"The following two lines are also equivalent:"
{ $code
"[ p ] 2bi@"
"[ p ] [ p ] 2bi*"
}
} ; } ;
HELP: tri@ HELP: tri@
@ -693,6 +701,11 @@ HELP: tri@
"[ p ] tri@" "[ p ] tri@"
">r >r p r> p r> p" ">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 -- ) HELP: if ( cond true false -- )
@ -791,19 +804,6 @@ HELP: null
"The canonical empty class with no instances." "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 HELP: most
{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } } { $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" } "." } ; { $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. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel.private ; USING: kernel.private slots.private classes.tuple.private ;
IN: kernel IN: kernel
! Stack stuff ! Stack stuff
@ -99,14 +99,14 @@ DEFER: if
! Appliers ! Appliers
: bi@ ( x y quot -- ) : bi@ ( x y quot -- )
tuck 2slip call ; inline dup bi* ; inline
: tri@ ( x y z quot -- ) : tri@ ( x y z quot -- )
tuck >r bi@ r> call ; inline dup dup tri* ; inline
! Double appliers ! Double appliers
: 2bi@ ( w x y z quot -- ) : 2bi@ ( w x y z quot -- )
dup -roll 3slip call ; inline dup 2bi* ; inline
: while ( pred body tail -- ) : while ( pred body tail -- )
>r >r dup slip r> r> roll >r >r dup slip r> r> roll
@ -114,12 +114,6 @@ DEFER: if
[ 2nip call ] if ; inline [ 2nip call ] if ; inline
! Object protocol ! Object protocol
GENERIC: delegate ( obj -- delegate )
M: object delegate drop f ;
GENERIC: set-delegate ( delegate tuple -- )
GENERIC: hashcode* ( depth obj -- code ) GENERIC: hashcode* ( depth obj -- code )
M: object hashcode* 2drop 0 ; M: object hashcode* 2drop 0 ;
@ -130,6 +124,10 @@ GENERIC: equal? ( obj1 obj2 -- ? )
M: object equal? 2drop f ; M: object equal? 2drop f ;
TUPLE: identity-tuple ;
M: identity-tuple equal? 2drop f ;
: = ( obj1 obj2 -- ? ) : = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [ equal? ] if ; inline 2dup eq? [ 2drop t ] [ equal? ] if ; inline
@ -142,18 +140,11 @@ M: object clone ;
M: callstack clone (clone) ; M: callstack clone (clone) ;
! Tuple construction ! Tuple construction
GENERIC# get-slots 1 ( tuple slots -- ... ) : construct-empty ( class -- tuple )
tuple-layout <tuple> ;
GENERIC# set-slots 1 ( ... tuple slots -- ) : construct-boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;
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
! Quotation building ! Quotation building
: 2curry ( obj1 obj2 quot -- curry ) : 2curry ( obj1 obj2 quot -- curry )
@ -194,8 +185,27 @@ GENERIC: construct-boa ( ... class -- tuple )
<PRIVATE <PRIVATE
: hi-tag ( obj -- n ) 0 slot ; inline
: declare ( spec -- ) drop ; : declare ( spec -- ) drop ;
: do-primitive ( number -- ) "Improper primitive call" throw ; : do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE> 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." } ; { $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
HELP: num-types 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 HELP: tag-number
{ $values { "class" class } { "n" "an integer or " { $link f } } } { $values { "class" class } { "n" "an integer or " { $link f } } }
@ -76,7 +76,7 @@ HELP: bootstrap-cell-bits
ARTICLE: "layouts-types" "Type numbers" 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:" "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:" "Built-in type numbers can be converted to classes, and vice versa:"
{ $subsection type>class } { $subsection type>class }
{ $subsection type-number } { $subsection type-number }

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

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

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

@ -7,9 +7,6 @@ $nl
"A mirror provides such a view of a tuple:" "A mirror provides such a view of a tuple:"
{ $subsection mirror } { $subsection mirror }
{ $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:" "Utility word used by developer tools which inspect objects:"
{ $subsection make-mirror } { $subsection make-mirror }
{ $see-also "slots" } ; { $see-also "slots" } ;
@ -44,11 +41,6 @@ HELP: >mirror<
{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } } { $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." } ; { $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 HELP: make-mirror
{ $values { "obj" object } { "assoc" assoc } } { $values { "obj" object } { "assoc" assoc } }
{ $description "Creates an assoc which reflects the internal structure of the object." } ; { $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 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 ) : sort-assoc ( assoc -- alist )
>alist >alist
[ dup first unparse-short swap ] { } map>assoc [ dup first unparse-short swap ] { } map>assoc

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

@ -154,7 +154,7 @@ SYMBOL: potential-loops
] [ ] [
node-class { node-class {
{ [ dup null class< ] [ drop f f ] } { [ 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 ] } { [ dup \ f class< ] [ drop f t ] }
{ [ t ] [ drop f f ] } { [ t ] [ drop f f ] }
} cond } cond

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

@ -70,12 +70,25 @@ DEFER: (flat-length)
] if ; ] if ;
! Partial dispatch of math-generic words ! 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-both-known? ( word left right -- ? )
math-class-max swap specific-method ; math-class-max swap specific-method ;
: inline-math-method ( #call word -- node ) : inline-math-method ( #call word -- node )
over node-input-classes first2 3dup math-both-known? over node-input-classes
[ math-method f splice-quot ] [ 2drop 2drop t ] if ; [ 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 ) : inline-method ( #call -- node )
dup node-param { 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 ; [ value-literal sequence? ] [ drop f ] if ;
: member-quot ( seq -- newquot ) : 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 -- ) : expand-member ( #call -- )
dup node-in-d peek value-literal member-quot f splice-quot ; 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? [ dup node-in-d second dup value? [
swap [ swap [
value-literal 0 `input literal, value-literal 0 `input literal,
general-t 0 `output class, \ f class-not 0 `output class,
] set-constraints ] set-constraints
] [ ] [
2drop 2drop
@ -87,29 +87,6 @@ sequences.private combinators ;
{ { @ @ } [ 2drop t ] } { { @ @ } [ 2drop t ] }
} define-identities } 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 ! Specializers
{ 1+ 1- sq neg recip sgn } [ { 1+ 1- sq neg recip sgn } [
{ number } "specializer" set-word-prop { 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 -- ) : comparison-constraints ( node true false -- )
>r >r dup node set intervals dup [ >r >r dup node set intervals dup [
2dup 2dup
r> general-t (comparison-constraints) r> \ f class-not (comparison-constraints)
r> \ f (comparison-constraints) r> \ f (comparison-constraints)
] [ ] [
r> r> 2drop 2drop 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. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math USING: arrays generic hashtables kernel kernel.private math
namespaces sequences vectors words strings layouts combinators 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 IN: optimizer.specializers
: (make-specializer) ( class picker -- quot ) : (make-specializer) ( class picker -- quot )
@ -32,7 +33,7 @@ IN: optimizer.specializers
: method-declaration ( method -- quot ) : method-declaration ( method -- quot )
dup "method-generic" word-prop dispatch# object <array> 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' ) : specialize-method ( quot method -- quot' )
method-declaration [ declare ] curry prepend ; method-declaration [ declare ] curry prepend ;

43
core/parser/parser.factor
View File

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

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

@ -57,8 +57,6 @@ unit-test
[ ] [ \ integer see ] unit-test [ ] [ \ integer see ] unit-test
[ ] [ \ general-t see ] unit-test
[ ] [ \ generic see ] unit-test [ ] [ \ generic see ] unit-test
[ ] [ \ duplex-stream see ] unit-test [ ] [ \ duplex-stream see ] unit-test
@ -192,7 +190,7 @@ unit-test
"IN: prettyprint.tests" "IN: prettyprint.tests"
": another-soft-break-layout ( node -- quot )" ": another-soft-break-layout ( node -- quot )"
" parse-error-file" " parse-error-file"
" [ <reversed> \"hello world foo\" add ] [ ] make ;" " [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
} ; } ;
[ t ] [ [ 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 prettyprint.config sorting splitting math.parser vocabs
definitions effects classes.tuple io.files classes continuations definitions effects classes.tuple io.files classes continuations
hashtables classes.mixin classes.union classes.predicate hashtables classes.mixin classes.union classes.predicate
combinators quotations ; classes.singleton combinators quotations ;
: make-pprint ( obj quot -- block in use ) : make-pprint ( obj quot -- block in use )
[ [
@ -254,6 +254,9 @@ M: predicate-class see-class*
"predicate-definition" word-prop pprint-elements "predicate-definition" word-prop pprint-elements
pprint-; block> block> ; pprint-; block> block> ;
M: singleton-class see-class* ( class -- )
\ SINGLETON: pprint-word pprint-word ;
M: tuple-class see-class* M: tuple-class see-class*
<colon \ TUPLE: pprint-word <colon \ TUPLE: pprint-word
dup pprint-word dup pprint-word

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

@ -10,8 +10,8 @@ IN: quotations.tests
] unit-test ] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 ] [ 3 4 ] append ] unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 ] [ 3 4 ] append ] unit-test
[ [ 1 2 3 ] ] [ [ 1 2 ] 3 add ] unit-test [ [ 1 2 3 ] ] [ [ 1 2 ] 3 suffix ] unit-test
[ [ 3 1 2 ] ] [ [ 1 2 ] 3 add* ] unit-test [ [ 3 1 2 ] ] [ [ 1 2 ] 3 prefix ] unit-test
[ [ "hi" ] ] [ "hi" 1quotation ] 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" ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:" "Adding elements:"
{ $subsection add } { $subsection prefix }
{ $subsection add* } { $subsection suffix }
"Removing elements:" "Removing elements:"
{ $subsection remove } { $subsection remove }
{ $subsection seq-diff } ; { $subsection seq-diff } ;
@ -641,22 +641,22 @@ HELP: push-new
} }
{ $side-effects "seq" } ; { $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 } } { $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the end of " { $snippet "seq" } "." } { $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" } "." } { $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples { $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 } } { $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." } { $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" } "." } { $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples { $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 HELP: seq-diff
@ -940,7 +940,7 @@ HELP: unclip
{ $values { "seq" sequence } { "rest" sequence } { "first" object } } { $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." } { $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 { $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 HELP: unclip-slice

17
core/sequences/sequences.factor
View File

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

2
core/splitting/splitting.factor
View File

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

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

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

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

@ -1,20 +1,12 @@
USING: generic help.markup help.syntax kernel math memory USING: generic help.markup help.syntax kernel math memory
namespaces sequences kernel.private strings ; namespaces sequences kernel.private strings classes.singleton ;
IN: system IN: system
ARTICLE: "os" "System interface" ABOUT: "system"
"Operating system detection:"
{ $subsection os } ARTICLE: "system" "System interface"
{ $subsection unix? } { $subsection "cpu" }
{ $subsection macosx? } { $subsection "os" }
{ $subsection solaris? }
{ $subsection windows? }
{ $subsection winnt? }
{ $subsection win32? }
{ $subsection win64? }
{ $subsection wince? }
"Processor detection:"
{ $subsection cpu }
"Reading environment variables:" "Reading environment variables:"
{ $subsection os-env } { $subsection os-env }
{ $subsection os-envs } { $subsection os-envs }
@ -27,63 +19,51 @@ ARTICLE: "os" "System interface"
{ $subsection exit } { $subsection exit }
{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ; { $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 HELP: cpu
{ $values { "cpu" string } } { $values { "class" singleton-class } }
{ $description { $description
"Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:" "Outputs a singleton class with the name of the current CPU architecture."
{ $code "x86.32" "x86.64" "ppc" "arm" }
} ; } ;
HELP: os HELP: os
{ $values { "os" string } } { $values { "class" singleton-class } }
{ $description { $description
"Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:" "Outputs a singleton class with the name of the current operating system family."
{ $code
"freebsd"
"linux"
"macosx"
"openbsd"
"netbsd"
"solaris"
"wince"
"winnt"
}
} ; } ;
HELP: embedded? HELP: embedded?
{ $values { "?" "a boolean" } } { $values { "?" "a boolean" } }
{ $description "Tests if this Factor instance is embedded in another application." } ; { $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 -- ) HELP: exit ( n -- )
{ $values { "n" "an integer exit code" } } { $values { "n" "an integer exit code" } }
{ $description "Exits the Factor process." } ; { $description "Exits the Factor process." } ;
@ -120,14 +100,6 @@ HELP: set-os-envs
{ os-env os-envs set-os-envs } related-words { 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 HELP: image
{ $values { "path" "a pathname string" } } { $values { "path" "a pathname string" } }
{ $description "Outputs the pathname of the currently running Factor image." } ; { $description "Outputs the pathname of the currently running Factor image." } ;
@ -135,7 +107,3 @@ HELP: image
HELP: vm HELP: vm
{ $values { "path" "a pathname string" } } { $values { "path" "a pathname string" } }
{ $description "Outputs the pathname of the currently running Factor VM." } ; { $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 ; USING: math tools.test system prettyprint namespaces kernel ;
IN: system.tests IN: system.tests
wince? [ os wince? [
[ ] [ os-envs . ] unit-test [ ] [ os-envs . ] unit-test
] unless ] unless
unix? [ os unix? [
[ ] [ os-envs "envs" set ] unit-test [ ] [ os-envs "envs" set ] unit-test
[ ] [ { { "A" "B" } } set-os-envs ] unit-test [ ] [ { { "A" "B" } } set-os-envs ] unit-test
[ "B" ] [ "A" os-env ] 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. ! See http://factorcode.org/license.txt for BSD license.
IN: system IN: system
USING: kernel kernel.private sequences math namespaces 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 ; : image ( -- path ) 13 getenv ;
: vm ( -- path ) 14 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 ; : 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 ( -- assoc )
(os-envs) [ "=" split1 ] H{ } map>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 ) : vocab-dir+ ( vocab str/f -- path )
>r vocab-name "." split r> >r vocab-name "." split r>
[ >r dup peek r> append add ] when* [ >r dup peek r> append suffix ] when*
"/" join ; "/" join ;
: vocab-dir? ( root name -- ? ) : vocab-dir? ( root name -- ? )

10
core/vocabs/vocabs.factor
View File

@ -6,13 +6,11 @@ IN: vocabs
SYMBOL: dictionary SYMBOL: dictionary
TUPLE: vocab TUPLE: vocab < identity-tuple
name words name words
main help main help
source-loaded? docs-loaded? ; source-loaded? docs-loaded? ;
M: vocab equal? 2drop f ;
: <vocab> ( name -- vocab ) : <vocab> ( name -- vocab )
H{ } clone H{ } clone
{ set-vocab-name set-vocab-words } { set-vocab-name set-vocab-words }
@ -82,7 +80,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
: child-vocab? ( prefix name -- ? ) : child-vocab? ( prefix name -- ? )
2dup = pick empty? or 2dup = pick empty? or
[ 2drop t ] [ swap CHAR: . add head? ] if ; [ 2drop t ] [ swap CHAR: . suffix head? ] if ;
: child-vocabs ( vocab -- seq ) : child-vocabs ( vocab -- seq )
vocab-name vocabs [ child-vocab? ] with subset ; vocab-name vocabs [ child-vocab? ] with subset ;
@ -92,10 +90,6 @@ TUPLE: vocab-link name ;
: <vocab-link> ( name -- vocab-link ) : <vocab-link> ( name -- vocab-link )
vocab-link construct-boa ; vocab-link construct-boa ;
M: vocab-link equal?
over vocab-link?
[ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ;
M: vocab-link hashcode* M: vocab-link hashcode*
vocab-link-name 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." } { $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." }
{ $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "<salmon>" } } ; { $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "<salmon>" } } ;
HELP: forget-word { POSTPONE: FORGET: forget forget* forget-vocab } related-words
{ $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
HELP: target-word HELP: target-word
{ $values { "word" word } { "target" word } } { $values { "word" word } { "target" word } }

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