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

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

Conflicts:

	extra/delegate/delegate.factor
db4
Daniel Ehrenberg 2008-04-03 19:20:29 -05:00
parent 90d4266867 653bc1cd80
commit 4e1285112d
299 changed files with 3561 additions and 2402 deletions
build-support
core
alien
assocs
bootstrap
classes
combinators
command-line
compiler
continuations
cpu
debugger
definitions
generator/fixup
generic
inference
io
kernel
layouts
math/intervals
mirrors
optimizer
parser
prettyprint
quotations
sequences
slots
splitting
syntax
system
Show More

2
build-support/grovel.c
View File

@ -42,6 +42,7 @@
#include <sys/socket.h>
#include <sys/errno.h>
#include <sys/mman.h>
#include <sys/syslimits.h>
#include <fcntl.h>
#include <unistd.h>
#endif
@ -146,6 +147,7 @@ void unix_constants()
constant(PROT_WRITE);
constant(MAP_FILE);
constant(MAP_SHARED);
constant(PATH_MAX);
grovel(pid_t);
}

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

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

2
core/alien/alien.factor
View File

@ -29,7 +29,7 @@ M: f expired? drop t ;
f <displaced-alien> { simple-c-ptr } declare ; inline
: alien>native-string ( alien -- string )
windows? [ alien>u16-string ] [ alien>char-string ] if ;
os windows? [ alien>u16-string ] [ alien>char-string ] if ;
: dll-path ( dll -- string )
(dll-path) alien>native-string ;

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

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

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

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

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

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

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

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

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

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

26
core/assocs/assocs.factor
View File

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

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

@ -14,13 +14,7 @@ IN: bootstrap.compiler
"alien.remote-control" require
] unless
"cpu." cpu append require
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
"cpu." cpu word-name append require
enable-compiler

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

