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

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

db4
Joe Groff 2008-12-03 09:51:47 -08:00
parent 5214923a35 4c6af1cc9f
commit d2599b3633
1385 changed files with 22264 additions and 10688 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -20,3 +20,4 @@ temp
logs
work
build-support/wordsize
*.bak

2
Makefile
View File

@ -161,7 +161,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
clean:
rm -f vm/*.o
rm -f factor*.dll libfactor*.*
rm -f factor*.dll libfactor.{a,so,dylib}
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o

5
README.txt
View File

@ -43,13 +43,10 @@ Compilation will yield an executable named 'factor' on Unix,
For X11 support, you need recent development libraries for libc,
Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
(like Ubuntu), you can use the line
(like Ubuntu), you can use the following line to grab everything:
sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
to grab everything (if you're on a non-debian-derived distro please tell
us what the equivalent command is on there and it can be added).
* Bootstrapping the Factor image
Once you have compiled the Factor runtime, you must bootstrap the Factor

2
basis/alarms/alarms-docs.factor
View File

@ -5,7 +5,7 @@ HELP: alarm
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
HELP: add-alarm
{ $values { "quot" quotation } { "time" timestamp } { "frequency" "a " { $link duration } " or " { $link f } } { "alarm" alarm } }
{ $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } }
{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
HELP: later

2
basis/alarms/alarms.factor
View File

@ -35,7 +35,7 @@ ERROR: bad-alarm-frequency frequency ;
[ time>> ] dip before=? ;
: reschedule-alarm ( alarm -- )
dup [ swap interval>> time+ ] change-time register-alarm ;
dup [ swap interval>> time+ now max ] change-time register-alarm ;
: call-alarm ( alarm -- )
[ entry>> box> drop ]

2
basis/alias/alias-docs.factor
View File

@ -16,7 +16,7 @@ HELP: ALIAS:
}
} ;
ARTICLE: "alias" "Alias"
ARTICLE: "alias" "Word aliasing"
"The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl
"Make a new word that aliases another word:"
{ $subsection define-alias }

64
basis/alien/arrays/arrays-docs.factor
View File

@ -1,69 +1,7 @@
IN: alien.arrays
USING: help.syntax help.markup byte-arrays alien.c-types ;
ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
"Each primitive C type has a pair of words, " { $snippet ">" { $emphasis "type" } "-array" } " and " { $snippet { $emphasis "type" } "-array>" } ", for converting an array of Factor objects to and from a " { $link byte-array } " of C values. This set of words consists of:"
{ $subsection >c-bool-array }
{ $subsection >c-char-array }
{ $subsection >c-double-array }
{ $subsection >c-float-array }
{ $subsection >c-int-array }
{ $subsection >c-long-array }
{ $subsection >c-longlong-array }
{ $subsection >c-short-array }
{ $subsection >c-uchar-array }
{ $subsection >c-uint-array }
{ $subsection >c-ulong-array }
{ $subsection >c-ulonglong-array }
{ $subsection >c-ushort-array }
{ $subsection >c-void*-array }
{ $subsection c-bool-array> }
{ $subsection c-char-array> }
{ $subsection c-double-array> }
{ $subsection c-float-array> }
{ $subsection c-int-array> }
{ $subsection c-long-array> }
{ $subsection c-longlong-array> }
{ $subsection c-short-array> }
{ $subsection c-uchar-array> }
{ $subsection c-uint-array> }
{ $subsection c-ulong-array> }
{ $subsection c-ulonglong-array> }
{ $subsection c-ushort-array> }
{ $subsection c-void*-array> } ;
ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
"Each C type has a pair of words, " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } ", for reading and writing values of this type stored in an array. This set of words includes but is not limited to:"
{ $subsection char-nth }
{ $subsection set-char-nth }
{ $subsection uchar-nth }
{ $subsection set-uchar-nth }
{ $subsection short-nth }
{ $subsection set-short-nth }
{ $subsection ushort-nth }
{ $subsection set-ushort-nth }
{ $subsection int-nth }
{ $subsection set-int-nth }
{ $subsection uint-nth }
{ $subsection set-uint-nth }
{ $subsection long-nth }
{ $subsection set-long-nth }
{ $subsection ulong-nth }
{ $subsection set-ulong-nth }
{ $subsection longlong-nth }
{ $subsection set-longlong-nth }
{ $subsection ulonglong-nth }
{ $subsection set-ulonglong-nth }
{ $subsection float-nth }
{ $subsection set-float-nth }
{ $subsection double-nth }
{ $subsection set-double-nth }
{ $subsection void*-nth }
{ $subsection set-void*-nth } ;
ARTICLE: "c-arrays" "C arrays"
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
$nl
"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
{ $subsection "c-arrays-factor" }
{ $subsection "c-arrays-get/set" } ;
"C type specifiers for array types are documented in " { $link "c-types-specs" } "." ;

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

@ -8,6 +8,8 @@ UNION: value-type array struct-type ;
M: array c-type ;
M: array c-type-class drop object ;
M: array heap-size unclip heap-size [ * ] reduce ;
M: array c-type-align first c-type-align ;

22
basis/alien/c-types/c-types-docs.factor
View File

@ -39,12 +39,12 @@ HELP: byte-length
{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
HELP: c-getter
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } }
{ $values { "name" string } { "quot" { $quotation "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: c-setter
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( obj c-ptr n -- )" } } }
{ $values { "name" string } { "quot" { $quotation "( obj c-ptr n -- )" } } }
{ $description "Outputs a quotation which writes values of this C type to a C structure." }
{ $errors "Throws an error if the type does not exist." } ;
@ -89,16 +89,6 @@ HELP: malloc-byte-array
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
HELP: define-nth
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
HELP: define-set-nth
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
{ $description "Defines a word " { $snippet "set-" { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( value n c-ptr -- )" } " for writing the value with C type " { $snippet "name" } " to an alien pointer, displaced by a multiple of the C type's size." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
HELP: box-parameter
{ $values { "n" integer } { "ctype" string } }
{ $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }
@ -115,12 +105,12 @@ HELP: unbox-return
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
HELP: define-deref
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
{ $values { "name" "a word name" } }
{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
HELP: define-out
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
{ $values { "name" "a word name" } }
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
@ -230,9 +220,7 @@ $nl
"You can copy a range of bytes from memory into a byte array:"
{ $subsection memory>byte-array }
"You can copy a byte array to memory unsafely:"
{ $subsection byte-array>memory }
"A wrapper for temporarily allocating a block of memory:"
{ $subsection with-malloc } ;
{ $subsection byte-array>memory } ;
ARTICLE: "c-data" "Passing data between Factor and C"
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."

4
basis/alien/c-types/c-types-tests.factor
View File

@ -55,4 +55,6 @@ TYPEDEF: uchar* MyLPBYTE
0 B{ 1 2 3 4 } <displaced-alien> <void*>
] must-fail
[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test
os windows? cpu x86.64? and [
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
] when

135
basis/alien/c-types/c-types.factor
View File

@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
accessors combinators effects continuations ;
accessors combinators effects continuations fry ;
IN: alien.c-types
DEFER: <int>
@ -13,13 +13,15 @@ DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type
class
boxer boxer-quot unboxer unboxer-quot
getter setter
reg-class size align stack-align? ;
: new-c-type ( class -- type )
new
int-regs >>reg-class ;
int-regs >>reg-class
object >>class ; inline
: <c-type> ( -- type )
\ c-type new-c-type ;
@ -50,7 +52,7 @@ GENERIC: c-type ( name -- type ) foldable
: parse-array-type ( name -- array )
"[" split unclip
>r [ "]" ?tail drop string>number ] map r> prefix ;
[ [ "]" ?tail drop string>number ] map ] dip prefix ;
M: string c-type ( name -- type )
CHAR: ] over member? [
@ -63,6 +65,12 @@ M: string c-type ( name -- type )
] ?if
] if ;
GENERIC: c-type-class ( name -- class )
M: c-type c-type-class class>> ;
M: string c-type-class c-type c-type-class ;
GENERIC: c-type-boxer ( name -- boxer )
M: c-type c-type-boxer boxer>> ;
@ -164,7 +172,7 @@ GENERIC: stack-size ( type -- size ) foldable
M: string stack-size c-type stack-size ;
M: c-type stack-size size>> ;
M: c-type stack-size size>> cell align ;
GENERIC: byte-length ( seq -- n ) flushable
@ -172,12 +180,12 @@ M: byte-array byte-length length ;
: c-getter ( name -- quot )
c-type-getter [
[ "Cannot read struct fields with type" throw ]
[ "Cannot read struct fields with this type" throw ]
] unless* ;
: c-setter ( name -- quot )
c-type-setter [
[ "Cannot write struct fields with type" throw ]
[ "Cannot write struct fields with this type" throw ]
] unless* ;
: <c-array> ( n type -- array )
@ -193,36 +201,21 @@ M: byte-array byte-length length ;
1 swap malloc-array ; inline
: malloc-byte-array ( byte-array -- alien )
dup length dup malloc [ -rot memcpy ] keep ;
dup length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
dup <byte-array> [ -rot memcpy ] keep ;
[ nip <byte-array> dup ] 2keep memcpy ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;
: (define-nth) ( word type quot -- )
: array-accessor ( type quot -- def )
[
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
] [ ] make define-inline ;
: nth-word ( name vocab -- word )
>r "-nth" append r> create ;
: define-nth ( name vocab -- )
dupd nth-word swap dup c-getter (define-nth) ;
: set-nth-word ( name vocab -- word )
>r "set-" swap "-nth" 3append r> create ;
: define-set-nth ( name vocab -- )
dupd set-nth-word swap dup c-setter (define-nth) ;
] [ ] make ;
: typedef ( old new -- ) c-types get set-at ;
: define-c-type ( type name vocab -- )
>r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- type )
@ -240,62 +233,34 @@ M: long-long-type box-parameter ( n type -- )
M: long-long-type box-return ( type -- )
f swap box-parameter ;
: define-deref ( name vocab -- )
>r dup CHAR: * prefix r> create
swap c-getter 0 prefix define-inline ;
: define-deref ( name -- )
[ CHAR: * prefix "alien.c-types" create ]
[ c-getter 0 prefix ] bi
define-inline ;
: define-out ( name vocab -- )
over [ <c-object> tuck 0 ] over c-setter append swap
>r >r constructor-word r> r> prefix define-inline ;
: define-out ( name -- )
[ "alien.c-types" constructor-word ]
[ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ]
bi define-inline ;
: c-bool> ( int -- ? )
zero? not ;
: >c-array ( seq type word -- byte-array )
[ [ dup length ] dip <c-array> ] dip
[ [ execute ] 2curry each-index ] 2keep drop ; inline
: >c-array-quot ( type vocab -- quot )
dupd set-nth-word [ >c-array ] 2curry ;
: to-array-word ( name vocab -- word )
>r ">c-" swap "-array" 3append r> create ;
: define-to-array ( type vocab -- )
[ to-array-word ] 2keep >c-array-quot
(( array -- byte-array )) define-declared ;
: c-array>quot ( type vocab -- quot )
[
\ swap ,
nth-word 1quotation ,
[ curry map ] %
] [ ] make ;
: from-array-word ( name vocab -- word )
>r "c-" swap "-array>" 3append r> create ;
: define-from-array ( type vocab -- )
[ from-array-word ] 2keep c-array>quot
(( c-ptr n -- array )) define-declared ;
: define-primitive-type ( type name -- )
"alien.c-types"
{
[ define-c-type ]
[ define-deref ]
[ define-to-array ]
[ define-from-array ]
[ define-out ]
} 2cleave ;
[ typedef ]
[ define-deref ]
[ define-out ]
tri ;
: expand-constants ( c-type -- c-type' )
dup array? [
unclip >r [
dup word? [
def>> { } swap with-datastack first
] when
] map r> prefix
unclip [
[
dup word? [
def>> { } swap with-datastack first
] when
] map
] dip prefix
] when ;
: malloc-file-contents ( path -- alien len )
@ -304,8 +269,20 @@ M: long-long-type box-return ( type -- )
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
: primitive-types
{
"char" "uchar"
"short" "ushort"
"int" "uint"
"long" "ulong"
"longlong" "ulonglong"
"float" "double"
"void*" "bool"
} ;
[
<c-type>
c-ptr >>class
[ alien-cell ] >>getter
[ set-alien-cell ] >>setter
bootstrap-cell >>size
@ -315,6 +292,7 @@ M: long-long-type box-return ( type -- )
"void*" define-primitive-type
<long-long-type>
integer >>class
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
@ -324,6 +302,7 @@ M: long-long-type box-return ( type -- )
"longlong" define-primitive-type
<long-long-type>
integer >>class
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
@ -333,6 +312,7 @@ M: long-long-type box-return ( type -- )
"ulonglong" define-primitive-type
<c-type>
integer >>class
[ alien-signed-cell ] >>getter
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
@ -342,6 +322,7 @@ M: long-long-type box-return ( type -- )
"long" define-primitive-type
<c-type>
integer >>class
[ alien-unsigned-cell ] >>getter
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
@ -351,6 +332,7 @@ M: long-long-type box-return ( type -- )
"ulong" define-primitive-type
<c-type>
integer >>class
[ alien-signed-4 ] >>getter
[ set-alien-signed-4 ] >>setter
4 >>size
@ -360,6 +342,7 @@ M: long-long-type box-return ( type -- )
"int" define-primitive-type
<c-type>
integer >>class
[ alien-unsigned-4 ] >>getter
[ set-alien-unsigned-4 ] >>setter
4 >>size
@ -369,6 +352,7 @@ M: long-long-type box-return ( type -- )
"uint" define-primitive-type
<c-type>
fixnum >>class
[ alien-signed-2 ] >>getter
[ set-alien-signed-2 ] >>setter
2 >>size
@ -378,6 +362,7 @@ M: long-long-type box-return ( type -- )
"short" define-primitive-type
<c-type>
fixnum >>class
[ alien-unsigned-2 ] >>getter
[ set-alien-unsigned-2 ] >>setter
2 >>size
@ -387,6 +372,7 @@ M: long-long-type box-return ( type -- )
"ushort" define-primitive-type
<c-type>
fixnum >>class
[ alien-signed-1 ] >>getter
[ set-alien-signed-1 ] >>setter
1 >>size
@ -396,6 +382,7 @@ M: long-long-type box-return ( type -- )
"char" define-primitive-type
<c-type>
fixnum >>class
[ alien-unsigned-1 ] >>getter
[ set-alien-unsigned-1 ] >>setter
1 >>size
@ -414,6 +401,7 @@ M: long-long-type box-return ( type -- )
"bool" define-primitive-type
<c-type>
float >>class
[ alien-float ] >>getter
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
@ -425,6 +413,7 @@ M: long-long-type box-return ( type -- )
"float" define-primitive-type
<c-type>
float >>class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
@ -436,6 +425,6 @@ M: long-long-type box-return ( type -- )
"double" define-primitive-type
"long" "ptrdiff_t" typedef
"long" "intptr_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit

19
basis/alien/parser/parser.factor Normal file
View File

@ -0,0 +1,19 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs effects grouping kernel
parser sequences splitting words fry locals ;
IN: alien.parser
: parse-arglist ( parameters return -- types effect )
[ 2 group unzip [ "," ?tail drop ] map ]
[ [ { } ] [ 1array ] if-void ]
bi* <effect> ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
:: define-function ( return library function parameters -- )
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip
define-declared ;

11
basis/alien/strings/strings.factor
View File

@ -3,13 +3,13 @@
USING: arrays sequences kernel accessors math alien.accessors
alien.c-types byte-arrays words io io.encodings
io.streams.byte-array io.streams.memory io.encodings.utf8
io.encodings.utf16 system alien strings cpu.architecture ;
io.encodings.utf16 system alien strings cpu.architecture fry ;
IN: alien.strings
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
M: c-ptr alien>string
>r <memory-stream> r> <decoder>
[ <memory-stream> ] [ <decoder> ] bi*
"\0" swap stream-read-until drop ;
M: f alien>string
@ -40,6 +40,9 @@ PREDICATE: string-type < pair
M: string-type c-type ;
M: string-type c-type-class
drop object ;
M: string-type heap-size
drop "void*" heap-size ;
@ -74,10 +77,10 @@ M: string-type c-type-unboxer
drop "void*" c-type-unboxer ;
M: string-type c-type-boxer-quot
second [ alien>string ] curry [ ] like ;
second '[ _ alien>string ] ;
M: string-type c-type-unboxer-quot
second [ string>alien ] curry [ ] like ;
second '[ _ string>alien ] ;
M: string-type c-type-getter
drop [ alien-cell ] ;

18
basis/alien/structs/fields/fields.factor
View File

@ -29,10 +29,10 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
writer>> swap "writing" set-word-prop ;
: reader-word ( class name vocab -- word )
>r >r "-" r> 3append r> create ;
[ "-" swap 3append ] dip create ;
: writer-word ( class name vocab -- word )
>r [ swap "set-" % % "-" % % ] "" make r> create ;
[ [ swap "set-" % % "-" % % ] "" make ] dip create ;
: <field-spec> ( struct-name vocab type field-name -- spec )
field-spec new
@ -52,25 +52,21 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
[ (>>offset) ] [ type>> heap-size + ] 2bi
] reduce ;
: define-struct-slot-word ( spec word quot -- )
rot offset>> prefix define-inline ;
: define-struct-slot-word ( word quot spec -- )
offset>> prefix define-inline ;
: define-getter ( type spec -- )
[ set-reader-props ] keep
[ ]
[ reader>> ]
[
type>>
[ c-getter ] [ c-type-boxer-quot ] bi append
] tri
define-struct-slot-word ;
]
[ ] tri define-struct-slot-word ;
: define-setter ( type spec -- )
[ set-writer-props ] keep
[ ]
[ writer>> ]
[ type>> c-setter ] tri
define-struct-slot-word ;
[ writer>> ] [ type>> c-setter ] [ ] tri define-struct-slot-word ;
: define-field ( type spec -- )
[ define-getter ] [ define-setter ] 2bi ;

2
basis/alien/structs/structs-tests.factor
View File

@ -38,7 +38,7 @@ C-UNION: barx
[ 120 ] [ "barx" heap-size ] unit-test
"help" vocab [
"help" "help" lookup "help" set
"print-topic" "help" lookup "help" set
[ ] [ \ foox-x "help" get execute ] unit-test
[ ] [ \ set-foox-x "help" get execute ] unit-test
] when

51
basis/alien/structs/structs.factor
View File

@ -1,58 +1,63 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc
math namespaces parser sequences strings words libc fry
alien.c-types alien.structs.fields cpu.architecture ;
IN: alien.structs
: if-value-structs? ( ctype true false -- )
value-structs?
[ drop call ] [ >r 2drop "void*" r> call ] if ; inline
TUPLE: struct-type size align fields ;
M: struct-type heap-size size>> ;
M: struct-type c-type-class drop object ;
M: struct-type c-type-align align>> ;
M: struct-type c-type-stack-align? drop f ;
M: struct-type unbox-parameter
[ %unbox-struct ] [ unbox-parameter ] if-value-structs? ;
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
M: struct-type unbox-return
f swap %unbox-struct ;
M: struct-type unbox-parameter
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
M: struct-type box-parameter
[ %box-struct ] [ box-parameter ] if-value-structs? ;
[ %box-large-struct ] [ box-parameter ] if-value-struct ;
: if-small-struct ( c-type true false -- ? )
[ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline
M: struct-type unbox-return
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
M: struct-type box-return
f swap %box-struct ;
[ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
M: struct-type stack-size
[ heap-size ] [ stack-size ] if-value-structs? ;
[ heap-size ] [ stack-size ] if-value-struct ;
: c-struct? ( type -- ? ) (c-type) struct-type? ;
: (define-struct) ( name vocab size align fields -- )
>r [ align ] keep r>
: (define-struct) ( name size align fields -- )
[ [ align ] keep ] dip
struct-type boa
-rot define-c-type ;
swap typedef ;
: define-struct-early ( name vocab fields -- fields )
-rot [ rot first2 <field-spec> ] 2curry map ;
: make-fields ( name vocab fields -- fields )
[ first2 <field-spec> ] with with map ;
: compute-struct-align ( types -- n )
[ c-type-align ] map supremum ;
: define-struct ( name vocab fields -- )
pick >r
[ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep
[ (define-struct) ] keep
r> [ swap define-field ] curry each ;
[
[ 2drop ] [ make-fields ] 3bi
[ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep
[ (define-struct) ] keep
] [ 2drop '[ _ swap define-field ] ] 3bi each ;
: define-union ( name vocab members -- )
: define-union ( name members -- )
[ expand-constants ] map
[ [ heap-size ] map supremum ] keep
compute-struct-align f (define-struct) ;

10
basis/alien/syntax/syntax-docs.factor
View File

@ -1,5 +1,5 @@
IN: alien.syntax
USING: alien alien.c-types alien.structs alien.syntax.private
USING: alien alien.c-types alien.parser alien.structs
help.markup help.syntax ;
HELP: DLL"
@ -54,12 +54,6 @@ HELP: TYPEDEF:
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: TYPEDEF-IF:
{ $syntax "TYPEDEF-IF: word old new" }
{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } }
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if " { $snippet "word" } " evaluates to a true value." }
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: C-STRUCT:
{ $syntax "C-STRUCT: name pairs... ;" }
{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
@ -88,7 +82,7 @@ HELP: typedef
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
{ $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
{ POSTPONE: TYPEDEF-IF: POSTPONE: TYPEDEF: typedef } related-words
{ POSTPONE: TYPEDEF: typedef } related-words
HELP: c-struct?
{ $values { "type" "a string" } { "?" "a boolean" } }

40
basis/alien/syntax/syntax.factor
View File

@ -4,35 +4,9 @@ USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects prettyprint prettyprint.sections prettyprint.backend
assocs combinators lexer strings.parser ;
assocs combinators lexer strings.parser alien.parser ;
IN: alien.syntax
<PRIVATE
: parse-arglist ( return seq -- types effect )
2 group dup keys swap values [ "," ?tail drop ] map
rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
: function-quot ( type lib func types -- quot )
[ alien-invoke ] 2curry 2curry ;
: define-function ( return library function parameters -- )
>r pick r> parse-arglist
pick create-in dup reset-generic
>r >r function-quot r> r>
-rot define-declared ;
PRIVATE>
: indirect-quot ( function-ptr-quot return types abi -- quot )
[ alien-indirect ] 3curry compose ;
: define-indirect ( abi return function-ptr-quot function-name parameters -- )
>r pick r> parse-arglist
rot create-in dup reset-generic
>r >r swapd roll indirect-quot r> r>
-rot define-declared ;
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
: ALIEN: scan string>number <alien> parsed ; parsing
@ -49,22 +23,16 @@ PRIVATE>
: TYPEDEF:
scan scan typedef ; parsing
: TYPEDEF-IF:
scan-word execute scan scan rot [ typedef ] [ 2drop ] if ; parsing
: C-STRUCT:
scan in get
parse-definition
>r 2dup r> define-struct-early
define-struct ; parsing
scan in get parse-definition define-struct ; parsing
: C-UNION:
scan in get parse-definition define-union ; parsing
scan parse-definition define-union ; parsing
: C-ENUM:
";" parse-tokens
dup length
[ >r create-in r> 1quotation define ] 2each ;
[ [ create-in ] dip 1quotation define ] 2each ;
parsing
M: alien pprint*

2
basis/binary-search/binary-search-docs.factor
View File

@ -2,7 +2,7 @@ IN: binary-search
USING: help.markup help.syntax sequences kernel math.order ;
HELP: search
{ $values { "seq" "a sorted sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
{ $values { "seq" "a sorted sequence" } { "quot" { $quotation "( elt -- <=> )" } } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
{ $description "Performs a binary search on a sequence, calling the quotation to decide whether to end the search (" { $link +eq+ } "), search lower (" { $link +lt+ } ") or search higher (" { $link +gt+ } ")."
$nl
"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "."

13
basis/bit-arrays/bit-arrays.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types accessors math alien.accessors kernel
kernel.private locals sequences sequences.private byte-arrays
parser prettyprint.backend ;
parser prettyprint.backend fry ;
IN: bit-arrays
TUPLE: bit-array
@ -24,9 +24,8 @@ TUPLE: bit-array
: bits>bytes 7 + n>byte ; inline
: (set-bits) ( bit-array n -- )
[ [ length bits>cells ] keep ] dip
[ -rot underlying>> set-uint-nth ] 2curry
each ; inline
[ [ length bits>cells ] keep ] dip swap underlying>>
'[ [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
PRIVATE>
@ -84,9 +83,9 @@ M: bit-array byte-length length 7 + -3 shift ;
] if ;
: bit-array>integer ( bit-array -- n )
0 swap underlying>> [ length ] keep [
uchar-nth swap 8 shift bitor
] curry each ;
0 swap underlying>> dup length [
alien-unsigned-1 swap 8 shift bitor
] with each ;
INSTANCE: bit-array sequence

2
basis/bit-vectors/bit-vectors-tests.factor
View File

@ -4,7 +4,7 @@ USING: tools.test bit-vectors vectors sequences kernel math ;
[ 0 ] [ 123 <bit-vector> length ] unit-test
: do-it
1234 swap [ >r even? r> push ] curry each ;
1234 swap [ [ even? ] dip push ] curry each ;
[ t ] [
3 <bit-vector> dup do-it

6
basis/bootstrap/help/help.factor
View File

@ -1,6 +1,6 @@
USING: help help.topics help.syntax help.crossref
help.definitions io io.files kernel namespaces vocabs sequences
parser vocabs.loader ;
parser vocabs.loader vocabs.loader.private accessors assocs ;
IN: bootstrap.help
: load-help ( -- )
@ -10,8 +10,8 @@ IN: bootstrap.help
t load-help? set-global
[ drop ] load-vocab-hook [
vocabs
[ vocab-docs-loaded? not ] filter
dictionary get values
[ docs-loaded?>> not ] filter
[ load-docs ] each
] with-variable ;

4
basis/bootstrap/image/download/download.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.client checksums checksums.openssl splitting assocs
USING: http.client checksums checksums.md5 splitting assocs
kernel io.files bootstrap.image sequences io urls ;
IN: bootstrap.image.download
@ -13,7 +13,7 @@ IN: bootstrap.image.download
: need-new-image? ( image -- ? )
dup exists?
[
[ openssl-md5 checksum-file hex-string ]
[ md5 checksum-file hex-string ]
[ download-checksums at ]
bi = not
] [ drop t ] if ;

55
basis/bootstrap/image/image.factor
View File

@ -72,7 +72,7 @@ SYMBOL: objects
: put-object ( n obj -- ) (objects) set-at ;
: cache-object ( obj quot -- value )
>r (objects) r> [ obj>> ] prepose cache ; inline
[ (objects) ] dip [ obj>> ] prepose cache ; inline
! Constants
@ -97,10 +97,10 @@ SYMBOL: sub-primitives
{ [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
: jit-define ( quot rc rt offset name -- )
>r make-jit r> set ; inline
[ make-jit ] dip set ; inline
: define-sub-primitive ( quot rc rt offset word -- )
>r make-jit r> sub-primitives get set-at ;
[ make-jit ] dip sub-primitives get set-at ;
! The image being constructed; a vector of word-size integers
SYMBOL: image
@ -124,22 +124,29 @@ SYMBOL: jit-primitive-word
SYMBOL: jit-primitive
SYMBOL: jit-word-jump
SYMBOL: jit-word-call
SYMBOL: jit-push-literal
SYMBOL: jit-push-immediate
SYMBOL: jit-if-word
SYMBOL: jit-if-jump
SYMBOL: jit-if-1
SYMBOL: jit-if-2
SYMBOL: jit-dispatch-word
SYMBOL: jit-dispatch
SYMBOL: jit-dip-word
SYMBOL: jit-dip
SYMBOL: jit-2dip-word
SYMBOL: jit-2dip
SYMBOL: jit-3dip-word
SYMBOL: jit-3dip
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-declare-word
SYMBOL: jit-save-stack
! Default definition for undefined words
SYMBOL: undefined-quot
: userenv-offset ( symbol -- n )
{
: userenvs ( -- assoc )
H{
{ bootstrap-boot-quot 20 }
{ bootstrap-global 21 }
{ jit-code-format 22 }
@ -148,9 +155,9 @@ SYMBOL: undefined-quot
{ jit-primitive 25 }
{ jit-word-jump 26 }
{ jit-word-call 27 }
{ jit-push-literal 28 }
{ jit-if-word 29 }
{ jit-if-jump 30 }
{ jit-if-word 28 }
{ jit-if-1 29 }
{ jit-if-2 30 }
{ jit-dispatch-word 31 }
{ jit-dispatch 32 }
{ jit-epilog 33 }
@ -158,8 +165,18 @@ SYMBOL: undefined-quot
{ jit-profiling 35 }
{ jit-push-immediate 36 }
{ jit-declare-word 42 }
{ jit-save-stack 43 }
{ jit-dip-word 44 }
{ jit-dip 45 }
{ jit-2dip-word 46 }
{ jit-2dip 47 }
{ jit-3dip-word 48 }
{ jit-3dip 49 }
{ undefined-quot 60 }
} at header-size + ;
} ; inline
: userenv-offset ( symbol -- n )
userenvs at header-size + ;
: emit ( cell -- ) image get push ;
@ -188,7 +205,7 @@ SYMBOL: undefined-quot
: emit-fixnum ( n -- ) tag-fixnum emit ;
: emit-object ( header tag quot -- addr )
swap here-as >r swap tag-fixnum emit call align-here r> ;
swap here-as [ swap tag-fixnum emit call align-here ] dip ;
inline
! Write an object to the image.
@ -441,6 +458,9 @@ M: quotation '
\ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
\ declare jit-declare-word set
\ dip jit-dip-word set
\ 2dip jit-2dip-word set
\ 3dip jit-3dip-word set
[ undefined ] undefined-quot set
{
jit-code-format
@ -449,16 +469,23 @@ M: quotation '
jit-primitive
jit-word-jump
jit-word-call
jit-push-literal
jit-push-immediate
jit-if-word
jit-if-jump
jit-if-1
jit-if-2
jit-dispatch-word
jit-dispatch
jit-dip-word
jit-dip
jit-2dip-word
jit-2dip
jit-3dip-word
jit-3dip
jit-epilog
jit-return
jit-profiling
jit-declare-word
jit-save-stack
undefined-quot
} [ emit-userenv ] each ;

31
basis/bootstrap/stage2.factor
View File

@ -8,6 +8,8 @@ definitions assocs compiler.errors compiler.units
math.parser generic sets debugger command-line ;
IN: bootstrap.stage2
SYMBOL: core-bootstrap-time
SYMBOL: bootstrap-time
: default-image-name ( -- string )
@ -30,11 +32,15 @@ SYMBOL: bootstrap-time
: count-words ( pred -- )
all-words swap count number>string write ;
: print-report ( time -- )
: print-time ( ms -- )
1000 /i
60 /mod swap
"Bootstrap completed in " write number>string write
" minutes and " write number>string write " seconds." print
number>string write
" minutes and " write number>string write " seconds." print ;
: print-report ( -- )
"Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time
[ compiled>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
@ -46,22 +52,22 @@ SYMBOL: bootstrap-time
[
! We time bootstrap
millis >r
millis
default-image-name "output-image" set-global
"math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global
parse-command-line
(command-line) parse-command-line
"-no-crossref" cli-args member? [ do-crossref ] unless
do-crossref
! Set dll paths
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when
"deploy-vocab" get [
"staging" get "deploy-vocab" get or [
"stage2: deployment mode" print
] [
"listener" require
@ -71,6 +77,8 @@ SYMBOL: bootstrap-time
[
load-components
millis over - core-bootstrap-time set-global
run-bootstrap-init
] with-compiler-errors
:errors
@ -84,15 +92,10 @@ SYMBOL: bootstrap-time
[
boot
do-init-hooks
[
parse-command-line
run-user-init
"run" get run
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover
handle-command-line
] set-boot-quot
millis r> - dup bootstrap-time set-global
millis swap - bootstrap-time set-global
print-report
"output-image" get save-image-and-exit

2
basis/boxes/boxes.factor
View File

@ -23,4 +23,4 @@ ERROR: box-empty box ;
dup occupied>> [ box> t ] [ drop f f ] if ;
: if-box? ( box quot -- )
>r ?box r> [ drop ] if ; inline
[ ?box ] dip [ drop ] if ; inline

62
basis/calendar/calendar-docs.factor
View File

@ -99,6 +99,48 @@ HELP: seconds-per-year
{ $values { "integer" integer } }
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
HELP: biweekly
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of two week periods in a year." } ;
HELP: daily-360
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of days in a 360-day year." } ;
HELP: daily-365
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of days in a 365-day year." } ;
HELP: monthly
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of months in a year." } ;
HELP: semimonthly
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
HELP: weekly
{ $values
{ "x" number }
{ "y" number }
}
{ $description "Divides a number by the number of weeks in a year." } ;
HELP: julian-day-number
{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
@ -365,12 +407,12 @@ HELP: unix-1970
{ $values { "timestamp" timestamp } }
{ $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ;
HELP: millis>timestamp
HELP: micros>timestamp
{ $values { "x" number } { "timestamp" timestamp } }
{ $description "Converts a number of milliseconds into a timestamp value in GMT time." }
{ $description "Converts a number of microseconds into a timestamp value in GMT time." }
{ $examples
{ $example "USING: accessors calendar prettyprint ;"
"1000 millis>timestamp year>> ."
"1000 micros>timestamp year>> ."
"1970"
}
} ;
@ -540,6 +582,8 @@ ARTICLE: "calendar" "Calendar"
{ $subsection "years" }
{ $subsection "months" }
{ $subsection "days" }
"Calculating amounts per period of time:"
{ $subsection "time-period-calculations" }
"Meta-data about the calendar:"
{ $subsection "calendar-facts" }
;
@ -626,6 +670,18 @@ ARTICLE: "calendar-facts" "Calendar facts"
{ $subsection day-of-week }
;
ARTICLE: "time-period-calculations" "Calculations over periods of time"
{ $subsection monthly }
{ $subsection semimonthly }
{ $subsection biweekly }
{ $subsection weekly }
{ $subsection daily-360 }
{ $subsection daily-365 }
{ $subsection biweekly }
{ $subsection biweekly }
{ $subsection biweekly }
;
ARTICLE: "years" "Year operations"
"Leap year predicate:"
{ $subsection leap-year? }

10
basis/calendar/calendar-tests.factor
View File

@ -143,10 +143,10 @@ IN: calendar.tests
[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test
[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test
[ t ] [ now timestamp>micros micros - 1000000 < ] unit-test
[ t ] [ 0 micros>timestamp unix-1970 = ] unit-test
[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
: checktime+ now dup clone [ rot time+ drop ] keep = ;
@ -167,3 +167,5 @@ IN: calendar.tests
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
[ 4+1/6 ] [ 100 semimonthly ] unit-test

42
basis/calendar/calendar.factor
View File

@ -89,6 +89,13 @@ PRIVATE>
: minutes-per-year ( -- ratio ) 5259492/10 ; inline
: seconds-per-year ( -- integer ) 31556952 ; inline
: monthly ( x -- y ) 12 / ; inline
: semimonthly ( x -- y ) 24 / ; inline
: biweekly ( x -- y ) 26 / ; inline
: weekly ( x -- y ) 52 / ; inline
: daily-360 ( x -- y ) 360 / ; inline
: daily-365 ( x -- y ) 365 / ; inline
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
@ -173,7 +180,7 @@ M: real +year ( timestamp n -- timestamp )
12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
M: integer +month ( timestamp n -- timestamp )
[ over month>> + months/years >r >>month r> +year ] unless-zero ;
[ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
M: real +month ( timestamp n -- timestamp )
[ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
@ -181,7 +188,7 @@ M: real +month ( timestamp n -- timestamp )
M: integer +day ( timestamp n -- timestamp )
[
over >date< julian-day-number + julian-day-number>date
>r >r >>year r> >>month r> >>day
[ >>year ] [ >>month ] [ >>day ] tri*
] unless-zero ;
M: real +day ( timestamp n -- timestamp )
@ -191,7 +198,7 @@ M: real +day ( timestamp n -- timestamp )
24 /rem swap ;
M: integer +hour ( timestamp n -- timestamp )
[ over hour>> + hours/days >r >>hour r> +day ] unless-zero ;
[ over hour>> + hours/days [ >>hour ] dip +day ] unless-zero ;
M: real +hour ( timestamp n -- timestamp )
float>whole-part swapd 60 * +minute swap +hour ;
@ -200,7 +207,7 @@ M: real +hour ( timestamp n -- timestamp )
60 /rem swap ;
M: integer +minute ( timestamp n -- timestamp )
[ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ;
[ over minute>> + minutes/hours [ >>minute ] dip +hour ] unless-zero ;
M: real +minute ( timestamp n -- timestamp )
[ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
@ -209,7 +216,7 @@ M: real +minute ( timestamp n -- timestamp )
60 /rem swap >integer ;
M: number +second ( timestamp n -- timestamp )
[ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ;
[ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ;
: (time+)
[ second>> +second ] keep
@ -226,7 +233,7 @@ PRIVATE>
GENERIC# time+ 1 ( time1 time2 -- time3 )
M: timestamp time+
>r clone r> (time+) drop ;
[ clone ] dip (time+) drop ;
M: duration time+
dup timestamp? [
@ -284,7 +291,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
: (time-) ( timestamp timestamp -- n )
[ >gmt ] bi@
[ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
[ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ;
[ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ;
M: timestamp time-
#! Exact calendar-time difference
@ -320,14 +327,20 @@ M: duration time-
1970 1 1 0 0 0 instant <timestamp> ;
: millis>timestamp ( x -- timestamp )
>r unix-1970 r> milliseconds time+ ;
[ unix-1970 ] dip milliseconds time+ ;
: timestamp>millis ( timestamp -- n )
unix-1970 (time-) 1000 * >integer ;
: micros>timestamp ( x -- timestamp )
[ unix-1970 ] dip microseconds time+ ;
: timestamp>micros ( timestamp -- n )
unix-1970 (time-) 1000000 * >integer ;
: gmt ( -- timestamp )
#! GMT time, right now
unix-1970 millis milliseconds time+ ;
unix-1970 micros microseconds time+ ;
: now ( -- timestamp ) gmt >local-time ;
: hence ( duration -- timestamp ) now swap time+ ;
@ -337,10 +350,11 @@ M: duration time-
#! Zeller Congruence
#! http://web.textfiles.com/computers/formulas.txt
#! good for any date since October 15, 1582
>r dup 2 <= [ 12 + >r 1- r> ] when
>r dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + r>
[ 1+ 3 * 5 /i + ] keep 2 * + r>
1+ + 7 mod ;
[
dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
[ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
[ 1+ 3 * 5 /i + ] keep 2 * +
] dip 1+ + 7 mod ;
GENERIC: days-in-year ( obj -- n )
@ -404,7 +418,7 @@ PRIVATE>
: since-1970 ( duration -- timestamp )
unix-1970 time+ >local-time ;
M: timestamp sleep-until timestamp>millis sleep-until ;
M: timestamp sleep-until timestamp>micros sleep-until ;
M: duration sleep hence sleep-until ;

21
basis/calendar/format/format.factor
View File

@ -138,11 +138,11 @@ M: timestamp year. ( timestamp -- )
: read-rfc3339-gmt-offset ( ch -- dt )
dup CHAR: Z = [ drop instant ] [
>r
read-00 hours
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
time+
r> signed-gmt-offset
[
read-00 hours
read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
time+
] dip signed-gmt-offset
] if ;
: read-ymd ( -- y m d )
@ -152,8 +152,9 @@ M: timestamp year. ( timestamp -- )
read-00 ":" expect read-00 ":" expect read-00 ;
: read-rfc3339-seconds ( s -- s' ch )
"+-Z" read-until >r
[ string>number ] [ length 10 swap ^ ] bi / + r> ;
"+-Z" read-until [
[ string>number ] [ length 10 swap ^ ] bi / +
] dip ;
: (rfc3339>timestamp) ( -- timestamp )
read-ymd
@ -181,9 +182,9 @@ ERROR: invalid-timestamp-format ;
: parse-rfc822-gmt-offset ( string -- dt )
dup "GMT" = [ drop instant ] [
unclip >r
2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
r> signed-gmt-offset
unclip [
2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
] dip signed-gmt-offset
] if ;
: (rfc822>timestamp) ( -- timestamp )

2
basis/calendar/model/model.factor
View File

@ -7,7 +7,7 @@ SYMBOL: time
: (time-thread) ( -- )
now time get set-model
1000 sleep (time-thread) ;
1 seconds sleep (time-thread) ;
: time-thread ( -- )
[

1
basis/calendar/windows/tags.txt Normal file → Executable file
View File

@ -1,2 +1 @@
unportable
windows

2
basis/channels/remote/remote.factor
View File

@ -14,7 +14,7 @@ IN: channels.remote
PRIVATE>
: publish ( channel -- id )
256 random-bits dup >r remote-channels set-at r> ;
256 random-bits dup [ remote-channels set-at ] dip ;
: get-channel ( id -- channel )
remote-channels at ;

2
basis/checksums/common/common.factor
View File

@ -18,4 +18,4 @@ SYMBOL: bytes-read
] "" make 64 group ;
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
[ [ get ] bi@ w+ dup ] 2keep [ set ] bi@ ; inline

2
basis/checksums/md5/md5.factor
View File

@ -14,7 +14,7 @@ IN: checksums.md5
SYMBOLS: a b c d old-a old-b old-c old-d ;
: T ( N -- Y )
sin abs 4294967296 * >bignum ; foldable
sin abs 4294967296 * >integer ; foldable
: initialize-md5 ( -- )
0 bytes-read set

2
basis/checksums/openssl/openssl.factor
View File

@ -28,7 +28,7 @@ M: evp-md-context dispose
handle>> EVP_MD_CTX_cleanup drop ;
: with-evp-md-context ( quot -- )
maybe-init-ssl >r <evp-md-context> r> with-disposal ; inline
maybe-init-ssl [ <evp-md-context> ] dip with-disposal ; inline
: digest-named ( name -- md )
dup EVP_get_digestbyname

4
basis/checksums/sha1/sha1.factor
View File

@ -41,9 +41,9 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
: sha1-f ( B C D t -- f_tbcd )
20 /i
{
{ 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
{ 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
{ 1 [ bitxor bitxor ] }
{ 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
{ 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
{ 3 [ bitxor bitxor ] }
} case ;

10
basis/checksums/sha2/sha2.factor
View File

@ -59,7 +59,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
[ 15 - swap nth s0-256 ] 2keep
[ 7 - swap nth ] 2keep
[ 2 - swap nth s1-256 ] 2keep
>r >r + + w+ r> r> swap set-nth ; inline
[ + + w+ ] 2dip swap set-nth ; inline
: prepare-message-schedule ( seq -- w-seq )
word-size get group [ be> ] map block-size get 0 pad-right
@ -71,7 +71,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
[ bitxor bitand ] keep bitxor ;
: maj ( x y z -- x' )
>r [ bitand ] 2keep bitor r> bitand bitor ;
[ [ bitand ] 2keep bitor ] dip bitand bitor ;
: S0-256 ( x -- x' )
[ -2 bitroll-32 ] keep
@ -83,7 +83,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
[ -11 bitroll-32 ] keep
-25 bitroll-32 bitxor bitxor ; inline
: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ; inline
: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
: T1 ( W n -- T1 )
[ swap nth ] keep
@ -105,7 +105,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
d c pick exchange
c b pick exchange
b a pick exchange
>r w+ a r> set-nth ;
[ w+ a ] dip set-nth ;
: process-chunk ( M -- )
H get clone vars set
@ -118,7 +118,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
: preprocess-plaintext ( string big-endian? -- padded-string )
#! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
>r >sbuf r> over [
[ >sbuf ] dip over [
HEX: 80 ,
dup length HEX: 3f bitand
calculate-pad-length 0 <string> %

9
basis/cocoa/application/application.factor
View File

@ -40,12 +40,13 @@ FUNCTION: void NSBeep ( ) ;
dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
: add-observer ( observer selector name object -- )
>r >r >r >r NSNotificationCenter -> defaultCenter
r> r> sel_registerName
r> r> -> addObserver:selector:name:object: ;
[
[ NSNotificationCenter -> defaultCenter ] 2dip
sel_registerName
] 2dip -> addObserver:selector:name:object: ;
: remove-observer ( observer -- )
>r NSNotificationCenter -> defaultCenter r>
[ NSNotificationCenter -> defaultCenter ] dip
-> removeObserver: ;
: finish-launching ( -- ) NSApp -> finishLaunching ;

8
basis/cocoa/dialogs/dialogs.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cocoa cocoa.messages cocoa.classes
cocoa.application sequences splitting core-foundation ;
@ -26,9 +26,9 @@ IN: cocoa.dialogs
[ -> filenames CF>string-array ] [ drop f ] if ;
: split-path ( path -- dir file )
"/" last-split1 [ <NSString> ] bi@ ;
"/" split1-last [ <NSString> ] bi@ ;
: save-panel ( path -- paths )
<NSSavePanel> dup
rot split-path -> runModalForDirectory:file: NSOKButton =
[ <NSSavePanel> dup ] dip
split-path -> runModalForDirectory:file: NSOKButton =
[ -> filename CF>string ] [ drop f ] if ;

27
basis/cocoa/enumeration/enumeration.factor
View File

@ -1,26 +1,31 @@
USING: kernel cocoa cocoa.types alien.c-types locals math sequences
vectors fry libc ;
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cocoa cocoa.types alien.c-types locals math
sequences vectors fry libc destructors
specialized-arrays.direct.alien ;
IN: cocoa.enumeration
: NS-EACH-BUFFER-SIZE 16 ; inline
: (with-enumeration-buffers) ( quot -- )
"NSFastEnumerationState" heap-size swap '[
NS-EACH-BUFFER-SIZE "id" heap-size * [
NS-EACH-BUFFER-SIZE @
] with-malloc
] with-malloc ; inline
: with-enumeration-buffers ( quot -- )
[
[
"NSFastEnumerationState" malloc-object &free
NS-EACH-BUFFER-SIZE "id" heap-size * malloc-object &free
NS-EACH-BUFFER-SIZE
] dip call
] with-destructors ; inline
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
object state stackbuf count -> countByEnumeratingWithState:objects:count:
dup zero? [ drop ] [
dup 0 = [ drop ] [
state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
'[ _ void*-nth quot call ] each
swap <direct-void*-array> quot each
object quot state stackbuf count (NSFastEnumeration-each)
] if ; inline recursive
: NSFastEnumeration-each ( object quot -- )
[ (NSFastEnumeration-each) ] (with-enumeration-buffers) ; inline
[ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline
: NSFastEnumeration-map ( object quot -- vector )
NS-EACH-BUFFER-SIZE <vector>

2
basis/cocoa/messages/messages-docs.factor
View File

@ -31,7 +31,7 @@ HELP: alien>objc-types
{ objc>alien-types alien>objc-types } related-words
HELP: import-objc-class
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( -- )" } } }
{ $values { "name" string } { "quot" { $quotation "( -- )" } } }
{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." } ;
HELP: root-class

38
basis/cocoa/messages/messages.factor
View File

@ -5,7 +5,8 @@ combinators compiler compiler.alien kernel math namespaces make
parser prettyprint prettyprint.sections quotations sequences
strings words cocoa.runtime io macros memoize debugger
io.encodings.ascii effects libc libc.private parser lexer init
core-foundation fry ;
core-foundation fry generalizations
specialized-arrays.direct.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )
@ -27,7 +28,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
: cache-stub ( method function hash -- )
[
over get [ 2drop ] [ over >r sender-stub r> set ] if
over get [ 2drop ] [ over [ sender-stub ] dip set ] if
] bind ;
: cache-stubs ( method -- )
@ -37,7 +38,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
: <super> ( receiver -- super )
"objc-super" <c-object> [
>r dup object_getClass class_getSuperclass r>
[ dup object_getClass class_getSuperclass ] dip
set-objc-super-class
] keep
[ set-objc-super-receiver ] keep ;
@ -62,23 +63,18 @@ objc-methods global [ H{ } assoc-like ] change-at
dup objc-methods get at
[ ] [ "No such method: " prepend throw ] ?if ;
: make-dip ( quot n -- quot' )
dup
\ >r <repetition> >quotation -rot
\ r> <repetition> >quotation 3append ;
MEMO: make-prepare-send ( selector method super? -- quot )
[
[ \ <super> , ] when
swap <selector> , \ selector ,
] [ ] make
swap second length 2 - make-dip ;
swap second length 2 - '[ _ _ ndip ] ;
MACRO: (send) ( selector super? -- quot )
>r dup lookup-method r>
[ dup lookup-method ] dip
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
[ slip execute ] 2curry ;
'[ _ call _ execute ] ;
: send ( receiver args... selector -- return... ) f (send) ; inline
@ -165,14 +161,14 @@ objc>alien-types get [ swap ] assoc-map
assoc-union alien>objc-types set-global
: objc-struct-type ( i string -- ctype )
2dup CHAR: = -rot index-from swap subseq
[ CHAR: = ] 2keep index-from swap subseq
dup c-types get key? [
"Warning: no such C type: " write dup print
drop "void*"
] unless ;
: (parse-objc-type) ( i string -- ctype )
2dup nth >r >r 1+ r> r> {
[ [ 1+ ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
@ -203,8 +199,11 @@ assoc-union alien>objc-types set-global
objc-methods get set-at ;
: each-method-in-class ( class quot -- )
[ 0 <uint> [ class_copyMethodList ] keep *uint over ] dip
'[ _ void*-nth @ ] each (free) ; inline
[ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
over 0 = [ 3drop ] [
[ <direct-void*-array> ] dip
[ each ] [ drop underlying>> (free) ] 2bi
] if ; inline
: register-objc-methods ( class -- )
[ register-objc-method ] each-method-in-class ;
@ -223,22 +222,23 @@ assoc-union alien>objc-types set-global
: class-exists? ( string -- class ) objc_getClass >boolean ;
: unless-defined ( class quot -- )
>r class-exists? r> unless ; inline
[ class-exists? ] dip unless ; inline
: define-objc-class-word ( name quot -- )
[
over , , \ unless-defined , dup , \ objc-class ,
] [ ] make >r "cocoa.classes" create r>
] [ ] make [ "cocoa.classes" create ] dip
(( -- class )) define-declared ;
: import-objc-class ( name quot -- )
2dup unless-defined
dupd define-objc-class-word
[
'[
_
dup
objc-class register-objc-methods
objc-meta-class register-objc-methods
] curry try ;
] try ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;

12
basis/cocoa/pasteboard/pasteboard.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays kernel cocoa.messages
cocoa.classes cocoa.application cocoa core-foundation
sequences ;
USING: alien.accessors arrays kernel cocoa.messages
cocoa.classes cocoa.application cocoa core-foundation sequences
;
IN: cocoa.pasteboard
: NSStringPboardType "NSStringPboardType" ;
@ -20,11 +20,11 @@ IN: cocoa.pasteboard
: set-pasteboard-string ( str pasteboard -- )
NSStringPboardType <NSString>
dup 1array pick set-pasteboard-types
>r swap <NSString> r> -> setString:forType: drop ;
[ swap <NSString> ] dip -> setString:forType: drop ;
: pasteboard-error ( error -- f )
"Pasteboard does not hold a string" <NSString>
0 spin set-void*-nth f ;
0 set-alien-cell f ;
: ?pasteboard-string ( pboard error -- str/f )
over pasteboard-string? [

2
basis/cocoa/subclassing/subclassing.factor
View File

@ -36,7 +36,7 @@ IN: cocoa.subclassing
] map concat ;
: prepare-method ( ret types quot -- type imp )
>r [ encode-types ] 2keep r> [
[ [ encode-types ] 2keep ] dip [
"cdecl" swap 4array % \ alien-callback ,
] [ ] make define-temp ;

21
basis/cocoa/views/views.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays kernel math namespaces make cocoa
cocoa.messages cocoa.classes cocoa.types sequences
continuations ;
USING: specialized-arrays.int arrays kernel math namespaces make
cocoa cocoa.messages cocoa.classes cocoa.types sequences
continuations accessors ;
IN: cocoa.views
: NSOpenGLPFAAllRenderers 1 ;
@ -69,12 +69,12 @@ PRIVATE>
NSOpenGLPFASamples , 8 ,
] when
0 ,
] { } make >c-int-array
] int-array{ } make underlying>>
-> initWithAttributes:
-> autorelease ;
: <GLView> ( class dim -- view )
>r -> alloc 0 0 r> first2 <NSRect> <PixelFormat>
[ -> alloc 0 0 ] dip first2 <NSRect> <PixelFormat>
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
dup 1 -> setPostsFrameChangedNotifications: ;
@ -85,10 +85,11 @@ PRIVATE>
swap NSRect-h >fixnum 2array ;
: mouse-location ( view event -- loc )
over >r
-> locationInWindow f -> convertPoint:fromView:
dup NSPoint-x swap NSPoint-y
r> -> frame NSRect-h swap - 2array ;
[
-> locationInWindow f -> convertPoint:fromView:
[ NSPoint-x ] [ NSPoint-y ] bi
] [ drop -> frame NSRect-h ] 2bi
swap - 2array ;
USE: opengl.gl
USE: alien.syntax

3
basis/cocoa/windows/windows.factor
View File

@ -34,5 +34,6 @@ IN: cocoa.windows
dup 0 -> setReleasedWhenClosed: ;
: window-content-rect ( window -- rect )
NSWindow over -> frame rot -> styleMask
[ NSWindow ] dip
[ -> frame ] [ -> styleMask ] bi
-> contentRectForFrameRect:styleMask: ;

14
basis/combinators/short-circuit/short-circuit-docs.factor
View File

@ -52,17 +52,17 @@ HELP: 3||
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
HELP: n&&-rewrite
HELP: n&&
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quot" quotation } }
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ;
{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
HELP: n||-rewrite
HELP: n||
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quots" "a sequence of quotations" } { "n" integer }
{ "quot" quotation } }
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ;
{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each OR quotation." } ;
ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
@ -77,8 +77,8 @@ ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
{ $subsection 2|| }
{ $subsection 3|| }
"Generalized combinators:"
{ $subsection n&&-rewrite }
{ $subsection n||-rewrite }
{ $subsection n&& }
{ $subsection n|| }
;
ABOUT: "combinators.short-circuit"

56
basis/combinators/short-circuit/short-circuit.factor
View File

@ -1,35 +1,33 @@
USING: kernel combinators quotations arrays sequences assocs
locals generalizations macros fry ;
locals generalizations macros fry ;
IN: combinators.short-circuit
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO:: n&& ( quots n -- quot )
[ f ] quots [| q |
n
[ q '[ drop _ ndup @ dup not ] ]
[ '[ drop _ ndrop f ] ]
bi 2array
] map
n '[ _ nnip ] suffix 1array
[ cond ] 3append ;
:: n&&-rewrite ( quots N -- quot )
quots
[ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
map
[ t ] [ N nnip ] 2array suffix
'[ f _ cond ] ;
MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ;
MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ;
MACRO:: n|| ( quots n -- quot )
[ f ] quots [| q |
n
[ q '[ drop _ ndup @ dup ] ]
[ '[ _ nnip ] ]
bi 2array
] map
n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
[ cond ] 3append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: n||-rewrite ( quots N -- quot )
quots
[ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
map
[ drop N ndrop t ] [ f ] 2array suffix
'[ f _ cond ] ;
MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;
MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ;
MACRO: 3|| ( quots -- quot ) 3 n||-rewrite ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;

8
basis/combinators/short-circuit/smart/smart.factor
View File

@ -1,7 +1,5 @@
USING: kernel sequences math stack-checker effects accessors macros
combinators.short-circuit ;
fry combinators.short-circuit ;
IN: combinators.short-circuit.smart
<PRIVATE
@ -13,6 +11,6 @@ IN: combinators.short-circuit.smart
PRIVATE>
MACRO: && ( quots -- quot ) dup arity n&&-rewrite ;
MACRO: && ( quots -- quot ) dup arity '[ _ _ n&& ] ;
MACRO: || ( quots -- quot ) dup arity n||-rewrite ;
MACRO: || ( quots -- quot ) dup arity '[ _ _ n|| ] ;

93
basis/command-line/command-line-docs.factor
View File

@ -1,13 +1,17 @@
USING: help.markup help.syntax parser vocabs.loader strings ;
USING: help.markup help.syntax parser vocabs.loader strings
command-line.private ;
IN: command-line
HELP: run-bootstrap-init
{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
{ $description "Runs the bootstrap initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-boot-rc" } " on Unix and " { $snippet "factor-boot-rc" } " on Windows." } ;
HELP: run-user-init
{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
{ $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ;
HELP: cli-param
HELP: load-vocab-roots
{ $description "Loads the newline-separated list of additional vocabulary roots from the file named " { $snippet ".factor-roots" } " on Unix and " { $snippet "factor-roots" } " on Windows." } ;
HELP: param
{ $values { "param" string } }
{ $description "Process a command-line switch."
$nl
@ -17,10 +21,13 @@ $nl
$nl
"Otherwise, sets the global variable named by the parameter to " { $link t } "." } ;
HELP: cli-args
HELP: (command-line)
{ $values { "args" "a sequence of strings" } }
{ $description "Outputs the command line parameters which were passed to the Factor VM on startup." } ;
HELP: command-line
{ $var-description "The command line parameters which follow the name of the script on the command line." } ;
HELP: main-vocab-hook
{ $var-description "Global variable holding a quotation which outputs a vocabulary name. UI backends set this so that the UI can automatically start if the prerequisites are met (for example, " { $snippet "$DISPLAY" } " being set on X11)." } ;
@ -35,9 +42,6 @@ HELP: ignore-cli-args?
{ $values { "?" "a boolean" } }
{ $description "On Mac OS X, source files to run are supplied by the Cocoa API, so to avoid running them twice the startup code has to call this word." } ;
HELP: parse-command-line
{ $description "Called on startup to process command line arguments. This sets global variables with " { $link cli-param } ", runs source files, and evaluates the string given by the " { $snippet "-e" } " switch, if there is one." } ;
ARTICLE: "runtime-cli-args" "Command line switches for the VM"
"A handful of command line switches are processed by the VM and not the library. They control low-level features."
{ $table
@ -57,16 +61,19 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"
{ $table
{ { $snippet "-output-image=" { $emphasis "image" } } { "Save the result to " { $snippet "image" } ". The default is " { $snippet "factor.image" } "." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-boot-rc" } " file in the user's home directory." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-include=" { $emphasis "components..." } } "A list of components to include (see below)." }
{ { $snippet "-exclude=" { $emphasis "components..." } } "A list of components to exclude." }
{ { $snippet "-ui-backend=" { $emphasis "backend" } } { "One of " { $snippet "x11" } ", " { $snippet "windows" } ", or " { $snippet "cocoa" } ". The default is platform-specific." } }
}
"Bootstrap can load various optional components:"
{ $table
{ { $snippet "math" } "Rational and complex number support." }
{ { $snippet "threads" } "Thread support." }
{ { $snippet "compiler" } "The compiler." }
{ { $snippet "tools" } "Terminal-based developer tools." }
{ { $snippet "help" } "The help system." }
{ { $snippet "help.handbook" } "The help handbook." }
{ { $snippet "ui" } "The graphical user interface." }
{ { $snippet "ui.tools" } "Graphical developer tools." }
{ { $snippet "io" } "Non-blocking I/O and networking." }
@ -74,9 +81,9 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"By default, all optional components are loaded. To load all optional components except for a given list, use the " { $snippet "-exclude=" } " switch; to only load specified optional components, use the " { $snippet "-include=" } "."
$nl
"For example, to build an image with the compiler but no other components, you could do:"
{ $code "./factor -i=boot.ppc.image -include=compiler" }
{ $code "./factor -i=boot.macosx-ppc.image -include=compiler" }
"To build an image with everything except for the user interface and graphical tools,"
{ $code "./factor -i=boot.ppc.image -exclude=\"ui ui.tools\"" }
{ $code "./factor -i=boot.macosx-ppc.image -exclude=\"ui ui.tools\"" }
"To generate a bootstrap image in the first place, see " { $link "bootstrap.image" } "." ;
ARTICLE: "standard-cli-args" "Command line switches for general usage"
@ -84,20 +91,60 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
{ $table
{ { $snippet "-e=" { $emphasis "code" } } { "This specifies a code snippet to evaluate. If you want Factor to exit immediately after, also specify " { $snippet "-run=none" } "." } }
{ { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-rc" } " file in the user's home directory on startup." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } }
{ { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } }
} ;
ARTICLE: "rc-files" "Running code on startup"
"Unless the " { $snippet "-no-user-init" } " command line switch is specified, The startup routine runs the " { $snippet ".factor-rc" } " file in the user's home directory, if it exists. This file can contain initialization and customization for your development environment."
ARTICLE: "factor-boot-rc" "Bootstrap initialization file"
"The botstrap initialization file is named " { $snippet "factor-boot-rc" } " on Windows and " { $snippet ".factor-boot-rc" } " on Unix. This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts."
$nl
"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:"
{ $subsection run-user-init }
{ $subsection run-bootstrap-init } ;
"A word to run this file from an existing Factor session:"
{ $subsection run-bootstrap-init }
"For example, if you changed " { $snippet ".factor-boot-rc" } " and do not want to bootstrap again, you can just invoke " { $link run-bootstrap-init } " in the listener." ;
ARTICLE: "cli" "Command line usage"
"Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "."
ARTICLE: "factor-rc" "Startup initialization file"
"The startup initialization file is named " { $snippet "factor-rc" } " on Windows and " { $snippet ".factor-rc" } " on Unix. If it exists, it is run every time Factor starts."
$nl
"A word to run this file from an existing Factor session:"
{ $subsection run-user-init } ;
ARTICLE: "factor-roots" "Additional vocabulary roots file"
"The vocabulary roots file is named " { $snippet "factor-roots" } " on Windows and " { $snippet ".factor-roots" } " on Unix. If it exists, it is loaded every time Factor starts. It contains a newline-separated list of " { $link "vocabs.roots" } "."
$nl
"A word to run this file from an existing Factor session:"
{ $subsection load-vocab-roots } ;
ARTICLE: "rc-files" "Running code on startup"
"Factor looks for three optional files in your home directory."
{ $subsection "factor-boot-rc" }
{ $subsection "factor-rc" }
{ $subsection "factor-roots" }
"The " { $snippet "-no-user-init" } " command line switch will inhibit loading running of these files."
$nl
"If you are unsure where the files should be located, evaluate the following code:"
{ $code
"USE: command-line"
"\"factor-rc\" rc-path print"
"\"factor-boot-rc\" rc-path print"
}
"Here is an example " { $snippet ".factor-boot-rc" } " which sets up GVIM editor integration, adds an additional vocabulary root (see " { $link "vocabs.roots" } "), and increases the font size in the UI by setting the DPI (dots-per-inch) variable:"
{ $code
"USING: editors.gvim vocabs.loader ui.freetype namespaces sequences ;"
"\"/opt/local/bin\" \\ gvim-path set-global"
"\"/home/jane/src/\" vocab-roots get push"
"100 dpi set-global"
} ;
ARTICLE: "cli" "Command line arguments"
"Factor command line usage:"
{ $code "factor [system switches...] [script args...]" }
"Zero or more system switches can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in a variable, with no further processing by Factor itself:"
{ $subsection command-line }
"Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:"
{ $code "factor [system switches...] -run=<vocab name>" }
"If no script file or " { $snippet "-run=" } " switch is specified, Factor will start " { $link "listener" } " or " { $link "ui-tools" } ", depending on the operating system."
$nl
"As stated above, arguments in the first part of the command line, before the optional script name, are interpreted by to the Factor system. These arguments all start with a dash (" { $snippet "-" } ")."
$nl
"Switches can take one of the following three forms:"
{ $list
@ -108,9 +155,9 @@ $nl
{ $subsection "runtime-cli-args" }
{ $subsection "bootstrap-cli-args" }
{ $subsection "standard-cli-args" }
"The list of command line arguments can be obtained and inspected directly:"
{ $subsection cli-args }
"There is a way to override the default vocabulary to run on startup:"
"The raw list of command line arguments can also be obtained and inspected directly:"
{ $subsection (command-line) }
"There is a way to override the default vocabulary to run on startup, if no script name or " { $snippet "-run" } " switch is specified:"
{ $subsection main-vocab-hook } ;
ABOUT: "cli"

12
basis/command-line/command-line-tests.factor
View File

@ -1,12 +0,0 @@
USING: namespaces tools.test kernel command-line ;
IN: command-line.tests
[
[ f ] [ "-no-user-init" cli-arg ] unit-test
[ f ] [ "user-init" get ] unit-test
[ f ] [ "-user-init" cli-arg ] unit-test
[ t ] [ "user-init" get ] unit-test
[ "sdl.factor" ] [ "sdl.factor" cli-arg ] unit-test
] with-scope

68
basis/command-line/command-line.factor
View File

@ -1,31 +1,56 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init continuations debugger hashtables io kernel
kernel.private namespaces parser sequences strings system
splitting io.files eval ;
USING: init continuations debugger hashtables io
io.encodings.utf8 io.files kernel kernel.private namespaces
parser sequences strings system splitting eval vocabs.loader ;
IN: command-line
SYMBOL: script
SYMBOL: command-line
: (command-line) ( -- args ) 10 getenv sift ;
: rc-path ( name -- path )
os windows? [ "." prepend ] unless
home prepend-path ;
: run-bootstrap-init ( -- )
"user-init" get [
home ".factor-boot-rc" append-path ?run-file
"factor-boot-rc" rc-path ?run-file
] when ;
: run-user-init ( -- )
"user-init" get [
home ".factor-rc" append-path ?run-file
"factor-rc" rc-path ?run-file
] when ;
: cli-var-param ( name value -- ) swap set-global ;
: load-vocab-roots ( -- )
"user-init" get [
"factor-roots" rc-path dup exists? [
utf8 file-lines [ add-vocab-root ] each
] [ drop ] if
] when ;
: cli-bool-param ( name -- ) "no-" ?head not cli-var-param ;
<PRIVATE
: cli-param ( param -- )
"=" split1 [ cli-var-param ] [ cli-bool-param ] if* ;
: var-param ( name value -- ) swap set-global ;
: cli-arg ( argument -- argument )
"-" ?head [ cli-param f ] when ;
: bool-param ( name -- ) "no-" ?head not var-param ;
: cli-args ( -- args ) 10 getenv ;
: param ( param -- )
"=" split1 [ var-param ] [ bool-param ] if* ;
: run-script ( file -- )
t "quiet" set-global run-file ;
PRIVATE>
: parse-command-line ( args -- )
[ command-line off script off ] [
unclip "-" ?head
[ param parse-command-line ]
[ script set command-line set ] if
] if-empty ;
SYMBOL: main-vocab-hook
@ -49,14 +74,17 @@ SYMBOL: main-vocab-hook
: ignore-cli-args? ( -- ? )
os macosx? "run" get "ui" = and ;
: script-mode ( -- )
t "quiet" set-global
"none" "run" set-global ;
: script-mode ( -- ) ;
: parse-command-line ( -- )
cli-args [ cli-arg ] filter
"script" get [ script-mode ] when
ignore-cli-args? [ drop ] [ [ run-file ] each ] if
"e" get [ eval ] when* ;
: handle-command-line ( -- )
[
(command-line) parse-command-line
load-vocab-roots
run-user-init
"e" get [ eval ] when*
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover ;
[ default-cli-args ] "command-line" add-init-hook

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

@ -18,7 +18,7 @@ IN: compiler.alien
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
: parameter-align ( n type -- n delta )
over >r c-type-stack-align align dup r> - ;
[ c-type-stack-align align dup ] [ drop ] 2bi - ;
: parameter-sizes ( types -- total offsets )
#! Compute stack frame locations.

29
basis/compiler/cfg/builder/builder.factor
View File

@ -21,8 +21,6 @@ IN: compiler.cfg.builder
! Convert tree SSA IR to CFG SSA IR.
: stop-iterating ( -- next ) end-basic-block f ;
SYMBOL: procedures
SYMBOL: current-word
SYMBOL: current-label
@ -190,7 +188,7 @@ M: #if emit-node
: emit-dispatch ( node -- )
##epilogue
ds-pop ^^offset>slot i ##dispatch
ds-pop ^^offset>slot i 0 ##dispatch
dispatch-branches ;
: <dispatch-block> ( -- word )
@ -211,7 +209,7 @@ M: #dispatch emit-node
! #call
M: #call emit-node
dup word>> dup "intrinsic" word-prop
[ emit-intrinsic iterate-next ] [ nip emit-call ] if ;
[ emit-intrinsic ] [ nip emit-call ] if ;
! #call-recursive
M: #call-recursive emit-node label>> id>> emit-call ;
@ -221,21 +219,14 @@ M: #push emit-node
literal>> ^^load-literal ds-push iterate-next ;
! #shuffle
: emit-shuffle ( effect -- )
[ out>> ] [ in>> dup length ds-load zip ] bi
'[ _ at ] map ds-store ;
M: #shuffle emit-node
shuffle-effect emit-shuffle iterate-next ;
M: #>r emit-node
[ in-d>> length ] [ out-r>> empty? ] bi
[ neg ##inc-d ] [ ds-load rs-store ] if
iterate-next ;
M: #r> emit-node
[ in-r>> length ] [ out-d>> empty? ] bi
[ neg ##inc-r ] [ rs-load ds-store ] if
dup
H{ } clone
[ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
[ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
[ nip ] 2tri
[ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi
iterate-next ;
! #return
@ -269,7 +260,7 @@ M: #terminate emit-node drop stop-iterating ;
: emit-alien-node ( node quot -- next )
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
begin-basic-block iterate-next ; inline
##branch begin-basic-block iterate-next ; inline
M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ;

11
basis/compiler/cfg/def-use/def-use.factor
View File

@ -12,9 +12,14 @@ M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp defs-vregs dst/tmp-vregs ;
M: ##allot defs-vregs dst/tmp-vregs ;
M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
M: ##slot defs-vregs dst/tmp-vregs ;
M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
M: ##string-nth defs-vregs dst/tmp-vregs ;
M: ##compare defs-vregs dst/tmp-vregs ;
M: ##compare-imm defs-vregs dst/tmp-vregs ;
M: ##compare-float defs-vregs dst/tmp-vregs ;
M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: insn defs-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;
@ -31,6 +36,7 @@ M: ##compare-imm-branch uses-vregs src1>> 1array ;
M: ##dispatch uses-vregs src>> 1array ;
M: ##alien-getter uses-vregs src>> 1array ;
M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: _compare-imm-branch uses-vregs src1>> 1array ;
M: insn uses-vregs drop f ;
@ -40,6 +46,7 @@ UNION: vreg-insn
##write-barrier
##dispatch
##effect
##fixnum-overflow
##conditional-branch
##compare-imm-branch
_conditional-branch

6
basis/compiler/cfg/hats/hats.factor
View File

@ -65,9 +65,9 @@ IN: compiler.cfg.hats
: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline

17
basis/compiler/cfg/instructions/instructions.factor
View File

@ -62,7 +62,7 @@ INSN: ##jump word ;
INSN: ##return ;
! Jump tables
INSN: ##dispatch src temp ;
INSN: ##dispatch src temp offset ;
INSN: ##dispatch-label label ;
! Slot access
@ -92,6 +92,15 @@ INSN: ##shr-imm < ##binary-imm ;
INSN: ##sar-imm < ##binary-imm ;
INSN: ##not < ##unary ;
! Overflowing arithmetic
TUPLE: ##fixnum-overflow < insn src1 src2 ;
INSN: ##fixnum-add < ##fixnum-overflow ;
INSN: ##fixnum-add-tail < ##fixnum-overflow ;
INSN: ##fixnum-sub < ##fixnum-overflow ;
INSN: ##fixnum-sub-tail < ##fixnum-overflow ;
INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ;
INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ;
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
@ -198,11 +207,11 @@ TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
INSN: ##compare-branch < ##conditional-branch ;
INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
INSN: ##compare < ##binary cc ;
INSN: ##compare-imm < ##binary-imm cc ;
INSN: ##compare < ##binary cc temp ;
INSN: ##compare-imm < ##binary-imm cc temp ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc ;
INSN: ##compare-float < ##binary cc temp ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;

29
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -3,10 +3,22 @@
USING: sequences accessors layouts kernel math namespaces
combinators fry locals
compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities ;
compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.iterator
compiler.cfg.instructions
compiler.cfg.utilities
compiler.cfg.registers ;
IN: compiler.cfg.intrinsics.fixnum
: emit-both-fixnums? ( -- )
D 0 ^^peek
D 1 ^^peek
^^or
tag-mask get ^^and-imm
0 cc= ^^compare-imm
ds-push ;
: (emit-fixnum-imm-op) ( infos insn -- dst )
ds-drop
[ ds-pop ]
@ -64,3 +76,16 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum>bignum ( -- )
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
: emit-fixnum-overflow-op ( quot quot-tail -- next )
[ 2inputs 1 ##inc-d ] 2dip
tail-call? [
##epilogue
nip call
stop-iterating
] [
drop call
##branch
begin-basic-block
iterate-next
] if ; inline

121
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -8,7 +8,8 @@ compiler.cfg.intrinsics.alien
compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots ;
compiler.cfg.intrinsics.slots
compiler.cfg.iterator ;
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
@ -22,6 +23,10 @@ IN: compiler.cfg.intrinsics
{
kernel.private:tag
math.private:both-fixnums?
math.private:fixnum+
math.private:fixnum-
math.private:fixnum*
math.private:fixnum+fast
math.private:fixnum-fast
math.private:fixnum-bitand
@ -85,60 +90,64 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
: emit-intrinsic ( node word -- )
: emit-intrinsic ( node word -- node/f )
{
{ \ kernel.private:tag [ drop emit-tag ] }
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
{ \ math.private:fixnum*fast [ emit-fixnum*fast ] }
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
{ \ kernel:eq? [ cc= emit-fixnum-comparison ] }
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
{ \ math.private:float< [ drop cc< emit-float-comparison ] }
{ \ math.private:float<= [ drop cc<= emit-float-comparison ] }
{ \ math.private:float>= [ drop cc>= emit-float-comparison ] }
{ \ math.private:float> [ drop cc> emit-float-comparison ] }
{ \ math.private:float= [ drop cc= emit-float-comparison ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
{ \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] }
{ \ strings.private:string-nth [ drop emit-string-nth ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
{ \ arrays:<array> [ emit-<array> ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
{ \ math.private:<complex> [ emit-simple-allot ] }
{ \ math.private:<ratio> [ emit-simple-allot ] }
{ \ kernel:<wrapper> [ emit-simple-allot ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
{ \ kernel.private:tag [ drop emit-tag iterate-next ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
{ \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
{ \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
{ \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
{ \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
{ \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
{ \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
{ \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
{ \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] }
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] }
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] }
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] }
{ \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] }
{ \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] }
{ \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] }
{ \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] }
{ \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] }
{ \ slots.private:slot [ emit-slot iterate-next ] }
{ \ slots.private:set-slot [ emit-set-slot iterate-next ] }
{ \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
{ \ arrays:<array> [ emit-<array> iterate-next ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
{ \ math.private:<complex> [ emit-simple-allot iterate-next ] }
{ \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] }
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] }
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] }
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] }
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] }
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] }
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] }
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] }
{ \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] }
{ \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] }
{ \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] }
{ \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] }
} case ;

4
basis/compiler/cfg/linearization/linearization.factor
View File

@ -43,8 +43,8 @@ M: ##branch linearize-insn
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
[ (binary-conditional) ]
[ drop dup successors>> first useless-branch? ] 2bi
[ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
[ drop dup successors>> second useless-branch? ] 2bi
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
M: ##compare-branch linearize-insn
binary-conditional _compare-branch emit-branch ;

5
basis/compiler/cfg/rpo/rpo.factor
View File

@ -9,7 +9,10 @@ SYMBOL: visited
: post-order-traversal ( bb -- )
dup id>> visited get key? [ drop ] [
dup id>> visited get conjoin
[ successors>> [ post-order-traversal ] each ] [ , ] bi
[
successors>> <reversed>
[ post-order-traversal ] each
] [ , ] bi
] if ;
: post-order ( bb -- blocks )

6
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -34,6 +34,12 @@ M: insn compute-stack-frame*
\ _gc t frame-required? set-word-prop
\ _spill t frame-required? set-word-prop
\ ##fixnum-add t frame-required? set-word-prop
\ ##fixnum-sub t frame-required? set-word-prop
\ ##fixnum-mul t frame-required? set-word-prop
\ ##fixnum-add-tail f frame-required? set-word-prop
\ ##fixnum-sub-tail f frame-required? set-word-prop
\ ##fixnum-mul-tail f frame-required? set-word-prop
: compute-stack-frame ( insns -- )
frame-required? off

20
basis/compiler/cfg/stacks/stacks.factor
View File

@ -15,16 +15,28 @@ IN: compiler.cfg.stacks
1 ##inc-d D 0 ##replace ;
: ds-load ( n -- vregs )
[ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
dup 0 =
[ drop f ]
[ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ] if ;
: ds-store ( vregs -- )
<reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
[
<reversed>
[ length ##inc-d ]
[ [ <ds-loc> ##replace ] each-index ] bi
] unless-empty ;
: rs-load ( n -- vregs )
[ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
dup 0 =
[ drop f ]
[ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ] if ;
: rs-store ( vregs -- )
<reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
[
<reversed>
[ length ##inc-r ]
[ [ <rs-loc> ##replace ] each-index ] bi
] unless-empty ;
: 2inputs ( -- vreg1 vreg2 )
D 1 ^^peek D 0 ^^peek -2 ##inc-d ;

2
basis/compiler/cfg/utilities/utilities.factor
View File

@ -33,5 +33,7 @@ IN: compiler.cfg.utilities
building off
basic-block off ;
: stop-iterating ( -- next ) end-basic-block f ;
: emit-primitive ( node -- )
word>> ##call ##branch begin-basic-block ;

4
basis/compiler/cfg/value-numbering/propagate/propagate.factor
View File

@ -62,4 +62,8 @@ M: ##compare-imm-branch propagate
M: ##dispatch propagate
[ resolve ] change-src ;
M: ##fixnum-overflow propagate
[ resolve ] change-src1
[ resolve ] change-src2 ;
M: insn propagate ;

27
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
math
math fry
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.simplify
@ -63,7 +64,7 @@ M: ##compare-imm-branch rewrite-tagged-comparison
M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
f \ ##compare-imm boa ;
i f \ ##compare-imm boa ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
@ -78,7 +79,7 @@ M: ##compare-imm-branch rewrite
[ dst>> ]
[ src2>> ]
[ src1>> vreg>vn vn>constant ] tri
cc= f \ ##compare-imm boa ;
cc= f i \ ##compare-imm boa ;
M: ##compare rewrite
dup flip-comparison? [
@ -95,9 +96,9 @@ M: ##compare rewrite
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
{ \ ##compare [ >compare-expr< f \ ##compare boa ] }
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
{ \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
{ \ ##compare [ >compare-expr< i f \ ##compare boa ] }
{ \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
{ \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
@ -113,4 +114,18 @@ M: ##compare-imm rewrite
] when
] when ;
: dispatch-offset ( expr -- n )
[ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
\ ##sub-imm eq? [ neg ] when ;
: add-dispatch-offset? ( insn -- expr ? )
src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
M: ##dispatch rewrite
dup add-dispatch-offset? [
[ clone ] dip
[ in1>> vn>vreg >>src ]
[ dispatch-offset '[ _ + ] change-offset ] bi
] [ drop ] if ;
M: insn rewrite ;

23
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -1,6 +1,17 @@
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test kernel math ;
compiler.cfg.registers cpu.architecture tools.test kernel math
combinators.short-circuit accessors sequences ;
: trim-temps ( insns -- insns )
[
dup {
[ ##compare? ]
[ ##compare-imm? ]
[ ##compare-float? ]
} 1|| [ f >>temp ] when
] map ;
[
{
T{ ##peek f V int-regs 45 D 1 }
@ -34,7 +45,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
[ t ] [
{
T{ ##peek f V int-regs 1 D 0 }
T{ ##dispatch f V int-regs 1 V int-regs 2 }
T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
} dup value-numbering =
] unit-test
@ -82,7 +93,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering
} value-numbering trim-temps
] unit-test
[
@ -100,7 +111,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering
} value-numbering trim-temps
] unit-test
[
@ -122,7 +133,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
T{ ##replace f V int-regs 14 D 0 }
} value-numbering
} value-numbering trim-temps
] unit-test
[
@ -138,5 +149,5 @@ compiler.cfg.registers cpu.architecture tools.test kernel math ;
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
} value-numbering
} value-numbering trim-temps
] unit-test

36
basis/compiler/codegen/codegen.factor
View File

@ -93,7 +93,7 @@ M: ##return generate-insn drop %return ;
M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn
[ src>> register ] [ temp>> register ] bi %dispatch ;
[ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
: >slot<
{
@ -156,6 +156,19 @@ M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
M: ##not generate-insn dst/src %not ;
: src1/src2 ( insn -- src1 src2 )
[ src1>> register ] [ src2>> register ] bi ; inline
: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 )
[ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline
M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ;
: dst/src/temp ( insn -- dst src temp )
[ dst/src ] [ temp>> register ] bi ; inline
@ -235,7 +248,7 @@ M: float-regs reg-class-variable drop float-regs ;
GENERIC: inc-reg-class ( register-class -- )
: ?dummy-stack-params ( reg-class -- )
dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
dummy-stack-params? [ reg-size cell align stack-params +@ ] [ drop ] if ;
: ?dummy-int-params ( reg-class -- )
dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
@ -264,7 +277,7 @@ M: object reg-class-full?
: spill-param ( reg-class -- n reg-class )
stack-params get
>r reg-size stack-params +@ r>
[ reg-size cell align stack-params +@ ] dip
stack-params ;
: fastcall-param ( reg-class -- n reg-class )
@ -300,10 +313,10 @@ M: long-long-type flatten-value-type ( type -- types )
] { } make ;
: each-parameter ( parameters quot -- )
>r [ parameter-sizes nip ] keep r> 2each ; inline
[ [ parameter-sizes nip ] keep ] dip 2each ; inline
: reverse-each-parameter ( parameters quot -- )
>r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
[ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
: reset-freg-counts ( -- )
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
@ -316,15 +329,13 @@ M: long-long-type flatten-value-type ( type -- types )
#! Moves values from C stack to registers (if word is
#! %load-param-reg) and registers to C stack (if word is
#! %save-param-reg).
>r
alien-parameters
flatten-value-types
r> '[ alloc-parameter _ execute ] each-parameter ;
inline
[ alien-parameters flatten-value-types ]
[ '[ alloc-parameter _ execute ] ]
bi* each-parameter ; inline
: unbox-parameters ( offset node -- )
parameters>> [
%prepare-unbox >r over + r> unbox-parameter
%prepare-unbox [ over + ] dip unbox-parameter
] reverse-each-parameter drop ;
: prepare-box-struct ( node -- offset )
@ -491,9 +502,10 @@ M: _label generate-insn
M: _branch generate-insn
label>> lookup-label %jump-label ;
: >compare< ( insn -- label cc src1 src2 )
: >compare< ( insn -- dst temp cc src1 src2 )
{
[ dst>> register ]
[ temp>> register ]
[ cc>> ]
[ src1>> register ]
[ src2>> ?register ]

21
basis/compiler/codegen/fixup/fixup.factor
View File

@ -46,34 +46,33 @@ M: integer fixup* , ;
: indq ( elt seq -- n ) [ eq? ] with find drop ;
: adjoin* ( obj table -- n )
2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
2dup indq [ 2nip ] [ dup length [ push ] dip ] if* ;
SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;
[ string>symbol ] dip 2array literal-table get push-all ;
: rel-dlsym ( name dll class -- )
>r literal-table get length >r
add-dlsym-literals
r> r> rt-dlsym rel-fixup ;
[ literal-table get length [ add-dlsym-literals ] dip ] dip
rt-dlsym rel-fixup ;
: rel-word ( word class -- )
>r add-literal r> rt-xt rel-fixup ;
[ add-literal ] dip rt-xt rel-fixup ;
: rel-primitive ( word class -- )
>r def>> first r> rt-primitive rel-fixup ;
[ def>> first ] dip rt-primitive rel-fixup ;
: rel-literal ( literal class -- )
>r add-literal r> rt-literal rel-fixup ;
: rel-immediate ( literal class -- )
[ add-literal ] dip rt-immediate rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
: rel-here ( class -- )
0 swap rt-here rel-fixup ;
: rel-here ( offset class -- )
rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set

2
basis/compiler/compiler-docs.factor
View File

@ -6,7 +6,7 @@ HELP: enable-compiler
{ $description "Enables the optimizing compiler." } ;
HELP: disable-compiler
{ $description "Enables the optimizing compiler." } ;
{ $description "Disable the optimizing compiler." } ;
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically. This can be changed:"

8
basis/compiler/compiler.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io debugger
words fry continuations vocabs assocs dlists definitions math
threads graphs generic combinators deques search-deques
words fry continuations vocabs assocs dlists definitions
math threads graphs generic combinators deques search-deques
prettyprint io stack-checker stack-checker.state
stack-checker.inlining compiler.errors compiler.units
compiler.tree.builder compiler.tree.optimizer
@ -91,8 +91,8 @@ t compile-dependencies? set-global
[
dup crossref?
[
dependencies get >alist
generic-dependencies get >alist
dependencies get
generic-dependencies get
compiled-xref
] [ drop ] if
] tri ;

16
basis/compiler/constants/constants.factor
View File

@ -37,14 +37,14 @@ IN: compiler.constants
: rc-indirect-arm-pc 8 ; inline
! Relocation types
: rt-primitive 0 ; inline
: rt-dlsym 1 ; inline
: rt-literal 2 ; inline
: rt-dispatch 3 ; inline
: rt-xt 4 ; inline
: rt-here 5 ; inline
: rt-label 6 ; inline
: rt-immediate 7 ; inline
: rt-primitive 0 ; inline
: rt-dlsym 1 ; inline
: rt-dispatch 2 ; inline
: rt-xt 3 ; inline
: rt-here 4 ; inline
: rt-label 5 ; inline
: rt-immediate 6 ; inline
: rt-stack-chain 7 ; inline
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]

25
basis/compiler/tests/alien.factor
View File

@ -3,7 +3,8 @@ USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences stack-checker
stack-checker.errors words arrays parser quotations
continuations effects namespaces.private io io.streams.string
memory system threads tools.test math accessors combinators ;
memory system threads tools.test math accessors combinators
specialized-arrays.float ;
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test
@ -146,13 +147,21 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y )
"void"
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
"int"
f "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
alien-invoke gc 3 ;
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
"float"
f "ffi_test_31_point_5"
{ "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
alien-invoke ;
[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ;
@ -188,7 +197,11 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
[ 32.0 ] [
{ 1.0 2.0 3.0 } >float-array underlying>>
{ 4.0 5.0 6.0 } >float-array underlying>>
ffi_test_23
] unit-test
! Test odd-size structs
C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
@ -353,7 +366,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7 ( -- callback )
"void" { } "cdecl" [ 1000 sleep ] alien-callback ;
"void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test

48
basis/compiler/tests/templates.factor → basis/compiler/tests/codegen.factor
View File

@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors float-arrays ;
combinators vectors grouping make ;
IN: compiler.tests
! Originally, this file did black box testing of templating
@ -230,3 +230,49 @@ TUPLE: id obj ;
10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
[ ] [ gc-check-bug ] unit-test
! New optimization
: test-1 ( a -- b ) 8 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
[ "a" ] [ 8 test-1 ] unit-test
[ "b" ] [ 9 test-1 ] unit-test
: test-2 ( a -- b ) 1 fixnum-fast { [ "a" ] [ "b" ] } dispatch ;
[ "a" ] [ 1 test-2 ] unit-test
[ "b" ] [ 2 test-2 ] unit-test
! I accidentally fixnum/i-fast on PowerPC
[ { { 1 2 } { 3 4 } } ] [
{ 1 2 3 4 }
[
[ { array } declare 2 <groups> [ , ] each ] compile-call
] { } make
] unit-test
[ 2 ] [
{ 1 2 3 4 }
[ { array } declare 2 <groups> length ] compile-call
] unit-test
! Oops with new intrinsics
: fixnum-overflow-control-flow-test ( a b -- c )
[ 1 fixnum- ] [ 2 fixnum- ] if 3 fixnum+fast ;
[ 3 ] [ 1 t fixnum-overflow-control-flow-test ] unit-test
[ 2 ] [ 1 f fixnum-overflow-control-flow-test ] unit-test
! LOL
: blah ( a -- b )
{ float } declare dup 0 =
[ drop 1 ] [
dup 0 >=
[ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
[ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
if
] if ;
[ 4.0 ] [ 2.0 blah ] unit-test
[ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
[ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test

6
basis/compiler/tests/intrinsics.factor
View File

@ -160,6 +160,11 @@ IN: compiler.tests
[ -2 ] [ 4 [ -2 fixnum/i ] compile-call ] unit-test
[ 3 1 ] [ 10 3 [ fixnum/mod ] compile-call ] unit-test
[ 2 ] [ 4 2 [ fixnum/i-fast ] compile-call ] unit-test
[ 2 ] [ 4 [ 2 fixnum/i-fast ] compile-call ] unit-test
[ -2 ] [ 4 [ -2 fixnum/i-fast ] compile-call ] unit-test
[ 3 1 ] [ 10 3 [ fixnum/mod-fast ] compile-call ] unit-test
[ 4 ] [ 1 3 [ fixnum+ ] compile-call ] unit-test
[ 4 ] [ 1 [ 3 fixnum+ ] compile-call ] unit-test
[ 4 ] [ [ 1 3 fixnum+ ] compile-call ] unit-test
@ -208,6 +213,7 @@ IN: compiler.tests
[ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
[ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test

4
basis/compiler/tests/optimizer.factor
View File

@ -286,9 +286,7 @@ HINTS: recursive-inline-hang-2 array ;
HINTS: recursive-inline-hang-3 array ;
! Regression
USE: sequences.private
[ ] [ { (3append) } compile ] unit-test
[ ] [ { 3append-as } compile ] unit-test
! Wow
: counter-example ( a b c d -- a' b' c' d' )

14
basis/compiler/tests/redefine13.factor Normal file
View File

@ -0,0 +1,14 @@
USING: math fry macros eval tools.test ;
IN: compiler.tests.redefine13
: breakage-word ( a b -- c ) + ;
MACRO: breakage-macro ( a -- ) '[ _ breakage-word ] ;
GENERIC: breakage-caller ( a -- c )
M: fixnum breakage-caller 2 breakage-macro ;
: breakage ( -- obj ) 2 breakage-caller ;
! [ ] [ "IN: compiler.tests.redefine13 : breakage-word ( a b -- c ) ;" eval ] unit-test

8
basis/compiler/tests/redefine14.factor Normal file
View File

@ -0,0 +1,8 @@
USING: compiler.units definitions tools.test sequences ;
IN: compiler.tests.redefine14
! TUPLE: bad ;
!
! M: bad length 1 2 3 ;
!
! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test

2
basis/compiler/tests/spilling.factor
View File

@ -1,5 +1,5 @@
USING: math.private kernel combinators accessors arrays
generalizations float-arrays tools.test ;
generalizations tools.test ;
IN: compiler.tests
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )

27
basis/compiler/tree/builder/builder.factor
View File

@ -1,9 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces
assocs words arrays vectors hints combinators stack-checker
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.backend compiler.tree ;
assocs words arrays vectors hints combinators compiler.tree
stack-checker
stack-checker.state
stack-checker.errors
stack-checker.visitor
stack-checker.backend
stack-checker.recursive-state ;
IN: compiler.tree.builder
: with-tree-builder ( quot -- nodes )
@ -12,12 +16,13 @@ IN: compiler.tree.builder
: build-tree ( quot -- nodes )
#! Not safe to call from inference transforms.
[ f infer-quot ] with-tree-builder nip ;
[ f initial-recursive-state infer-quot ] with-tree-builder nip ;
: build-tree-with ( in-stack quot -- nodes out-stack )
#! Not safe to call from inference transforms.
[
[ >vector meta-d set ] [ f infer-quot ] bi*
[ >vector meta-d set ]
[ f initial-recursive-state infer-quot ] bi*
] with-tree-builder nip
unclip-last in-d>> ;
@ -29,14 +34,10 @@ IN: compiler.tree.builder
if ;
: (build-tree-from-word) ( word -- )
dup
[ "inline" word-prop ]
[ "recursive" word-prop ] bi and [
1quotation f infer-quot
] [
[ specialized-def ]
[ dup 2array 1array ] bi infer-quot
] if ;
dup initial-recursive-state recursive-state set
dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and
[ 1quotation ] [ specialized-def ] if
infer-quot-here ;
: check-cannot-infer ( word -- )
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;

18
basis/compiler/tree/checker/checker.factor
View File

@ -22,8 +22,8 @@ ERROR: check-use-error value message ;
GENERIC: check-node* ( node -- )
M: #shuffle check-node*
[ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
[ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
[ [ mapping>> values ] [ [ in-d>> ] [ in-r>> ] bi append ] bi subset? [ "Bad mapping inputs" throw ] unless ]
[ [ mapping>> keys ] [ [ out-d>> ] [ out-r>> ] bi append ] bi set= [ "Bad mapping outputs" throw ] unless ]
bi ;
: check-lengths ( seq -- )
@ -31,13 +31,6 @@ M: #shuffle check-node*
M: #copy check-node* inputs/outputs 2array check-lengths ;
: check->r/r> ( node -- )
inputs/outputs [ drop ] [ 2array check-lengths ] if-empty ;
M: #>r check-node* check->r/r> ;
M: #r> check-node* check->r/r> ;
M: #return-recursive check-node* inputs/outputs 2array check-lengths ;
M: #phi check-node*
@ -113,11 +106,8 @@ M: #push check-stack-flow* check-out-d ;
M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #shuffle check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #>r check-stack-flow* [ check-in-d ] [ check-out-r ] bi ;
M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ;
M: #shuffle check-stack-flow*
{ [ check-in-d ] [ check-in-r ] [ check-out-d ] [ check-out-r ] } cleave ;
: assert-datastack-empty ( -- )
datastack get empty? [ "Data stack not empty" throw ] unless ;

26
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -5,7 +5,7 @@ strings sbufs sequences.private slots.private combinators
definitions system layouts vectors math.partial-dispatch
math.order math.functions accessors hashtables classes assocs
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
sorting.private combinators.short-circuit
sorting.private combinators.short-circuit grouping prettyprint
compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
@ -71,7 +71,7 @@ M: object xyz ;
2over fixnum>= [
3drop
] [
[ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
[ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat)
] if ; inline recursive
: fx-repeat ( n quot -- )
@ -87,10 +87,10 @@ M: object xyz ;
2over dup xyz drop >= [
3drop
] [
[ swap >r call 1+ r> ] keep (i-repeat)
[ swap [ call 1+ ] dip ] keep (i-repeat)
] if ; inline recursive
: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline
[ t ] [
[ [ dup xyz drop ] i-repeat ] \ xyz inlined?
@ -194,7 +194,7 @@ M: fixnum annotate-entry-test-1 drop ;
2dup >= [
2drop
] [
>r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
] if ; inline recursive
: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
@ -448,7 +448,7 @@ cell-bits 32 = [
] unit-test
[ ] [
[ [ >r "A" throw r> ] [ "B" throw ] if ]
[ [ [ "A" throw ] dip ] [ "B" throw ] if ]
cleaned-up-tree drop
] unit-test
@ -463,7 +463,7 @@ cell-bits 32 = [
: buffalo-wings ( i seq -- )
2dup < [
2dup chicken-fingers
>r 1+ r> buffalo-wings
[ 1+ ] dip buffalo-wings
] [
2drop
] if ; inline recursive
@ -482,7 +482,7 @@ cell-bits 32 = [
: ribs ( i seq -- )
2dup < [
steak
>r 1+ r> ribs
[ 1+ ] dip ribs
] [
2drop
] if ; inline recursive
@ -500,3 +500,13 @@ cell-bits 32 = [
[ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
[ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
] unit-test
[ ] [
[ { null } declare [ 1 ] [ 2 ] if ]
build-tree normalize propagate cleanup check-nodes
] unit-test
[ t ] [
[ { array } declare 2 <groups> [ . . ] assoc-each ]
\ nth-unsafe inlined?
] unit-test

2
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -102,7 +102,7 @@ M: #declare cleanup* drop f ;
#! If only one branch is live we don't need to branch at
#! all; just drop the condition value.
dup live-children sift dup length {
{ 0 [ 2drop f ] }
{ 0 [ drop in-d>> #drop ] }
{ 1 [ first swap in-d>> #drop prefix ] }
[ 2drop ]
} case ;

2
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -39,7 +39,7 @@ M: #branch remove-dead-code*
[ drop filter-live ] [ swap nths ] 2bi
[ make-values ] keep
[ drop ] [ zip ] 2bi
#shuffle ;
#data-shuffle ;
: insert-drops ( nodes values indices -- nodes' )
'[

4
basis/compiler/tree/dead-code/dead-code-tests.factor
View File

@ -75,9 +75,9 @@ IN: compiler.tree.dead-code.tests
remove-dead-code
"no-check" get [ dup check-nodes ] unless nodes>quot ;
[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test
[ [ drop 1 ] ] [ [ [ 1 ] dip drop ] optimize-quot ] unit-test
[ [ read drop 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test
[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test
[ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test

5
basis/compiler/tree/dead-code/liveness/liveness.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors namespaces assocs deques search-deques
kernel sequences sequences.deep words sets stack-checker.branches
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
dlists kernel sequences sequences.deep words sets
stack-checker.branches compiler.tree compiler.tree.def-use
compiler.tree.combinators ;
IN: compiler.tree.dead-code.liveness
SYMBOL: work-list

26
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -39,12 +39,6 @@ M: #copy compute-live-values*
M: #call compute-live-values* nip look-at-inputs ;
M: #>r compute-live-values*
[ out-r>> ] [ in-d>> ] bi look-at-mapping ;
M: #r> compute-live-values*
[ out-d>> ] [ in-r>> ] bi look-at-mapping ;
M: #shuffle compute-live-values*
mapping>> at look-at-value ;
@ -61,7 +55,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
zip filter-mapping values ;
: filter-live ( values -- values' )
[ live-value? ] filter ;
dup empty? [ [ live-value? ] filter ] unless ;
:: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
inputs
@ -69,7 +63,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
outputs
mapping-keys
mapping-values
filter-corresponding zip #shuffle ; inline
filter-corresponding zip #data-shuffle ; inline
:: drop-dead-values ( outputs -- #shuffle )
[let* | new-outputs [ outputs make-values ]
@ -95,16 +89,6 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
M: #introduce remove-dead-code* ( #introduce -- nodes )
maybe-drop-dead-outputs ;
M: #>r remove-dead-code*
[ filter-live ] change-out-r
[ filter-live ] change-in-d
dup in-d>> empty? [ drop f ] when ;
M: #r> remove-dead-code*
[ filter-live ] change-out-d
[ filter-live ] change-in-r
dup in-r>> empty? [ drop f ] when ;
M: #push remove-dead-code*
dup out-d>> first live-value? [ drop f ] unless ;
@ -125,12 +109,14 @@ M: #call remove-dead-code*
M: #shuffle remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-out-d
[ filter-live ] change-in-r
[ filter-live ] change-out-r
[ filter-mapping ] change-mapping
dup in-d>> empty? [ drop f ] when ;
dup [ in-d>> empty? ] [ in-r>> empty? ] bi and [ drop f ] when ;
M: #copy remove-dead-code*
[ in-d>> ] [ out-d>> ] bi
2dup swap zip #shuffle
2dup swap zip #data-shuffle
remove-dead-code* ;
M: #terminate remove-dead-code*

62
basis/compiler/tree/debugger/debugger.factor
View File

@ -3,7 +3,7 @@
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
combinators io sorting hints qualified
combinators combinators.short-circuit io sorting hints qualified
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
@ -57,11 +57,43 @@ TUPLE: shuffle-node { effect effect } ;
M: shuffle-node pprint* effect>> effect>string text ;
M: #shuffle node>quot
shuffle-effect dup pretty-shuffle
[ % ] [ shuffle-node boa , ] ?if ;
: (shuffle-effect) ( in out #shuffle -- effect )
mapping>> '[ _ at ] map <effect> ;
M: #push node>quot literal>> , ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
: #>r? ( #shuffle -- ? )
{
[ in-d>> length 1 = ]
[ out-r>> length 1 = ]
[ in-r>> empty? ]
[ out-d>> empty? ]
} 1&& ;
: #r>? ( #shuffle -- ? )
{
[ in-d>> empty? ]
[ out-r>> empty? ]
[ in-r>> length 1 = ]
[ out-d>> length 1 = ]
} 1&& ;
M: #shuffle node>quot
{
{ [ dup #>r? ] [ drop \ >r , ] }
{ [ dup #r>? ] [ drop \ r> , ] }
{
[ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
[
shuffle-effect dup pretty-shuffle
[ % ] [ shuffle-node boa , ] ?if
]
}
[ drop "COMPLEX SHUFFLE" , ]
} cond ;
M: #push node>quot literal>> literalize , ;
M: #call node>quot word>> , ;
@ -82,16 +114,6 @@ M: #if node>quot
M: #dispatch node>quot
children>> [ nodes>quot ] map , \ dispatch , ;
M: #>r node>quot
[ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi
<repetition> % ;
DEFER: rdrop
M: #r> node>quot
[ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
<repetition> % ;
M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
@ -103,9 +125,13 @@ M: node node>quot drop ;
: nodes>quot ( node -- quot )
[ [ node>quot ] each ] [ ] make ;
: optimized. ( quot/word -- )
dup word? [ specialized-def ] when
build-tree optimize-tree nodes>quot . ;
GENERIC: optimized. ( quot/word -- )
M: method-spec optimized. first2 method optimized. ;
M: word optimized. specialized-def optimized. ;
M: callable optimized. build-tree optimize-tree nodes>quot . ;
SYMBOL: words-called
SYMBOL: generics-called

12
basis/compiler/tree/def-use/def-use.factor
View File

@ -18,12 +18,16 @@ TUPLE: definition value node uses ;
swap >>node
V{ } clone >>uses ;
ERROR: no-def-error value ;
: def-of ( value -- definition )
def-use get at* [ "No def" throw ] unless ;
dup def-use get at* [ nip ] [ no-def-error ] if ;
ERROR: multiple-defs-error ;
: def-value ( node value -- )
def-use get 2dup key? [
"Multiple defs" throw
multiple-defs-error
] [
[ [ <definition> ] keep ] dip set-at
] if ;
@ -38,16 +42,16 @@ GENERIC: node-uses-values ( node -- values )
M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ;
M: #r> node-uses-values in-r>> ;
M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
M: #declare node-uses-values declaration>> keys ;
M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
M: #alien-callback node-uses-values drop f ;
M: node node-uses-values in-d>> ;
GENERIC: node-defs-values ( node -- values )
M: #>r node-defs-values out-r>> ;
M: #shuffle node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
M: #branch node-defs-values drop f ;
M: #declare node-defs-values drop f ;
M: #return node-defs-values drop f ;

2
basis/compiler/tree/escape-analysis/allocations/allocations.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces sequences kernel math
combinators sets disjoint-sets fry stack-checker.state ;
combinators sets disjoint-sets fry stack-checker.values ;
IN: compiler.tree.escape-analysis.allocations
! A map from values to one of the following:

4
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -8,6 +8,7 @@ math.private kernel tools.test accessors slots.private
quotations.private prettyprint classes.tuple.private classes
classes.tuple namespaces
compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker
kernel.private ;
\ escape-analysis must-infer
@ -34,6 +35,7 @@ M: node count-unboxed-allocations* drop ;
propagate
cleanup
escape-analysis
dup check-nodes
0 swap [ count-unboxed-allocations* ] each-node ;
[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
@ -307,7 +309,7 @@ C: <ro-box> ro-box
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
[ 3 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
[ 0 ] [
[ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]

8
basis/compiler/tree/finalization/finalization.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences words memoize classes.builtin
fry assocs
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
@ -27,9 +28,10 @@ GENERIC: finalize* ( node -- nodes )
M: #copy finalize* drop f ;
M: #shuffle finalize*
dup shuffle-effect
[ in>> ] [ out>> ] bi sequence=
[ drop f ] when ;
dup
[ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
[ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
bi and [ drop f ] when ;
: builtin-predicate? ( #call -- ? )
word>> "predicating" word-prop builtin-class? ;

2
basis/compiler/tree/identities/identities.factor
View File

@ -79,7 +79,7 @@ GENERIC: apply-identities* ( node -- node )
: select-input ( node n -- #shuffle )
[ [ in-d>> ] [ out-d>> ] bi ] dip
pick nth over first associate #shuffle ;
pick nth over first associate #data-shuffle ;
M: #call apply-identities*
dup word>> "identities" word-prop [

4
basis/compiler/tree/normalization/normalization-tests.factor
View File

@ -34,8 +34,8 @@ sequences accessors tools.test kernel math ;
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
DEFER: bbb
: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive
[ ] [ [ bbb ] test-normalization ] unit-test

6
basis/compiler/tree/normalization/renaming/renaming.factor
View File

@ -10,7 +10,7 @@ SYMBOL: rename-map
[ rename-map get at ] keep or ;
: rename-values ( values -- values' )
rename-map get '[ [ _ at ] keep or ] map ;
dup empty? [ rename-map get '[ [ _ at ] keep or ] map ] unless ;
: add-renamings ( old new -- )
[ rename-values ] dip
@ -22,13 +22,11 @@ M: #introduce rename-node-values* ;
M: #shuffle rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r
[ [ rename-value ] assoc-map ] change-mapping ;
M: #push rename-node-values* ;
M: #r> rename-node-values*
[ rename-values ] change-in-r ;
M: #terminate rename-node-values*
[ rename-values ] change-in-d
[ rename-values ] change-in-r ;

4
basis/compiler/tree/propagation/branches/branches.factor
View File

@ -40,8 +40,8 @@ M: #dispatch live-branches
SYMBOL: infer-children-data
: copy-value-info ( -- )
value-infos [ clone ] change
constraints [ clone ] change ;
value-infos [ H{ } clone suffix ] change
constraints [ H{ } clone suffix ] change ;
: no-value-info ( -- )
value-infos off

6
basis/compiler/tree/propagation/constraints/constraints.factor
View File

@ -32,7 +32,7 @@ TUPLE: true-constraint value ;
M: true-constraint assume*
[ \ f class-not <class-info> swap value>> refine-value-info ]
[ constraints get at [ assume ] when* ]
[ constraints get assoc-stack [ assume ] when* ]
bi ;
M: true-constraint satisfied?
@ -44,7 +44,7 @@ TUPLE: false-constraint value ;
M: false-constraint assume*
[ \ f <class-info> swap value>> refine-value-info ]
[ constraints get at [ assume ] when* ]
[ constraints get assoc-stack [ assume ] when* ]
bi ;
M: false-constraint satisfied?
@ -83,7 +83,7 @@ TUPLE: implication p q ;
C: --> implication
: assume-implication ( p q -- )
[ constraints get [ swap suffix ] change-at ]
[ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: implication assume*

4
basis/compiler/tree/propagation/info/info-tests.factor
View File

@ -70,3 +70,7 @@ TUPLE: test-tuple { x read-only } ;
f f 3 <literal-info> 3array test-tuple <tuple-info> dup
object-info value-info-intersect =
] unit-test
[ t ] [
null-info 3 <literal-info> value-info<=
] unit-test

31
basis/compiler/tree/propagation/info/info.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals
namespaces sequences words combinators combinators.short-circuit
namespaces sequences words combinators
arrays compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
@ -34,7 +34,7 @@ slots ;
: null-info T{ value-info f null empty-interval } ; inline
: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline
: object-info T{ value-info f object full-interval } ; inline
: class-interval ( class -- interval )
dup real class<=
@ -43,7 +43,7 @@ slots ;
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
#! precise, we can turn it into a literal
dup empty-interval eq? [
dup special-interval? [
2drop f f
] [
dup from>> first {
@ -243,7 +243,7 @@ DEFER: (value-info-union)
: literals<= ( info1 info2 -- ? )
{
{ [ dup literal?>> not ] [ 2drop t ] }
{ [ over literal?>> not ] [ 2drop f ] }
{ [ over literal?>> not ] [ drop class>> null-class? ] }
[ [ literal>> ] bi@ eql? ]
} cond ;
@ -253,26 +253,29 @@ DEFER: (value-info-union)
{ [ over not ] [ 2drop f ] }
[
{
[ [ class>> ] bi@ class<= ]
[ [ interval>> ] bi@ interval-subset? ]
[ literals<= ]
[ [ length>> ] bi@ value-info<= ]
[ [ slots>> ] bi@ [ value-info<= ] 2all? ]
} 2&&
{ [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
{ [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
{ [ 2dup literals<= not ] [ f ] }
{ [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
{ [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
[ t ]
} cond 2nip
]
} cond ;
! Current value --> info mapping
! Assoc stack of current value --> info mapping
SYMBOL: value-infos
: value-info ( value -- info )
resolve-copy value-infos get at null-info or ;
resolve-copy value-infos get assoc-stack null-info or ;
: set-value-info ( info value -- )
resolve-copy value-infos get set-at ;
resolve-copy value-infos get peek set-at ;
: refine-value-info ( info value -- )
resolve-copy value-infos get [ value-info-intersect ] change-at ;
resolve-copy value-infos get
[ assoc-stack value-info-intersect ] 2keep
peek set-at ;
: value-literal ( value -- obj ? )
value-info >literal< ;

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