@ -12,7 +12,8 @@ io.encodings.binary ;
IN: bootstrap.image
: my-arch ( -- arch )
cpu dup "ppc" = [ os "-" rot 3append ] when ;
cpu word-name
dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
@ -55,7 +56,7 @@ IN: bootstrap.image
: quot-xt@ 3 bootstrap-cells object tag-number - ;
: jit-define ( quot rc rt offset name -- )
>r >r >r >r { } make r> r> r> 4array r> set ;
>r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
! The image being constructed; a vector of word-size integers
SYMBOL: image
@ -134,10 +135,10 @@ SYMBOL: undefined-quot
: here ( -- size ) heap-size data-base + ;
: here-as ( tag -- pointer ) here swap bitor ;
: here-as ( tag -- pointer ) here bitor ;
: align-here ( -- )
here 8 mod 4 = [ heap-size drop 0 emit ] when ;
here 8 mod 4 = [ 0 emit ] when ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
@ -164,7 +165,7 @@ GENERIC: ' ( obj -- ptr )
userenv-size [ f ' emit ] times ;
: emit-userenv ( symbol -- )
dup get ' swap userenv-offset fixup ;
[ get ' ] [ userenv-offset ] bi fixup ;
! Bignums
@ -175,14 +176,15 @@ GENERIC: ' ( obj -- ptr )
: bignum>seq ( n -- seq )
#! n is positive or zero.
[ dup 0 > ]
[ dup bignum-bits neg shift swap bignum-radix bitand ]
[ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
[ ] unfold nip ;
USE: continuations
: emit-bignum ( n -- )
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
dup length 1+ emit-fixnum
swap emit emit-seq ;
dup dup 0 < [ neg ] when bignum>seq
[ nip length 1+ emit-fixnum ]
[ drop 0 < 1 0 ? emit ]
[ nip emit-seq ]
2tri ;
M: bignum '
bignum tag-number dup [ emit-bignum ] emit-object ;
@ -221,28 +223,33 @@ M: f '
! Words
: emit-word ( word -- )
dup subwords [ emit-word ] each
[
dup hashcode ' ,
dup word-name ' ,
dup word-vocabulary ' ,
dup word-def ' ,
dup word-props ' ,
f ' ,
0 , ! count
0 , ! xt
0 , ! code
0 , ! profiling
] { } make
\ word type-number object tag-number
[ emit-seq ] emit-object
swap objects get set-at ;
[ subwords [ emit-word ] each ]
[
[
{
[ hashcode , ]
[ word-name , ]
[ word-vocabulary , ]
[ word-def , ]
[ word-props , ]
} cleave
f ,
0 , ! count
0 , ! xt
0 , ! code
0 , ! profiling
] { } make [ ' ] map
] bi
\ word type-number object tag-number
[ emit-seq ] emit-object
] keep objects get set-at ;
: word-error ( word msg -- * )
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
: transfer-word ( word -- word )
dup target-word swap or ;
[ target-word ] keep or ;
: fixup-word ( word -- offset )
transfer-word dup objects get at
@ -285,9 +292,10 @@ M: string '
length 0 assert= ;
: emit-dummy-array ( obj type -- ptr )
swap assert-empty
type-number object tag-number
[ 0 emit-fixnum ] emit-object ;
[ assert-empty ] [
type-number object tag-number
[ 0 emit-fixnum ] emit-object
] bi* ;
M: byte-array ' byte-array emit-dummy-array ;
@ -296,29 +304,28 @@ M: bit-array ' bit-array emit-dummy-array ;
M: float-array ' float-array emit-dummy-array ;
! Tuples
: (emit-tuple) ( tuple -- pointer )
[ tuple>array 1 tail-slice ]
[ class transfer-word tuple-layout ] bi prefix [ ' ] map
tuple type-number dup [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer )
[
[
dup class transfer-word tuple-layout ' ,
tuple>array 1 tail-slice [ ' ] map %
] { } make
tuple type-number dup [ emit-seq ] emit-object
]
! Hack
over class word-name "tombstone" =
[ objects get swap cache ] [ call ] if ;
dup class word-name "tombstone" =
[ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
M: tuple ' emit-tuple ;
M: tuple-layout '
objects get [
[
dup layout-hashcode ' ,
dup layout-class ' ,
dup layout-size ' ,
dup layout-superclasses ' ,
layout-echelon ' ,
] { } make
{
[ layout-hashcode , ]
[ layout-class , ]
[ layout-size , ]
[ layout-superclasses , ]
[ layout-echelon , ]
} cleave
] { } make [ ' ] map
\ tuple-layout type-number
object tag-number [ emit-seq ] emit-object
] cache ;
@ -329,14 +336,9 @@ M: tombstone '
word-def first objects get [ emit-tuple ] cache ;
! Arrays
: emit-array ( list type tag -- pointer )
>r >r [ ' ] map r> r> [
dup length emit-fixnum
emit-seq
] emit-object ;
M: array '
array type-number object tag-number emit-array ;
[ ' ] map array type-number object tag-number
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
! Quotations
@ -351,13 +353,6 @@ M: quotation '
] emit-object
] cache ;
! Curries
M: curry '
dup curry-quot ' swap curry-obj '
\ curry type-number object tag-number
[ emit emit ] emit-object ;
! End of the image
: emit-words ( -- )
@ -437,8 +432,8 @@ M: curry '
: write-image ( image -- )
"Writing image to " write
architecture get boot-image-name resource-path
dup write "..." print flush
binary <file-writer> [ (write-image) ] with-stream ;
[ write "..." print flush ]
[ binary <file-writer> [ (write-image) ] with-stream ] bi ;
PRIVATE>

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

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays
float-arrays quotations assocs layouts classes.tuple.private ;
float-arrays quotations assocs layouts classes.tuple.private
kernel.private ;
BIN: 111 tag-mask set
8 num-tags set
@ -15,6 +16,7 @@ H{
{ bignum BIN: 001 }
{ tuple BIN: 010 }
{ object BIN: 011 }
{ hi-tag BIN: 011 }
{ ratio BIN: 100 }
{ float BIN: 101 }
{ complex BIN: 110 }

151
core/bootstrap/primitives.factor
View File

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

1
core/bootstrap/stage1.factor
View File

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

6
core/bootstrap/stage2.factor
View File

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

2
core/bootstrap/syntax.factor
View File

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

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

@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects ;
random inference effects kernel.private ;
: class= [ class< ] 2keep swap class< and ;
@ -23,8 +23,8 @@ random inference effects ;
[ t ] [ number object number class-and* ] unit-test
[ t ] [ object number number class-and* ] unit-test
[ t ] [ slice reversed null class-and* ] unit-test
[ t ] [ general-t \ f null class-and* ] unit-test
[ t ] [ general-t \ f object class-or* ] unit-test
[ t ] [ \ f class-not \ f null class-and* ] unit-test
[ t ] [ \ f class-not \ f object class-or* ] unit-test
TUPLE: first-one ;
TUPLE: second-one ;
@ -96,7 +96,7 @@ UNION: z1 b1 c1 ;
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
[ f ] [ growable hi-tag classes-intersect? ] unit-test
[ f ] [ growable \ hi-tag classes-intersect? ] unit-test
[ t ] [
growable tuple sequence class-and class<

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables
;
kernel.private ;
IN: classes.algebra
: 2cache ( key1 key2 assoc quot -- value )
@ -138,10 +138,10 @@ C: <anonymous-complement> anonymous-complement
members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class )
>r members>> r> add <anonymous-intersection> ;
>r members>> r> suffix <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class )
members>> swap add <anonymous-intersection> ;
members>> swap suffix <anonymous-intersection> ;
: (class-and) ( first second -- class )
{
@ -158,10 +158,10 @@ C: <anonymous-complement> anonymous-complement
} cond ;
: left-anonymous-union-or ( first second -- class )
>r members>> r> add <anonymous-union> ;
>r members>> r> suffix <anonymous-union> ;
: right-anonymous-union-or ( first second -- class )
members>> swap add <anonymous-union> ;
members>> swap suffix <anonymous-union> ;
: (class-or) ( first second -- class )
{
@ -211,12 +211,6 @@ C: <anonymous-complement> anonymous-complement
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
: class-hashes ( class -- seq )
flatten-class keys [
dup builtin-class?
[ "type" word-prop ] [ hashcode ] if
] map ;
: flatten-builtin-class ( class -- assoc )
flatten-class [
dup tuple class< [ 2drop tuple tuple ] when
@ -229,5 +223,5 @@ C: <anonymous-complement> anonymous-complement
: class-tags ( class -- tag/f )
class-types [
dup num-tags get >=
[ drop object tag-number ] when
[ drop \ hi-tag tag-number ] when
] map prune ;

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

@ -21,7 +21,6 @@ $nl
{ { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } }
{ { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } }
{ { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } }
{ { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } }
}
"The set of class predicate words is a class:"
{ $subsection predicate }
@ -47,6 +46,7 @@ $nl
"Other sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
{ $subsection "singletons" }
{ $subsection "mixins" }
{ $subsection "predicates" }
"Classes can be inspected and operated upon:"

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

@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files
compiler.units ;
compiler.units kernel.private ;
IN: classes.tests
! DEFER: bah
@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
! Test generic see and parsing
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
[ [ \ bah see ] with-string-writer ] unit-test
[ t ] [ 3 object instance? ] unit-test
[ t ] [ 3 fixnum instance? ] unit-test
[ f ] [ 3 float instance? ] unit-test
[ t ] [ 3 number instance? ] unit-test
[ f ] [ 3 null instance? ] unit-test
[ t ] [ "hi" \ hi-tag instance? ] unit-test

59
core/classes/classes.factor
View File

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

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

@ -7,7 +7,7 @@ IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class
{ "metaclass" "members" "mixin" } reset-props ;
{ "class" "metaclass" "members" "mixin" } reset-props ;
: redefine-mixin-class ( class members -- )
dupd define-union-class
@ -35,7 +35,7 @@ TUPLE: check-mixin-class mixin ;
swap redefine-mixin-class ; inline
: add-mixin-instance ( class mixin -- )
[ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ;
[ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;

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

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

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

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

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

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

@ -0,0 +1,12 @@
USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
IN: classes.singleton.tests
[ ] [ SINGLETON: bzzt ] unit-test
[ t ] [ bzzt bzzt? ] unit-test
[ t ] [ bzzt bzzt eq? ] unit-test
GENERIC: zammo ( obj -- str )
[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
[ "yes!" ] [ bzzt zammo ] unit-test
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton-class? ] unit-test
[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test

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

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

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

@ -153,26 +153,6 @@ HELP: tuple=
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
HELP: permutation
{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
HELP: reshape-tuple
{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } }
{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ;
HELP: reshape-tuples
{ $values { "class" tuple-class } { "superclass" class } { "newslots" "a sequence of strings" } }
{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
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-slots
{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
HELP: tuple
{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
$nl

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

@ -3,7 +3,7 @@ math.constants parser sequences tools.test words assocs
namespaces quotations sequences.private classes continuations
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting ;
calendar prettyprint io.streams.string splitting inspector ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@ -62,13 +62,13 @@ C: <point> point
[ 200 ] [ "p" get y>> ] unit-test
[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
"p" get 300 ">>z" "accessors" lookup execute drop
[ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
[ 4 ] [ "p" get tuple-size ] unit-test
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
"IN: classes.tuple.tests TUPLE: point z y ;" eval
[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
[ 3 ] [ "p" get tuple-size ] unit-test
@ -265,9 +265,13 @@ C: <laptop> laptop
[ t ] [ "laptop" get computer? ] unit-test
[ t ] [ "laptop" get tuple? ] unit-test
[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
[ 128 ] [ "laptop" get ram>> ] unit-test
[ t ] [ "laptop" get battery>> 3 hours = ] unit-test
: test-laptop-slot-values
[ laptop ] [ "laptop" get class ] unit-test
[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
[ 128 ] [ "laptop" get ram>> ] unit-test
[ t ] [ "laptop" get battery>> 3 hours = ] unit-test ;
test-laptop-slot-values
[ laptop ] [
"laptop" get tuple-layout
@ -294,9 +298,13 @@ C: <server> server
[ t ] [ "server" get computer? ] unit-test
[ t ] [ "server" get tuple? ] unit-test
[ "PowerPC" ] [ "server" get cpu>> ] unit-test
[ 64 ] [ "server" get ram>> ] unit-test
[ "1U" ] [ "server" get rackmount>> ] unit-test
: test-server-slot-values
[ server ] [ "server" get class ] unit-test
[ "PowerPC" ] [ "server" get cpu>> ] unit-test
[ 64 ] [ "server" get ram>> ] unit-test
[ "1U" ] [ "server" get rackmount>> ] unit-test ;
test-server-slot-values
[ f ] [ "server" get laptop? ] unit-test
[ f ] [ "laptop" get server? ] unit-test
@ -316,10 +324,10 @@ C: <server> server
"IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
] must-fail
! Reshaping with inheritance
! Dynamically changing inheritance hierarchy
TUPLE: electronic-device ;
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device ;" eval ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
[ f ] [ electronic-device laptop class< ] unit-test
[ t ] [ server electronic-device class< ] unit-test
@ -335,11 +343,125 @@ TUPLE: electronic-device ;
[ f ] [ "server" get laptop? ] unit-test
[ t ] [ "server" get server? ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer ;" eval ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test
[ f ] [ "laptop" get electronic-device? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test
test-laptop-slot-values
test-server-slot-values
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test
test-laptop-slot-values
test-server-slot-values
TUPLE: make-me-some-accessors voltage grounded? ;
[ f ] [ "laptop" get voltage>> ] unit-test
[ f ] [ "server" get voltage>> ] unit-test
[ ] [ "laptop" get 220 >>voltage drop ] unit-test
[ ] [ "server" get 110 >>voltage drop ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test
test-laptop-slot-values
test-server-slot-values
[ 220 ] [ "laptop" get voltage>> ] unit-test
[ 110 ] [ "server" get voltage>> ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test
test-laptop-slot-values
test-server-slot-values
[ 220 ] [ "laptop" get voltage>> ] unit-test
[ 110 ] [ "server" get voltage>> ] unit-test
! Reshaping superclass and subclass simultaneously
"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval
test-laptop-slot-values
test-server-slot-values
[ 220 ] [ "laptop" get voltage>> ] unit-test
[ 110 ] [ "server" get voltage>> ] unit-test
! Reshape crash
TUPLE: test1 a ; TUPLE: test2 < test1 b ;
C: <test2> test2
"a" "b" <test2> "test" set
: test-a/b
[ "a" ] [ "test" get a>> ] unit-test
[ "b" ] [ "test" get b>> ] unit-test ;
test-a/b
[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test
test-a/b
[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test
test-a/b
! Twice in the same compilation unit
[
test1 tuple { "a" "x" "y" } define-tuple-class
test1 tuple { "a" "y" } define-tuple-class
] with-compilation-unit
test-a/b
! Moving slots up and down
TUPLE: move-up-1 a b ;
TUPLE: move-up-2 < move-up-1 c ;
T{ move-up-2 f "a" "b" "c" } "move-up" set
: test-move-up
[ "a" ] [ "move-up" get a>> ] unit-test
[ "b" ] [ "move-up" get b>> ] unit-test
[ "c" ] [ "move-up" get c>> ] unit-test ;
test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test
test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test
test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test
test-move-up
[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test
! Constructors must be recompiled when changing superclass
TUPLE: constructor-update-1 xxx ;
TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
C: <constructor-update-2> constructor-update-2
{ 3 1 } [ <constructor-update-2> ] must-infer-as
[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test
{ 5 1 } [ <constructor-update-2> ] must-infer-as
[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
! Redefinition problem
TUPLE: redefinition-problem ;
@ -389,3 +511,45 @@ USE: vocabs
define-tuple-class
] with-compilation-unit
] unit-test
[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with
! Accessors not being forgotten...
[ [ ] ] [
"IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
<string-reader>
"forget-accessors-test" parse-stream
] unit-test
[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
: accessor-exists? ( class name -- ? )
>r "forget-accessors-test" "classes.tuple.tests" lookup r>
">>" append "accessors" lookup method >boolean ;
[ t ] [ "x" accessor-exists? ] unit-test
[ t ] [ "y" accessor-exists? ] unit-test
[ t ] [ "z" accessor-exists? ] unit-test
[ [ ] ] [
"IN: classes.tuple.tests GENERIC: forget-accessors-test"
<string-reader>
"forget-accessors-test" parse-stream
] unit-test
[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
[ f ] [ "x" accessor-exists? ] unit-test
[ f ] [ "y" accessor-exists? ] unit-test
[ f ] [ "z" accessor-exists? ] unit-test
TUPLE: another-forget-accessors-test ;
[ [ ] ] [
"IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
<string-reader>
"another-forget-accessors-test" parse-stream
] unit-test
[ t ] [ \ another-forget-accessors-test class? ] unit-test

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

@ -19,12 +19,20 @@ ERROR: no-tuple-class class ;
GENERIC: tuple-layout ( object -- layout )
M: class tuple-layout "layout" word-prop ;
M: tuple-class tuple-layout "layout" word-prop ;
M: tuple tuple-layout 1 slot ;
M: tuple-layout tuple-layout ;
: tuple-size tuple-layout layout-size ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
[ tuple-size ] [ ] [ tuple-layout ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
PRIVATE>
: check-tuple ( class -- )
@ -32,28 +40,31 @@ PRIVATE>
[ drop ] [ no-tuple-class ] if ;
: tuple>array ( tuple -- array )
dup tuple-layout
[ layout-size swap [ array-nth ] curry map ] keep
layout-class add* ;
prepare-tuple>array
>r copy-tuple-slots r>
layout-class prefix ;
: >tuple ( seq -- tuple )
dup first tuple-layout <tuple> [
>r 1 tail-slice dup length r>
[ tuple-size min ] keep
[ set-array-nth ] curry
2each
: tuple-slots ( tuple -- array )
prepare-tuple>array drop copy-tuple-slots ;
: slots>tuple ( tuple class -- array )
tuple-layout <tuple> [
[ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
] keep ;
: >tuple ( tuple -- array )
unclip slots>tuple ;
: slot-names ( class -- seq )
"slots" word-prop [ name>> ] map ;
"slot-names" word-prop ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
over tuple-layout over tuple-layout eq? [
dup tuple-size -rot
[ >r over r> array-nth >r array-nth r> = ] 2curry
all-integers?
2dup [ tuple-layout ] bi@ eq? [
[ drop tuple-size ]
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
2bi all-integers?
] [
2drop f
] if ;
@ -92,72 +103,87 @@ PRIVATE>
superclasses 1 head-slice*
[ slot-names length ] map sum ;
: generate-tuple-slots ( class slots -- slots )
: generate-tuple-slots ( class slots -- slot-specs )
over superclass-size 2 + simple-slots ;
: define-tuple-slots ( class slots -- )
dupd generate-tuple-slots
: define-tuple-slots ( class -- )
dup dup slot-names generate-tuple-slots
[ "slots" set-word-prop ]
[ define-accessors ]
[ define-slots ] 2tri ;
[ define-accessors ] ! new
[ define-slots ] ! old
2tri ;
: make-tuple-layout ( class -- layout )
[ ]
[ [ superclass-size ] [ "slots" word-prop length ] bi + ]
[ [ superclass-size ] [ slot-names length ] bi + ]
[ superclasses dup length 1- ] tri
<tuple-layout> ;
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
: removed-slots ( class newslots -- seq )
swap slot-names seq-diff ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
: forget-slots ( class slots -- )
dupd removed-slots [
[ reader-word forget-method ]
[ writer-word forget-method ] 2bi
] with each ;
: compute-slot-permutation ( class old-slot-names -- permutation )
>r all-slot-names r> [ index ] curry map ;
: permutation ( seq1 seq2 -- permutation )
swap [ index ] curry map ;
: apply-slot-permutation ( old-values permutation -- new-values )
[ [ swap ?nth ] [ drop f ] if* ] with map ;
: reshape-tuple ( oldtuple permutation -- newtuple )
>r tuple>array 2 cut r>
[ [ swap ?nth ] [ drop f ] if* ] with map
append >tuple ;
: permute-slots ( old-values -- new-values )
dup first dup outdated-tuples get at
compute-slot-permutation
apply-slot-permutation ;
: reshape-tuples ( class superclass newslots -- )
nip
>r dup slot-names r> permutation
[
>r "predicate" word-prop instances dup
r> [ reshape-tuple ] curry map
become
] 2curry after-compilation ;
: change-tuple ( tuple quot -- newtuple )
>r tuple>array r> call >tuple ; inline
: update-tuple ( tuple -- newtuple )
[ permute-slots ] change-tuple ;
: update-tuples ( -- )
outdated-tuples get
dup assoc-empty? [ drop ] [
[ >r class r> key? ] curry instances
dup [ update-tuple ] map become
] if ;
[ update-tuples ] update-tuples-hook set-global
: update-tuples-after ( class -- )
outdated-tuples get [ all-slot-names ] cache drop ;
M: tuple-class update-class
[ define-tuple-layout ]
[ define-tuple-slots ]
[ define-tuple-predicate ]
tri ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
[ nip define-tuple-slots ] [
2drop
class-usages keys [ tuple-class? ] subset [
[ define-tuple-layout ]
[ define-tuple-predicate ]
bi
] each
] 3tri ;
[ nip "slot-names" set-word-prop ]
[ 2drop update-classes ]
3tri ;
: subclasses ( class -- classes )
class-usages keys [ tuple-class? ] subset ;
: each-subclass ( class quot -- )
>r subclasses r> each ; inline
: redefine-tuple-class ( class superclass slots -- )
[ reshape-tuples ]
[
nip
[ forget-slots ]
[ drop changed-word ]
[ drop redefined ]
2tri
2drop
[
[ update-tuples-after ]
[ changed-word ]
[ redefined ]
tri
] each-subclass
]
[ define-new-tuple-class ]
3tri ;
3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? )
rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
@ -175,20 +201,31 @@ M: tuple-class define-tuple-class
3drop ;
: define-error-class ( class superclass slots -- )
pick >r define-tuple-class r>
[ define-tuple-class ] [ 2drop ] 3bi
dup [ construct-boa throw ] curry define ;
M: tuple-class reset-class
[
dup "slot-names" word-prop [
[ reader-word method forget ]
[ writer-word method forget ] 2bi
] with each
] [
{
"class"
"metaclass"
"superclass"
"layout"
"slots"
} reset-props
] bi ;
M: tuple clone
(clone) dup delegate clone over set-delegate ;
M: tuple equal?
over tuple? [ tuple= ] [ 2drop f ] if ;
: delegates ( obj -- seq )
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
M: tuple hashcode*
[
dup tuple-size -rot 0 -rot [
@ -196,23 +233,13 @@ M: tuple hashcode*
] 2curry reduce
] recursive-hashcode ;
: tuple-slots ( tuple -- seq ) tuple>array 2 tail ;
! Definition protocol
M: tuple-class reset-class
{ "metaclass" "superclass" "slots" "layout" } reset-props ;
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
M: object set-slots ( ... obj slots -- )
<reversed> get-slots ;
M: object construct-empty ( class -- tuple )
tuple-layout <tuple> ;
: delegates ( obj -- seq ) [ delegate ] follow ;
M: object construct ( ... slots class -- tuple )
construct-empty [ swap set-slots ] keep ;
M: object construct-boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline

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

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

18
core/combinators/combinators.factor
View File

@ -9,18 +9,24 @@ hashtables sorting ;
[ call ] with each ;
: cleave>quot ( seq -- quot )
[ [ keep ] curry ] map concat [ drop ] append ;
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
: 2cleave ( x seq -- )
[ [ call ] 3keep drop ] each 2drop ;
[ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
[ [ 2keep ] curry ] map concat [ 2drop ] append ;
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
: 3cleave ( x seq -- )
[ 3keep ] each 3drop ;
: 3cleave>quot ( seq -- quot )
[ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
: spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi
append ;
append [ ] like ;
: spread ( objs... seq -- )
spread>quot call ;
@ -43,7 +49,7 @@ ERROR: no-case ;
: with-datastack ( stack quot -- newstack )
datastack >r
>r >array set-datastack r> call
datastack r> swap add set-datastack 2nip ; inline
datastack r> swap suffix set-datastack 2nip ; inline
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
@ -66,7 +72,7 @@ M: hashtable hashcode*
reverse [ no-cond ] swap alist>quot ;
: linear-case-quot ( default assoc -- quot )
[ >r [ dupd = ] curry r> \ drop add* ] assoc-map
[ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
alist>quot ;
: (distribute-buckets) ( buckets pair keys -- )

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

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

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

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

6
core/compiler/compiler.factor
View File

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

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

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

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

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

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

@ -69,21 +69,19 @@ GENERIC: definitions-changed ( assoc obj -- )
dup [ drop crossref? ] assoc-contains?
modify-code-heap ;
SYMBOL: post-compile-tasks
: after-compilation ( quot -- )
post-compile-tasks get push ;
SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: call-recompile-hook ( -- )
changed-words get keys
compiled-usages recompile-hook get call ;
: call-post-compile-tasks ( -- )
post-compile-tasks get [ call ] each ;
: call-update-tuples-hook ( -- )
update-tuples-hook get call ;
: finish-compilation-unit ( -- )
call-recompile-hook
call-post-compile-tasks
call-update-tuples-hook
dup [ drop crossref? ] assoc-contains? modify-code-heap
changed-definitions notify-definition-observers ;
@ -91,7 +89,7 @@ SYMBOL: post-compile-tasks
[
H{ } clone changed-words set
H{ } clone forgotten-definitions set
V{ } clone post-compile-tasks set
H{ } clone outdated-tuples set
<definitions> new-definitions set
<definitions> old-definitions set
[ finish-compilation-unit ]

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

@ -29,6 +29,7 @@ $nl
{ $subsection ignore-errors }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
{ $subsection "debugger" }
{ $subsection "errors-post-mortem" }
"When Factor encouters a critical error, it calls the following word:"
{ $subsection die } ;

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

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

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

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

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

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

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

@ -94,14 +94,14 @@ IN: cpu.ppc.intrinsics
} define-intrinsics
: fixnum-register-op ( op -- pair )
[ "out" operand "y" operand "x" operand ] swap add H{
[ "out" operand "y" operand "x" operand ] swap suffix H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} 2array ;
: fixnum-value-op ( op -- pair )
[ "out" operand "x" operand "y" operand ] swap add H{
[ "out" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
@ -205,11 +205,11 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
: fixnum-register-jump ( op -- pair )
[ "x" operand 0 "y" operand CMP ] swap add
[ "x" operand 0 "y" operand CMP ] swap suffix
{ { f "x" } { f "y" } } 2array ;
: fixnum-value-jump ( op -- pair )
[ 0 "x" operand "y" operand CMPI ] swap add
[ 0 "x" operand "y" operand CMPI ] swap suffix
{ { f "x" } { [ small-tagged? ] "y" } } 2array ;
: define-fixnum-jump ( word op -- )
@ -336,7 +336,7 @@ IN: cpu.ppc.intrinsics
} define-intrinsic
: define-float-op ( word op -- )
[ "z" operand "x" operand "y" operand ] swap add H{
[ "z" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +scratch+ { { float "z" } } }
{ +output+ { "z" } }
@ -352,7 +352,7 @@ IN: cpu.ppc.intrinsics
] each
: define-float-jump ( word op -- )
[ "x" operand 0 "y" operand FCMPU ] swap add
[ "x" operand 0 "y" operand FCMPU ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
@ -402,55 +402,6 @@ IN: cpu.ppc.intrinsics
{ +output+ { "out" } }
} define-intrinsic
\ type [
"end" define-label
! Get the tag
"y" operand "obj" operand tag-mask get ANDI
! Tag the tag
"y" operand "x" operand %tag-fixnum
! Compare with object tag number (3).
0 "y" operand object tag-number CMPI
! Jump if the object doesn't store type info in its header
"end" get BNE
! It does store type info in its header
"x" operand "obj" operand header-offset LWZ
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } { f "y" } } }
{ +output+ { "x" } }
} define-intrinsic
\ class-hash [
"end" define-label
"tuple" define-label
"object" define-label
! Get the tag
"y" operand "obj" operand tag-mask get ANDI
! Compare with tuple tag number (2).
0 "y" operand tuple tag-number CMPI
"tuple" get BEQ
! Compare with object tag number (3).
0 "y" operand object tag-number CMPI
"object" get BEQ
! Tag the tag
"y" operand "x" operand %tag-fixnum
"end" get B
"object" get resolve-label
! Load header type
"x" operand "obj" operand header-offset LWZ
"end" get B
"tuple" get resolve-label
! Load class hash
"x" operand "obj" operand tuple-class-offset LWZ
"x" operand dup class-hash-offset LWZ
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } { f "y" } } }
{ +output+ { "x" } }
} define-intrinsic
: userenv ( reg -- )
#! Load the userenv pointer in a register.
"userenv" f rot %load-dlsym ;

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -19,58 +19,6 @@ IN: cpu.x86.intrinsics
{ +output+ { "in" } }
} define-intrinsic
\ type [
"end" define-label
! Make a copy
"x" operand "obj" operand MOV
! Get the tag
"x" operand tag-mask get AND
! Tag the tag
"x" operand %tag-fixnum
! Compare with object tag number (3).
"x" operand object tag-number tag-fixnum CMP
"end" get JNE
! If we have equality, load type from header
"x" operand "obj" operand -3 [+] MOV
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
\ class-hash [
"end" define-label
"tuple" define-label
"object" define-label
! Make a copy
"x" operand "obj" operand MOV
! Get the tag
"x" operand tag-mask get AND
! Tag the tag
"x" operand %tag-fixnum
! Compare with tuple tag number (2).
"x" operand tuple tag-number tag-fixnum CMP
"tuple" get JE
! Compare with object tag number (3).
"x" operand object tag-number tag-fixnum CMP
"object" get JE
"end" get JMP
"object" get resolve-label
! Load header type
"x" operand "obj" operand header-offset [+] MOV
"end" get JMP
"tuple" get resolve-label
! Load class hash
"x" operand "obj" operand tuple-class-offset [+] MOV
"x" operand dup class-hash-offset [+] MOV
"end" resolve-label
] H{
{ +input+ { { f "obj" } } }
{ +scratch+ { { f "x" } } }
{ +output+ { "x" } }
} define-intrinsic
! Slots
: %slot-literal-known-tag
"obj" operand
@ -156,7 +104,7 @@ IN: cpu.x86.intrinsics
! Fixnums
: fixnum-op ( op hash -- pair )
>r [ "x" operand "y" operand ] swap add r> 2array ;
>r [ "x" operand "y" operand ] swap suffix r> 2array ;
: fixnum-value-op ( op -- pair )
H{
@ -251,7 +199,7 @@ IN: cpu.x86.intrinsics
\ fixnum- \ SUB overflow-template
: fixnum-jump ( op inputs -- pair )
>r [ "x" operand "y" operand CMP ] swap add r> 2array ;
>r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
: fixnum-value-jump ( op -- pair )
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;

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

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

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

@ -1,6 +1,7 @@
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
help generic.standard continuations system debugger.private ;
help generic.standard continuations system debugger.private
io.files.private ;
IN: debugger
ARTICLE: "errors-assert" "Assertions"
@ -86,7 +87,15 @@ HELP: error-hook
HELP: try
{ $values { "quot" "a quotation" } }
{ $description "Calls the quotation. If it throws an error, calls " { $link error-hook } " with the error and restores the data stack." } ;
{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
{ $examples
"The following example prints an error and keeps going:"
{ $code
"[ \"error\" throw ] try"
"\"still running...\" print"
}
{ $link "listener" } " uses " { $link try } " to recover from user errors."
} ;
HELP: expired-error.
{ $error-description "Thrown by " { $link alien-address } " and " { $link alien-invoke } " if an " { $link alien } " object passed in as a parameter has expired. Alien objects expire if they are saved an image which is subsequently loaded; this prevents a certain class of programming errors, usually attempts to use uninitialized objects, since holding a C address is meaningless between sessions." }

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

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

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

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

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

@ -37,7 +37,6 @@ $nl
{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
{ $subsection methods }
"A generic word contains methods; the list of methods specializing on a class can also be obtained:"
{ $subsection implementors }
"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
@ -63,15 +62,6 @@ ARTICLE: "method-combination" "Custom method combination"
"Developing a custom method combination requires that a parsing word calling " { $link define-generic } " be defined; additionally, it is a good idea to implement the definition protocol words " { $link definer } " and " { $link synopsis* } " on the class of words having this method combination, to properly support developer tools."
$nl
"The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation."
$nl
"Method combination utilities:"
{ $subsection single-combination }
{ $subsection class-predicates }
{ $subsection simplify-alist }
{ $subsection math-upgrade }
{ $subsection object-method }
{ $subsection error-method }
"More quotation construction utilities can be found in " { $link "quotations" } " and " { $link "combinators-quot" } "."
{ $see-also "generic-introspection" } ;
ARTICLE: "generic" "Generic words and methods"
@ -129,10 +119,6 @@ HELP: <method>
{ $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
{ $description "Creates a new method." } ;
HELP: methods
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
HELP: order
{ $values { "generic" generic } { "seq" "a sequence of classes" } }
{ $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ;
@ -160,4 +146,4 @@ HELP: forget-methods
{ $values { "class" class } }
{ $description "Remove all method definitions which specialize on the class." } ;
{ sort-classes methods order } related-words
{ sort-classes order } related-words

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

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

75
core/generic/generic.factor
View File

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

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

@ -12,9 +12,9 @@ PREDICATE: math-class < class
number bootstrap-word class<
] if ;
: last/first ( seq -- pair ) dup peek swap first 2array ;
: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
: math-precedence ( class -- n )
: math-precedence ( class -- pair )
{
{ [ dup null class< ] [ drop { -1 -1 } ] }
{ [ dup math-class? ] [ class-types last/first ] }
@ -71,13 +71,15 @@ M: math-combination make-default-method
M: math-combination perform-combination
drop
dup
\ over [
dup math-class? [
\ dup [ >r 2dup r> math-method ] math-vtable
] [
over object-method
] if nip
] math-vtable nip ;
] math-vtable nip
define ;
PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -3,14 +3,23 @@
USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors ;
continuations debugger assocs combinators compiler.errors
generic.standard.engines.tuple ;
IN: inference.backend
: recursive-label ( word -- label/f )
recursive-state get at ;
: inline? ( word -- ? )
dup "method-generic" word-prop swap or "inline" word-prop ;
GENERIC: inline? ( word -- ? )
M: method-body inline?
"method-generic" word-prop inline? ;
M: tuple-dispatch-engine-word inline?
"tuple-dispatch-generic" word-prop inline? ;
M: word inline?
"inline" word-prop ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys
@ -92,7 +101,7 @@ M: wrapper apply-object
r> recursive-state set ;
: infer-quot-recursive ( quot word label -- )
recursive-state get -rot 2array add* infer-quot ;
recursive-state get -rot 2array prefix infer-quot ;
: time-bomb ( error -- )
[ throw ] curry recursive-state get infer-quot ;
@ -109,7 +118,7 @@ TUPLE: recursive-quotation-error quot ;
dup value-literal callable? [
dup value-literal
over value-recursion
rot f 2array add* infer-quot
rot f 2array prefix infer-quot
] [
drop bad-call
] if
@ -430,7 +439,7 @@ M: #call-label collect-recursion*
[ [ swap collect-recursion* ] curry each-node ] { } make ;
: join-values ( node -- )
collect-recursion [ node-in-d ] map meta-d get add
collect-recursion [ node-in-d ] map meta-d get suffix
unify-lengths unify-stacks
meta-d [ length tail* ] change ;

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

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

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

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

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

@ -9,15 +9,13 @@ IN: inference.dataflow
: <computed> \ <computed> counter ;
! Literal value
TUPLE: value literal uid recursion ;
TUPLE: value < identity-tuple literal uid recursion ;
: <value> ( obj -- value )
<computed> recursive-state get value construct-boa ;
M: value hashcode* nip value-uid ;
M: value equal? 2drop f ;
! Result of curry
TUPLE: curried obj quot ;
@ -30,13 +28,12 @@ C: <composed> composed
UNION: special curried composed ;
TUPLE: node param
TUPLE: node < identity-tuple
param
in-d out-d in-r out-r
classes literals intervals
history successor children ;
M: node equal? 2drop f ;
M: node hashcode* drop node hashcode* ;
GENERIC: flatten-curry ( value -- )
@ -205,7 +202,7 @@ UNION: #branch #if #dispatch ;
2dup 2slip rot [
2drop t
] [
>r dup node-children swap node-successor add r>
>r dup node-children swap node-successor suffix r>
[ node-exists? ] curry contains?
] if
] [

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -28,11 +28,14 @@ ARTICLE: "pathnames" "Pathname manipulation"
{ $subsection <pathname> } ;
ARTICLE: "directories" "Directories"
"Current and home directories:"
"Current directory:"
{ $subsection with-directory }
{ $subsection current-directory }
"Home directory:"
{ $subsection home }
"Current system directory:"
{ $subsection cwd }
{ $subsection cd }
{ $subsection with-directory }
{ $subsection home }
"Directory listing:"
{ $subsection directory }
{ $subsection directory* }
@ -197,19 +200,20 @@ HELP: file-contents
HELP: cwd
{ $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ;
HELP: cd
{ $values { "path" "a pathname string" } }
{ $description "Changes the current working directory of the Factor process." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
{ $warning "Modifying the current directory through system calls is unsafe. Use the " { $link with-directory } " word instead." } ;
{ cd cwd with-directory } related-words
{ cd cwd current-directory with-directory } related-words
HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Changes the current working directory for the duration of a quotation's execution." }
{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
{ $description "Changes the " { $link current-directory } " variable for the duration of a quotation's execution. Words that use the file-system should call " { $link normalize-path } " in order to obtain a path relative to the current directory." } ;
HELP: append-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
@ -252,7 +256,7 @@ HELP: normalize-directory
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
HELP: normalize-pathname
HELP: normalize-path
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;

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

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

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

@ -3,7 +3,7 @@
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
io.encodings.binary init ;
io.encodings.binary init accessors ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream )
HOOK: (file-appender) io-backend ( path -- stream )
: <file-reader> ( path encoding -- stream )
swap normalize-pathname (file-reader) swap <decoder> ;
swap normalize-path (file-reader) swap <decoder> ;
: <file-writer> ( path encoding -- stream )
swap normalize-pathname (file-writer) swap <encoder> ;
swap normalize-path (file-writer) swap <encoder> ;
: <file-appender> ( path encoding -- stream )
swap normalize-pathname (file-appender) swap <encoder> ;
swap normalize-path (file-appender) swap <encoder> ;
: file-lines ( path encoding -- seq )
<file-reader> lines ;
@ -43,9 +43,9 @@ HOOK: (file-appender) io-backend ( path -- stream )
>r <file-appender> r> with-stream ; inline
! Pathnames
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
: path-separator ( -- string ) windows? "\\" "/" ? ;
: path-separator ( -- string ) os windows? "\\" "/" ? ;
: right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ;
@ -102,6 +102,7 @@ PRIVATE>
: windows-absolute-path? ( path -- path ? )
{
{ [ dup "\\\\?\\" head? ] [ t ] }
{ [ dup length 2 < ] [ f ] }
{ [ dup second CHAR: : = ] [ t ] }
{ [ t ] [ f ] }
@ -111,8 +112,8 @@ PRIVATE>
{
{ [ dup empty? ] [ f ] }
{ [ dup "resource:" head? ] [ t ] }
{ [ os windows? ] [ windows-absolute-path? ] }
{ [ dup first path-separator? ] [ t ] }
{ [ windows? ] [ windows-absolute-path? ] }
{ [ t ] [ f ] }
} cond nip ;
@ -126,6 +127,9 @@ PRIVATE>
2 tail left-trim-separators
>r parent-directory r> append-path
] }
{ [ over absolute-path? over first path-separator? and ] [
>r 2 head r> append
] }
{ [ t ] [
>r right-trim-separators "/" r>
left-trim-separators 3append
@ -145,8 +149,17 @@ PRIVATE>
TUPLE: file-info type size permissions modified ;
HOOK: file-info io-backend ( path -- info )
! Symlinks
HOOK: link-info io-backend ( path -- info )
HOOK: make-link io-backend ( path1 path2 -- )
HOOK: read-link io-backend ( path -- info )
: copy-link ( path1 path2 -- )
>r read-link r> make-link ;
SYMBOL: +regular-file+
SYMBOL: +directory+
SYMBOL: +character-device+
@ -158,34 +171,52 @@ SYMBOL: +unknown+
! File metadata
: exists? ( path -- ? )
normalize-pathname (exists?) ;
normalize-path (exists?) ;
: directory? ( path -- ? )
file-info file-info-type +directory+ = ;
! Current working directory
<PRIVATE
HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path )
SYMBOL: current-directory
M: object cwd ( -- path ) "." ;
PRIVATE>
SYMBOL: current-directory
[ cwd current-directory set-global ] "io.files" add-init-hook
: resource-path ( path -- newpath )
"resource-path" get [ image parent-directory ] unless*
prepend-path ;
: (normalize-path) ( path -- path' )
"resource:" ?head [
left-trim-separators resource-path
(normalize-path)
] [
current-directory get prepend-path
] if ;
M: object normalize-path ( path -- path' )
(normalize-path) ;
: with-directory ( path quot -- )
>r normalize-pathname r>
>r (normalize-path) r>
current-directory swap with-variable ; inline
: set-current-directory ( path -- )
normalize-pathname current-directory set ;
normalize-path current-directory set ;
! Creating directories
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
normalize-pathname right-trim-separators {
normalize-path right-trim-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
@ -218,14 +249,14 @@ HOOK: delete-file io-backend ( path -- )
HOOK: delete-directory io-backend ( path -- )
: (delete-tree) ( path dir? -- )
[
dup directory* [ (delete-tree) ] assoc-each
delete-directory
] [ delete-file ] if ;
: delete-tree ( path -- )
dup directory? (delete-tree) ;
dup link-info type>> +directory+ = [
dup directory over [
[ first delete-tree ] each
] with-directory delete-directory
] [
delete-file
] if ;
: to-directory over file-name append-path ;
@ -258,13 +289,17 @@ M: object copy-file
DEFER: copy-tree-into
: copy-tree ( from to -- )
over directory? [
>r dup directory swap r> [
>r swap first append-path r> copy-tree-into
] 2curry each
] [
copy-file
] if ;
normalize-path
over link-info type>>
{
{ +symbolic-link+ [ copy-link ] }
{ +directory+ [
>r dup directory r> rot [
[ >r first r> copy-tree-into ] curry each
] with-directory
] }
[ drop copy-file ]
} case ;
: copy-tree-into ( from to -- )
to-directory copy-tree ;
@ -273,9 +308,6 @@ DEFER: copy-tree-into
[ copy-tree-into ] curry each ;
! Special paths
: resource-path ( path -- newpath )
"resource-path" get [ image parent-directory ] unless*
prepend-path ;
: temp-directory ( -- path )
"temp" resource-path dup make-directories ;
@ -283,14 +315,6 @@ DEFER: copy-tree-into
: temp-file ( name -- path )
temp-directory prepend-path ;
M: object normalize-pathname ( path -- path' )
"resource:" ?head [
left-trim-separators resource-path
normalize-pathname
] [
current-directory get prepend-path
] if ;
! Pathname presentations
TUPLE: pathname string ;
@ -301,7 +325,7 @@ M: pathname <=> [ pathname-string ] compare ;
! Home directory
: home ( -- dir )
{
{ [ winnt? ] [ "USERPROFILE" os-env ] }
{ [ wince? ] [ "" resource-path ] }
{ [ unix? ] [ "HOME" os-env ] }
{ [ os winnt? ] [ "USERPROFILE" os-env ] }
{ [ os wince? ] [ "" resource-path ] }
{ [ os unix? ] [ "HOME" os-env ] }
} cond ;

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

@ -7,6 +7,8 @@ IN: kernel
ARTICLE: "shuffle-words" "Shuffle words"
"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
$nl
"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
$nl
"Removing stack elements:"
{ $subsection drop }
{ $subsection 2drop }
@ -39,9 +41,28 @@ $nl
{ $code
": foo ( m ? n -- m+n/n )"
" >r [ r> + ] [ drop r> ] if ; ! This is OK"
}
"An alternative to using " { $link >r } " and " { $link r> } " is the following:"
{ $subsection dip } ;
} ;
ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
$nl
"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
{ $code
": keep [ ] bi ;"
": 2keep [ ] 2bi ;"
": 3keep [ ] 3bi ;"
""
": dup [ ] [ ] bi ;"
": 2dup [ ] [ ] 2bi ;"
": 3dup [ ] [ ] 3bi ;"
""
": tuck [ nip ] [ ] 2bi ;"
": swap [ nip ] [ drop ] 2bi ;"
""
": over [ ] [ drop ] 2bi ;"
": pick [ ] [ 2drop ] 3bi ;"
": 2over [ ] [ drop ] 3bi ;"
} ;
ARTICLE: "cleave-combinators" "Cleave combinators"
"The cleave combinators apply multiple quotations to a single value."
@ -49,9 +70,11 @@ $nl
"Two quotations:"
{ $subsection bi }
{ $subsection 2bi }
{ $subsection 3bi }
"Three quotations:"
{ $subsection tri }
{ $subsection 2tri }
{ $subsection 3tri }
"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
{ $code
"! First alternative; uses keep"
@ -66,13 +89,38 @@ $nl
"The latter is more aesthetically pleasing than the former."
$nl
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
{ $subsection "cleave-shuffle-equivalence" } ;
ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
$nl
"From the Merriam-Webster Dictionary: "
$nl
{ $strong "cleave" }
{ $list
{ $emphasis "To divide by or as if by a cutting blow" }
{ $emphasis "To separate into distinct parts and especially into groups having divergent views" }
"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
{ $code
": dip [ ] bi* ;"
""
": slip [ call ] [ ] bi* ;"
": 2slip [ call ] [ ] [ ] tri* ;"
""
": nip [ drop ] [ ] bi* ;"
": 2nip [ drop ] [ drop ] [ ] tri* ;"
""
": rot"
" [ [ drop ] [ ] [ drop ] tri* ]"
" [ [ drop ] [ drop ] [ ] tri* ]"
" [ [ ] [ drop ] [ drop ] tri* ]"
" 3tri ;"
""
": -rot"
" [ [ drop ] [ drop ] [ ] tri* ]"
" [ [ ] [ drop ] [ drop ] tri* ]"
" [ [ drop ] [ ] [ drop ] tri* ]"
" 3tri ;"
""
": spin"
" [ [ drop ] [ drop ] [ ] tri* ]"
" [ [ drop ] [ ] [ drop ] tri* ]"
" [ [ ] [ drop ] [ drop ] tri* ]"
" 3tri ;"
} ;
ARTICLE: "spread-combinators" "Spread combinators"
@ -96,7 +144,8 @@ $nl
}
$nl
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." ;
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
{ $subsection "spread-shuffle-equivalence" } ;
ARTICLE: "apply-combinators" "Apply combinators"
"The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application."
@ -201,8 +250,9 @@ $nl
{ $subsection eq? }
"Value comparison:"
{ $subsection = }
"Generic words for custom value comparison methods:"
"Custom value comparison methods:"
{ $subsection equal? }
{ $subsection identity-tuple }
"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
{ $subsection <=> }
{ $subsection compare }
@ -328,10 +378,13 @@ HELP: equal?
}
$nl
"If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word."
}
} ;
HELP: identity-tuple
{ $class-description "A class defining an " { $link equal? } " method which always returns f." }
{ $examples
"To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
{ $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" }
"To define a tuple class such that two instances are only equal if they are both the same instance, inherit from the " { $link identity-tuple } " class. This class defines a method on " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
{ $code "TUPLE: foo < identity-tuple ;" }
"By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:"
{ $unchecked-example "T{ foo } dup = ." "t" }
{ $unchecked-example "T{ foo } dup clone = ." "f" }
@ -364,12 +417,6 @@ HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
HELP: type ( object -- n )
{ $values { "object" object } { "n" "a type number" } }
{ $description "Outputs an object's type number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
{ type tag type>class } related-words
HELP: ? ( ? true false -- true/false )
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
@ -496,7 +543,7 @@ HELP: 2bi
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- z )" } ", then the following two lines are equivalent:"
{ $code
"[ p ] [ q ] 2bi"
"2dup p swap q"
"2dup p -rot q"
}
"In general, the following two lines are equivalent:"
{ $code
@ -505,6 +552,27 @@ HELP: 2bi
}
} ;
HELP: 3bi
{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." }
{ $examples
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
{ $code
"[ p ] [ q ] 3bi"
"3dup p q"
}
"If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- w )" } ", then the following two lines are equivalent:"
{ $code
"[ p ] [ q ] 3bi"
"3dup p -roll q"
}
"In general, the following two lines are equivalent:"
{ $code
"[ p ] [ q ] 3bi"
"[ p ] 3keep q"
}
} ;
HELP: tri
{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "x" } "." }
@ -542,6 +610,22 @@ HELP: 2tri
}
} ;
HELP: 3tri
{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values, and finally applies " { $snippet "r" } " to the three input values." }
{ $examples
"If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
{ $code
"[ p ] [ q ] [ r ] 3tri"
"3dup p 3dup q r"
}
"In general, the following two lines are equivalent:"
{ $code
"[ p ] [ q ] [ r ] 3tri"
"[ p ] 3keep [ q ] 3keep r"
}
} ;
HELP: bi*
{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } }
@ -585,6 +669,11 @@ HELP: bi@
"[ p ] bi@"
">r p r> p"
}
"The following two lines are also equivalent:"
{ $code
"[ p ] bi@"
"[ p ] [ p ] bi*"
}
} ;
HELP: 2bi@
@ -596,6 +685,11 @@ HELP: 2bi@
"[ p ] 2bi@"
">r >r p r> r> p"
}
"The following two lines are also equivalent:"
{ $code
"[ p ] 2bi@"
"[ p ] [ p ] 2bi*"
}
} ;
HELP: tri@
@ -607,6 +701,11 @@ HELP: tri@
"[ p ] tri@"
">r >r p r> p r> p"
}
"The following two lines are also equivalent:"
{ $code
"[ p ] tri@"
"[ p ] [ p ] [ p ] tri*"
}
} ;
HELP: if ( cond true false -- )
@ -705,19 +804,6 @@ HELP: null
"The canonical empty class with no instances."
} ;
HELP: general-t
{ $class-description
"The class of all objects not equal to " { $link f } "."
}
{ $examples
"Here is an implementation of " { $link if } " using generic words:"
{ $code
"GENERIC# my-if 2 ( ? true false -- )"
"M: f my-if 2nip call ;"
"M: general-t my-if drop nip call ;"
}
} ;
HELP: most
{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
{ $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;

52
core/kernel/kernel.factor
View File

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

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

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

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

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

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

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

21
core/mirrors/mirrors.factor
View File

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

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

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

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

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

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

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

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

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

5
core/optimizer/specializers/specializers.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces sequences vectors words strings layouts combinators
sequences.private classes generic.standard assocs ;
sequences.private classes generic.standard
generic.standard.engines assocs ;
IN: optimizer.specializers
: (make-specializer) ( class picker -- quot )
@ -32,7 +33,7 @@ IN: optimizer.specializers
: method-declaration ( method -- quot )
dup "method-generic" word-prop dispatch# object <array>
swap "method-class" word-prop add* ;
swap "method-class" word-prop prefix ;
: specialize-method ( quot method -- quot' )
method-declaration [ declare ] curry prepend ;

43
core/parser/parser.factor
View File

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

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

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

5
core/prettyprint/prettyprint.factor
View File

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

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

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

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

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

17
core/sequences/sequences.factor
View File

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

8
core/slots/slots.factor
View File

@ -14,7 +14,7 @@ C: <slot-spec> slot-spec
>r create-method r> define ;
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;
rot >fixnum prefix define-typecheck ;
: reader-quot ( decl -- quot )
[
@ -23,9 +23,6 @@ C: <slot-spec> slot-spec
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;
: create-accessor ( name effect -- word )
>r "accessors" create dup r>
"declared-effect" set-word-prop ;
@ -82,3 +79,6 @@ C: <slot-spec> slot-spec
dup slot-spec-offset swap slot-spec-name
define-slot-methods
] with each ;
: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;

2
core/splitting/splitting.factor
View File

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

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

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

17
core/syntax/syntax.factor
View File

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

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

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

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

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

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