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

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

db4
Doug Coleman 2008-12-12 13:49:59 -06:00
parent 91f0d85a41 210c661d4d
commit e7979a1ac5
1379 changed files with 24630 additions and 12090 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

4
basis/alarms/alarms.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators generic init
kernel math namespaces sequences heaps boxes threads debugger
kernel math namespaces sequences heaps boxes threads
quotations assocs math.order ;
IN: alarms
@ -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 ]

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 ;

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

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

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

@ -8,7 +8,7 @@ sequences system libc alien.strings io.encodings.utf8 ;
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
: foo ( -- n ) &: fdafd [ 123 ] unless* ;
[ 123 ] [ foo ] unit-test
@ -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 ;

14
basis/alien/prettyprint/prettyprint.factor Normal file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators alien alien.strings alien.syntax
prettyprint.backend prettyprint.custom prettyprint.sections ;
IN: alien.prettyprint
M: alien pprint*
{
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;

4
basis/alien/strings/strings-docs.factor
View File

@ -31,10 +31,6 @@ HELP: string>symbol
$nl
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
HELP: utf16n
{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
{ $see-also "encodings-introduction" } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl

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

@ -1,6 +1,6 @@
USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
io.encodings.ascii alien io.encodings.string ;
io.encodings.utf16n io.encodings.ascii alien io.encodings.string ;
IN: alien.strings.tests
[ "\u0000ff" ]

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

@ -2,14 +2,14 @@
! See http://factorcode.org/license.txt for BSD license.
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.utf8 io.streams.byte-array io.streams.memory system
alien strings cpu.architecture fry vocabs.loader combinators ;
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 ] ;
@ -85,27 +88,22 @@ M: string-type c-type-getter
M: string-type c-type-setter
drop [ set-alien-cell ] ;
! Native-order UTF-16
HOOK: alien>native-string os ( alien -- string )
SINGLETON: utf16n
: utf16n ( -- descriptor )
little-endian? utf16le utf16be ? ; foldable
M: utf16n <decoder> drop utf16n <decoder> ;
M: utf16n <encoder> drop utf16n <encoder> ;
: alien>native-string ( alien -- string )
os windows? [ utf16n ] [ utf8 ] if alien>string ;
HOOK: native-string>alien os ( string -- alien )
: dll-path ( dll -- string )
path>> alien>native-string ;
: string>symbol ( str -- alien )
[ os wince? [ utf16n ] [ utf8 ] if string>alien ]
over string? [ call ] [ map ] if ;
dup string?
[ native-string>alien ]
[ [ native-string>alien ] map ] if ;
{ "char*" utf8 } "char*" typedef
{ "char*" utf16n } "wchar_t*" typedef
"char*" "uchar*" typedef
{
{ [ os windows? ] [ "alien.strings.windows" require ] }
{ [ os unix? ] [ "alien.strings.unix" require ] }
} cond

8
basis/alien/strings/unix/unix.factor Normal file
View File

@ -0,0 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings io.encodings.utf8 system ;
IN: alien.strings.unix
M: unix alien>native-string utf8 alien>string ;
M: unix native-string>alien utf8 string>alien ;

13
basis/alien/strings/windows/windows.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings alien.c-types io.encodings.utf8
io.encodings.utf16n system ;
IN: alien.strings.windows
M: windows alien>native-string utf16n alien>string ;
M: wince native-string>alien utf16n string>alien ;
M: winnt native-string>alien utf8 string>alien ;
{ "char*" utf16n } "wchar_t*" typedef

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 ;
[ "-" glue ] 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) ;

15
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" } }
@ -83,12 +77,17 @@ HELP: C-ENUM:
{ $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
} ;
HELP: &:
{ $syntax "&: symbol" }
{ $values { "symbol" "A C library symbol name" } }
{ $description "Pushes the address of a symbol named " { $snippet "symbol" } " from the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
HELP: typedef
{ $values { "old" "a string" } { "new" "a string" } }
{ $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" } }

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

@ -3,36 +3,10 @@
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 ;
effects assocs combinators lexer strings.parser alien.parser
fry ;
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,29 +23,18 @@ 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*
{
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
: &:
scan "c-library" get
'[ _ _ load-library dlsym ] over push-all ; parsing

17
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.custom 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>
@ -74,19 +73,19 @@ M: bit-array byte-length length 7 + -3 shift ;
:: integer>bit-array ( n -- bit-array )
n zero? [ 0 <bit-array> ] [
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
[ n' zero? not ] [
[ n' zero? ] [
n' out underlying>> i set-alien-unsigned-1
n' -8 shift n'!
i 1+ i!
] [ ] while
] [ ] until
out
]
] 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

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable bit-arrays prettyprint.backend
sequences.private growable bit-arrays prettyprint.custom
parser accessors ;
IN: bit-vectors

8
basis/bootstrap/bootstrap-error.factor Normal file
View File

@ -0,0 +1,8 @@
USING: continuations kernel io debugger vocabs words system namespaces ;
:c
:error
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
1 exit

13
basis/bootstrap/compiler/compiler.factor
View File

@ -5,17 +5,22 @@ sequences namespaces parser kernel kernel.private classes
classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io
io.encodings.string prettyprint libc splitting math.parser
io.encodings.string libc splitting math.parser
compiler.units math.order compiler.tree.builder
compiler.tree.optimizer compiler.cfg.optimizer ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
! reference to 'eval' in a global variable
"deploy-vocab" get [
"deploy-vocab" get "staging" get or [
"alien.remote-control" require
] unless
"prettyprint" vocab [
"stack-checker.errors.prettyprint" require
"alien.prettyprint" require
] when
"cpu." cpu name>> append require
enable-compiler
@ -60,7 +65,7 @@ nl
"." write flush
{
new-sequence nth push pop peek
new-sequence nth push pop peek flip
} compile-uncompiled
"." write flush
@ -86,7 +91,7 @@ nl
"." write flush
{
. malloc calloc free memcpy
malloc calloc free memcpy
} compile-uncompiled
"." write flush

16
basis/bootstrap/finish-bootstrap.factor Normal file
View File

@ -0,0 +1,16 @@
USING: init command-line debugger system continuations
namespaces eval kernel vocabs.loader io ;
[
boot
do-init-hooks
[
(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
] set-boot-quot

10
basis/bootstrap/finish-staging.factor Normal file
View File

@ -0,0 +1,10 @@
USING: init command-line system namespaces kernel vocabs.loader
io ;
[
boot
do-init-hooks
(command-line) parse-command-line
"run" get run
output-stream get [ stream-flush ] when*
] set-boot-quot

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 ;

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

@ -23,7 +23,7 @@ IN: bootstrap.image
os name>> cpu name>> arch ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
"boot." ".image" surround ;
: my-boot-image-name ( -- string )
my-arch boot-image-name ;
@ -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,12 +124,18 @@ 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
@ -139,8 +145,8 @@ 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 }
@ -149,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 }
@ -160,8 +166,17 @@ SYMBOL: undefined-quot
{ 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 ;
@ -190,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.
@ -336,7 +351,12 @@ M: wrapper '
: pad-bytes ( seq -- newseq )
dup length bootstrap-cell align 0 pad-right ;
: check-string ( string -- )
[ 127 > ] contains?
[ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
: emit-string ( string -- ptr )
dup check-string
string type-number object tag-number [
dup length emit-fixnum
f ' emit
@ -443,6 +463,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
@ -451,12 +474,18 @@ 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

4
basis/bootstrap/math/math.factor
View File

@ -1,5 +1,7 @@
USE: vocabs.loader
USING: vocabs vocabs.loader kernel ;
"math.ratios" require
"math.floats" require
"math.complex" require
"prettyprint" vocab [ "math.complex.prettyprint" require ] when

42
basis/bootstrap/stage2.factor
View File

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors init namespaces words io
kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint
io.backend system parser vocabs sequences
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units
math.parser generic sets debugger command-line ;
math.parser generic sets command-line ;
IN: bootstrap.stage2
SYMBOL: core-bootstrap-time
@ -32,7 +32,7 @@ SYMBOL: bootstrap-time
: count-words ( pred -- )
all-words swap count number>string write ;
: print-time ( time -- )
: print-time ( ms -- )
1000 /i
60 /mod swap
number>string write
@ -59,15 +59,15 @@ SYMBOL: bootstrap-time
"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
@ -86,30 +86,22 @@ SYMBOL: bootstrap-time
f error set-global
f error-continuation set-global
millis swap - bootstrap-time set-global
print-report
"deploy-vocab" get [
"tools.deploy.shaker" run
] [
[
boot
do-init-hooks
[
parse-command-line
run-user-init
"run" get run
output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover
] set-boot-quot
millis swap - bootstrap-time set-global
print-report
"staging" get [
"resource:basis/bootstrap/finish-staging.factor" run-file
] [
"resource:basis/bootstrap/finish-bootstrap.factor" run-file
] if
"output-image" get save-image-and-exit
] if
] [
:c
dup print-error flush
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
1 exit
drop
load-help? off
"resource:basis/bootstrap/bootstrap-error.factor" run-file
] recover

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

@ -1,7 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs vocabs.loader kernel ;
IN: bootstrap.threads
USE: io.thread
USE: threads
USE: debugger.threads
"debugger" vocab [
"debugger.threads" require
] when

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

0
core/byte-vectors/byte-vectors-docs.factor → basis/byte-vectors/byte-vectors-docs.factor
View File

0
core/byte-vectors/byte-vectors-tests.factor → basis/byte-vectors/byte-vectors-tests.factor
View File

51
basis/byte-vectors/byte-vectors.factor Normal file
View File

@ -0,0 +1,51 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
sequences.private growable byte-arrays accessors parser
prettyprint.custom ;
IN: byte-vectors
TUPLE: byte-vector
{ underlying byte-array }
{ length array-capacity } ;
: <byte-vector> ( n -- byte-vector )
(byte-array) 0 byte-vector boa ; inline
: >byte-vector ( seq -- byte-vector )
T{ byte-vector f B{ } 0 } clone-like ;
M: byte-vector like
drop dup byte-vector? [
dup byte-array?
[ dup length byte-vector boa ] [ >byte-vector ] if
] unless ;
M: byte-vector new-sequence
drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;
M: byte-vector equal?
over byte-vector? [ sequence= ] [ 2drop f ] if ;
M: byte-array like
#! If we have an byte-array, we're done.
#! If we have a byte-vector, and it's at full capacity,
#! we're done. Otherwise, call resize-byte-array, which is a
#! relatively fast primitive.
drop dup byte-array? [
dup byte-vector? [
[ length ] [ underlying>> ] bi
2dup length eq?
[ nip ] [ resize-byte-array ] if
] [ >byte-array ] if
] unless ;
M: byte-array new-resizable drop <byte-vector> ;
: BV{ \ } [ >byte-vector ] parse-literal ; parsing
M: byte-vector pprint* pprint-object ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
M: byte-vector >pprint-sequence ;
INSTANCE: byte-vector growable

0
core/byte-vectors/summary.txt → basis/byte-vectors/summary.txt
View File

0
basis/float-arrays/tags.txt → basis/byte-vectors/tags.txt
View File

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

@ -365,12 +365,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"
}
} ;

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

35
basis/calendar/calendar.factor
View File

@ -173,7 +173,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 +181,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 +191,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 +200,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 +209,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 +226,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 +284,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 +320,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 +343,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 +411,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 ;

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

@ -1,7 +1,8 @@
USING: math math.order math.parser math.functions kernel sequences io
accessors arrays io.streams.string splitting
combinators accessors debugger
calendar calendar.format.macros ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order math.parser math.functions kernel
sequences io accessors arrays io.streams.string splitting
combinators accessors calendar calendar.format.macros present ;
IN: calendar.format
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;
@ -138,11 +139,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 +153,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 +183,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 )
@ -287,3 +289,5 @@ ERROR: invalid-timestamp-format ;
]
} formatted
] with-string-writer ;
M: timestamp present timestamp>string ;

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

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

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

@ -4,7 +4,7 @@ USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting grouping strings
sequences byte-arrays locals sequences.private
io.encodings.binary symbols math.bitwise checksums
checksums.common ;
checksums.common checksums.stream ;
IN: checksums.md5
! See http://www.faqs.org/rfcs/rfc1321.html
@ -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
@ -180,7 +180,7 @@ PRIVATE>
SINGLETON: md5
INSTANCE: md5 checksum
INSTANCE: md5 stream-checksum
M: md5 checksum-stream ( stream -- byte-array )
drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;

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

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types kernel continuations
destructors sequences io openssl openssl.libcrypto checksums ;
destructors sequences io openssl openssl.libcrypto checksums
checksums.stream ;
IN: checksums.openssl
ERROR: unknown-digest name ;
@ -12,7 +13,7 @@ TUPLE: openssl-checksum name ;
: openssl-sha1 T{ openssl-checksum f "sha1" } ;
INSTANCE: openssl-checksum checksum
INSTANCE: openssl-checksum stream-checksum
C: <openssl-checksum> openssl-checksum
@ -28,7 +29,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

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

@ -3,7 +3,8 @@
USING: arrays combinators kernel io io.encodings.binary io.files
io.streams.byte-array math.vectors strings sequences namespaces
make math parser sequences assocs grouping vectors io.binary
hashtables symbols math.bitwise checksums checksums.common ;
hashtables symbols math.bitwise checksums checksums.common
checksums.stream ;
IN: checksums.sha1
! Implemented according to RFC 3174.
@ -41,9 +42,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 ;
@ -113,7 +114,7 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
SINGLETON: sha1
INSTANCE: sha1 checksum
INSTANCE: sha1 stream-checksum
M: sha1 checksum-stream ( stream -- sha1 )
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;

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

12
basis/checksums/stream/stream.factor Normal file
View File

@ -0,0 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.binary io.streams.byte-array kernel
checksums ;
IN: checksums.stream
MIXIN: stream-checksum
M: stream-checksum checksum-bytes
[ binary <byte-reader> ] dip checksum-stream ;
INSTANCE: stream-checksum checksum

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

@ -1,5 +1,5 @@
USING: debugger quotations help.markup help.syntax strings alien
core-foundation ;
core-foundation core-foundation.strings core-foundation.arrays ;
IN: cocoa.application
HELP: <NSString>

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

@ -1,8 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.run-loop cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads debugger init summary
core-foundation.run-loop core-foundation.arrays
core-foundation.data core-foundation.strings cocoa.messages
cocoa cocoa.classes cocoa.runtime sequences threads init summary
kernel.private assocs ;
IN: cocoa.application
@ -27,35 +28,31 @@ IN: cocoa.application
: NSApp ( -- app ) NSApplication -> sharedApplication ;
: NSAnyEventMask ( -- mask ) HEX: ffffffff ; inline
FUNCTION: void NSBeep ( ) ;
: with-cocoa ( quot -- )
[ NSApp drop call ] with-autorelease-pool ; inline
: next-event ( app -- event )
0 f CFRunLoopDefaultMode 1
NSAnyEventMask f CFRunLoopDefaultMode 1
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
: do-event ( app -- ? )
dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
dup next-event [ dupd -> sendEvent: -> updateWindows 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 ;
: cocoa-app ( quot -- )
[
call
finish-launching
NSApp -> run
] with-cocoa ; inline
: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
@ -80,6 +77,6 @@ M: objc-error summary ( error -- )
running.app? [
drop
] [
"The " swap " requires you to run Factor from an application bundle."
3append throw
"The " " requires you to run Factor from an application bundle."
surround throw
] if ;

26
basis/cocoa/cocoa-tests.factor
View File

@ -1,7 +1,7 @@
IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory
compiler.units ;
compiler.units math ;
CLASS: {
{ +superclass+ "NSObject" }
@ -45,3 +45,27 @@ Bar [
[ 2.0 ] [ "x" get NSRect-y ] unit-test
[ 101.0 ] [ "x" get NSRect-w ] unit-test
[ 102.0 ] [ "x" get NSRect-h ] unit-test
! Make sure that we can add methods
CLASS: {
{ +superclass+ "NSObject" }
{ +name+ "Bar" }
} {
"bar"
"NSRect"
{ "id" "SEL" }
[ 2drop test-foo "x" get ]
} {
"babb"
"int"
{ "id" "SEL" "int" }
[ 2nip sq ]
} ;
[ 144 ] [
Bar [
-> alloc -> init
dup 12 -> babb
swap -> release
] compile-call
] unit-test

4
basis/cocoa/cocoa.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
core-foundation namespaces assocs hashtables compiler.units
lexer init ;
core-foundation.bundles namespaces assocs hashtables
compiler.units lexer init ;
IN: cocoa
: (remember-send) ( selector variable -- )

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

@ -1,7 +1,8 @@
! 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 ;
cocoa.application sequences splitting core-foundation
core-foundation.strings ;
IN: cocoa.dialogs
: <NSOpenPanel> ( -- panel )
@ -26,9 +27,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>

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

@ -1,21 +1,18 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
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 ;
continuations combinators compiler compiler.alien kernel math
namespaces make parser quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private parser lexer init core-foundation fry
generalizations specialized-arrays.direct.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )
[ over first , f , , second , \ alien-invoke , ] [ ] make ;
: sender-stub-name ( method function -- string )
[ % "_" % unparse % ] "" make ;
: sender-stub ( method function -- word )
[ sender-stub-name f <word> dup ] 2keep
[ "( sender-stub )" f <word> dup ] 2dip
over first large-struct? [ "_stret" append ] when
make-sender define ;
@ -27,7 +24,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 +34,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,36 +59,35 @@ 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
\ send soft "break-after" set-word-prop
: super-send ( receiver args... selector -- return... ) t (send) ; inline
\ super-send soft "break-after" set-word-prop
! Runtime introspection
: (objc-class) ( string word -- class )
dupd execute
[ ] [ "No such class: " prepend throw ] ?if ; inline
SYMBOL: class-init-hooks
class-init-hooks global [ H{ } clone or ] change-at
: (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [
drop over class-init-hooks get at [ assert-depth ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
] if ; inline
: objc-class ( string -- class )
\ objc_getClass (objc-class) ;
@ -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 ] }
@ -184,7 +180,7 @@ assoc-union alien>objc-types set-global
: method-arg-type ( method i -- type )
method_copyArgumentType
[ ascii alien>string parse-objc-type ] keep
[ utf8 alien>string parse-objc-type ] keep
(free) ;
: method-arg-types ( method -- args )
@ -193,7 +189,7 @@ assoc-union alien>objc-types set-global
: method-return-type ( method -- ctype )
method_copyReturnType
[ ascii alien>string parse-objc-type ] keep
[ utf8 alien>string parse-objc-type ] keep
(free) ;
: register-objc-method ( method -- )
@ -203,42 +199,28 @@ 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 ;
: method. ( method -- )
{
[ method_getName sel_getName ]
[ method-return-type ]
[ method-arg-types ]
[ method_getImplementation ]
} cleave 4array . ;
: methods. ( class -- )
[ method. ] each-method-in-class ;
: class-exists? ( string -- class ) objc_getClass >boolean ;
: unless-defined ( class quot -- )
>r class-exists? r> unless ; inline
: define-objc-class-word ( name quot -- )
: define-objc-class-word ( quot name -- )
[ class-init-hooks get set-at ]
[
over , , \ unless-defined , dup , \ objc-class ,
] [ ] make >r "cocoa.classes" create r>
(( -- class )) define-declared ;
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
(( -- class )) define-declared
] bi ;
: 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 ;
over define-objc-class-word
[ objc-class register-objc-methods ]
[ objc-meta-class register-objc-methods ] bi ;
: root-class ( class -- root )
dup class_getSuperclass [ root-class ] [ ] ?if ;

7
basis/cocoa/nibs/nibs.factor
View File

@ -1,5 +1,8 @@
USING: cocoa.application cocoa.messages cocoa.classes cocoa.runtime
kernel cocoa core-foundation alien.c-types ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa.application cocoa.messages cocoa.classes
cocoa.runtime kernel cocoa alien.c-types core-foundation
core-foundation.arrays ;
IN: cocoa.nibs
: load-nib ( name -- )

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 sequences cocoa core-foundation
core-foundation.strings core-foundation.arrays ;
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/plists/plists.factor
View File

@ -3,7 +3,7 @@
USING: strings arrays hashtables assocs sequences
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
combinators alien.c-types core-foundation ;
combinators alien.c-types core-foundation core-foundation.data ;
IN: cocoa.plists
GENERIC: >plist ( value -- plist )

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

@ -1,33 +1,35 @@
! Copyright (C) 2006, 2008 Slava Pestov
! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
parser sequences words cocoa.messages cocoa.runtime
compiler.units io.encodings.ascii generalizations
continuations make ;
parser sequences words cocoa.messages cocoa.runtime locals
compiler.units io.encodings.utf8 continuations make fry ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
first3 swap
[ sel_registerName ] [ execute ] [ ascii string>alien ]
[ sel_registerName ] [ execute ] [ utf8 string>alien ]
tri* ;
: throw-if-false ( YES/NO -- )
zero? [ "Failed to add method or protocol to class" throw ]
when ;
: throw-if-false ( obj what -- )
swap { f 0 } member?
[ "Failed to " prepend throw ] [ drop ] if ;
: add-method ( class sel imp types -- )
class_addMethod "add method to class" throw-if-false ;
: add-methods ( methods class -- )
swap
[ init-method class_addMethod throw-if-false ] with each ;
'[ [ _ ] dip init-method add-method ] each ;
: add-protocol ( class protocol -- )
class_addProtocol "add protocol to class" throw-if-false ;
: add-protocols ( protocols class -- )
swap [ objc-protocol class_addProtocol throw-if-false ]
with each ;
'[ [ _ ] dip objc-protocol add-protocol ] each ;
: (define-objc-class) ( protocols superclass name imeth -- )
-rot
: (define-objc-class) ( imeth protocols superclass name -- )
[ objc-class ] dip 0 objc_allocateClassPair
[ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
[ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
tri ;
: encode-types ( return types -- encoding )
@ -36,7 +38,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 ;
@ -45,28 +47,19 @@ IN: cocoa.subclassing
[ first4 prepare-method 3array ] map
] with-compilation-unit ;
: types= ( a b -- ? )
[ ascii alien>string ] bi@ = ;
: (verify-method-type) ( class sel types -- )
[ class_getInstanceMethod method_getTypeEncoding ]
dip types=
[ "Objective-C method types cannot be changed once defined" throw ]
unless ;
: verify-method-type ( class sel imp types -- class sel imp types )
4 ndup nip (verify-method-type) ;
: (redefine-objc-method) ( class method -- )
init-method ! verify-method-type
drop
[ class_getInstanceMethod ] dip method_setImplementation drop ;
:: (redefine-objc-method) ( class method -- )
method init-method [| sel imp types |
class sel class_getInstanceMethod [
imp method_setImplementation drop
] [
class sel imp types add-method
] if*
] call ;
: redefine-objc-methods ( imeth name -- )
dup class-exists? [
objc_getClass swap [ (redefine-objc-method) ] with each
] [
2drop
] if ;
objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
] [ 2drop ] if ;
SYMBOL: +name+
SYMBOL: +protocols+
@ -76,10 +69,10 @@ SYMBOL: +superclass+
clone [
prepare-methods
+name+ get "cocoa.classes" create drop
+name+ get 2dup redefine-objc-methods swap [
+protocols+ get , +superclass+ get , +name+ get , ,
\ (define-objc-class) ,
] [ ] make import-objc-class
+name+ get 2dup redefine-objc-methods swap
+protocols+ get +superclass+ get +name+ get
'[ _ _ _ _ (define-objc-class) ]
import-objc-class
] bind ;
: CLASS:

29
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 ;
@ -55,10 +55,9 @@ PRIVATE>
: with-multisample ( quot -- )
t +multisample+ pick with-variable ; inline
: <PixelFormat> ( -- pixelfmt )
NSOpenGLPixelFormat -> alloc [
NSOpenGLPFAWindow ,
NSOpenGLPFADoubleBuffer ,
: <PixelFormat> ( attributes -- pixelfmt )
NSOpenGLPixelFormat -> alloc swap [
%
NSOpenGLPFADepthSize , 16 ,
+software-renderer+ get [
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
@ -69,12 +68,13 @@ 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>
NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <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|| ] ;

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

@ -1,4 +1,5 @@
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
@ -7,7 +8,10 @@ HELP: run-bootstrap-init
HELP: run-user-init
{ $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
@ -64,9 +68,12 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
}
"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." }
@ -86,7 +93,6 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
{ { $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 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: "factor-boot-rc" "Bootstrap initialization file"
@ -102,11 +108,18 @@ $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 two files in your home directory."
"Factor looks for three optional files in your home directory."
{ $subsection "factor-boot-rc" }
{ $subsection "factor-rc" }
"The " { $snippet "-no-user-init" } " command line switch will inhibit the running of these files."
{ $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
@ -122,8 +135,16 @@ $nl
"100 dpi set-global"
} ;
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: "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
@ -134,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

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

@ -1,10 +1,15 @@
! 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 hashtables io io.encodings.utf8
io.files kernel kernel.private namespaces parser sequences
strings system splitting 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 ;
@ -19,17 +24,29 @@ IN: command-line
"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 ;
: var-param ( name value -- ) swap set-global ;
: cli-param ( param -- )
"=" split1 [ cli-var-param ] [ cli-bool-param ] if* ;
: bool-param ( name -- ) "no-" ?head not var-param ;
: cli-arg ( argument -- argument )
"-" ?head [ cli-param f ] when ;
: param ( param -- )
"=" split1 [ var-param ] [ bool-param ] if* ;
: cli-args ( -- args ) 10 getenv ;
: run-script ( file -- )
t "quiet" set-global run-file ;
: 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
@ -53,14 +70,6 @@ SYMBOL: main-vocab-hook
: ignore-cli-args? ( -- ? )
os macosx? "run" get "ui" = and ;
: script-mode ( -- )
t "quiet" set-global
"none" "run" set-global ;
: 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* ;
: script-mode ( -- ) ;
[ 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.

4
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
View File

@ -1,6 +1,6 @@
USING: compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.alias-analysis cpu.architecture tools.test
kernel ;
compiler.cfg.alias-analysis compiler.cfg.debugger
cpu.architecture tools.test kernel ;
IN: compiler.cfg.alias-analysis.tests
[ ] [

7
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences
USING: kernel math namespaces assocs hashtables sequences arrays
accessors vectors combinators sets classes compiler.cfg
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.copy-prop ;
@ -194,6 +194,7 @@ M: ##slot insn-slot# slot>> constant ;
M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: ##peek insn-object loc>> class ;
M: ##replace insn-object loc>> class ;
@ -201,6 +202,7 @@ M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
: init-alias-analysis ( -- )
H{ } clone histories set
@ -224,6 +226,9 @@ M: ##load-immediate analyze-aliases*
M: ##load-indirect analyze-aliases*
dup dst>> set-heap-ac ;
M: ##alien-global analyze-aliases*
dup dst>> set-heap-ac ;
M: ##allot analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.

6
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
@ -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 ;
@ -262,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 ;

3
basis/compiler/cfg/dead-code/dead-code-tests.factor
View File

@ -1,5 +1,6 @@
USING: compiler.cfg.dead-code compiler.cfg.instructions
compiler.cfg.registers cpu.architecture tools.test ;
compiler.cfg.registers compiler.cfg.debugger
cpu.architecture tools.test ;
IN: compiler.cfg.dead-code.tests
[ { } ] [

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

@ -2,10 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words sequences quotations namespaces io
classes.tuple accessors prettyprint prettyprint.config
compiler.tree.builder compiler.tree.optimizer
prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.stack-frame compiler.cfg.linear-scan
compiler.cfg.two-operand compiler.cfg.optimizer ;
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.optimizer ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
@ -40,3 +42,15 @@ SYMBOL: allocate-registers?
instructions>> [ insn. ] each
nl
] each ;
! Prettyprinting
M: vreg pprint*
<block
\ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
block> ;
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
M: ds-loc pprint* \ D pprint-loc ;
M: rs-loc pprint* \ R pprint-loc ;

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

@ -12,9 +12,15 @@ 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: ##set-string-nth-fast defs-vregs temp>> 1array ;
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 ;
@ -26,11 +32,13 @@ M: ##slot-imm uses-vregs obj>> 1array ;
M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ;
M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
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 +48,7 @@ UNION: vreg-insn
##write-barrier
##dispatch
##effect
##fixnum-overflow
##conditional-branch
##compare-imm-branch
_conditional-branch

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

@ -39,6 +39,7 @@ IN: compiler.cfg.hats
: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
: ^^not ( src -- dst ) ^^i1 ##not ; inline
: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
@ -65,9 +66,10 @@ 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
: ^^alien-global ( symbol library -- dst ) ^^i2 ##alien-global ; 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

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

@ -73,6 +73,7 @@ INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
! String element access
INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ;
! Integer arithmetic
INSN: ##add < ##commutative ;
@ -91,6 +92,16 @@ INSN: ##shl-imm < ##binary-imm ;
INSN: ##shr-imm < ##binary-imm ;
INSN: ##sar-imm < ##binary-imm ;
INSN: ##not < ##unary ;
INSN: ##log2 < ##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
@ -151,6 +162,8 @@ INSN: ##set-alien-double < ##alien-setter ;
INSN: ##allot < ##flushable size class { temp vreg } ;
INSN: ##write-barrier < ##effect card# table ;
INSN: ##alien-global < ##read symbol library ;
! FFI
INSN: ##alien-invoke params ;
INSN: ##alien-indirect params ;
@ -198,11 +211,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 ;

28
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -54,15 +54,19 @@ IN: compiler.cfg.intrinsics.allot
: bytes>cells ( m -- n ) cell align cell /i ;
:: emit-<byte-array> ( node -- )
[let | len [ node node-input-infos first literal>> ] |
len expand-<byte-array>? [
[let | elt [ 0 ^^load-literal ]
reg [ len ^^allot-byte-array ] |
ds-drop
len reg store-length
elt reg len bytes>cells store-initial-element
reg ds-push
]
] [ node emit-primitive ] if
] ;
: emit-allot-byte-array ( len -- dst )
ds-drop
dup ^^allot-byte-array
[ store-length ] [ ds-push ] [ ] tri ;
: emit-(byte-array) ( node -- )
dup node-input-infos first literal>> dup expand-<byte-array>?
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
: emit-<byte-array> ( node -- )
dup node-input-infos first literal>> dup expand-<byte-array>? [
nip
[ 0 ^^load-literal ] dip
[ emit-allot-byte-array ] keep
bytes>cells store-initial-element
] [ drop emit-primitive ] if ;

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

@ -3,10 +3,21 @@
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? ( -- )
2inputs
^^or
tag-mask get ^^and-imm
0 cc= ^^compare-imm
ds-push ;
: (emit-fixnum-imm-op) ( infos insn -- dst )
ds-drop
[ ds-pop ]
@ -42,6 +53,9 @@ IN: compiler.cfg.intrinsics.fixnum
: emit-fixnum-bitnot ( -- )
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
: emit-fixnum-log2 ( -- )
ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
: (emit-fixnum*fast) ( -- dst )
2inputs ^^untag-fixnum ^^mul ;
@ -64,3 +78,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

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

@ -8,7 +8,9 @@ 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.intrinsics.misc
compiler.cfg.iterator ;
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
@ -17,11 +19,17 @@ QUALIFIED: slots.private
QUALIFIED: strings.private
QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: math.integers.private
QUALIFIED: alien.accessors
IN: compiler.cfg.intrinsics
{
kernel.private:tag
kernel.private:getenv
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
@ -40,9 +48,11 @@ IN: compiler.cfg.intrinsics
slots.private:slot
slots.private:set-slot
strings.private:string-nth
strings.private:set-string-nth-fast
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
byte-arrays:(byte-array)
math.private:<complex>
math.private:<ratio>
kernel:<wrapper>
@ -85,60 +95,71 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
: emit-intrinsic ( node word -- )
: enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
: 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 ] }
{ \ kernel.private:getenv [ emit-getenv 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.integers.private:fixnum-log2 [ drop emit-fixnum-log2 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 ] }
{ \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast 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 ] }
{ \ 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 ;

16
basis/compiler/cfg/intrinsics/misc/misc.factor Normal file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces layouts sequences kernel
accessors compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.misc
: emit-tag ( -- )
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
: emit-getenv ( node -- )
"userenv" f ^^alien-global
swap node-input-infos first literal>>
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
ds-push ;

7
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -6,9 +6,6 @@ compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.slots
: emit-tag ( -- )
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
: value-tag ( info -- n ) class>> class-tag ; inline
: (emit-slot) ( infos -- dst )
@ -54,3 +51,7 @@ IN: compiler.cfg.intrinsics.slots
: emit-string-nth ( -- )
2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
: emit-set-string-nth-fast ( -- )
3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
swap i ##set-string-nth-fast ;

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

@ -1,7 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel arrays
parser prettyprint.backend prettyprint.sections ;
USING: accessors namespaces kernel arrays parser ;
IN: compiler.cfg.registers
! Virtual registers, used by CFG and machine IRs
@ -18,20 +17,6 @@ C: <ds-loc> ds-loc
TUPLE: rs-loc < loc ;
C: <rs-loc> rs-loc
! Prettyprinting
: V scan-word scan-word vreg boa parsed ; parsing
M: vreg pprint*
<block
\ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
block> ;
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
: D scan-word <ds-loc> parsed ; parsing
M: ds-loc pprint* \ D pprint-loc ;
: R scan-word <rs-loc> parsed ; parsing
M: rs-loc pprint* \ R pprint-loc ;

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

4
basis/compiler/cfg/two-operand/two-operand.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel sequences sequences.deep
USING: accessors arrays kernel sequences compiler.utilities
compiler.cfg.instructions cpu.architecture ;
IN: compiler.cfg.two-operand
@ -55,6 +55,6 @@ M: insn convert-two-operand* ;
: convert-two-operand ( mr -- mr' )
[
two-operand? [
[ convert-two-operand* ] map flatten
[ convert-two-operand* ] map-flat
] when
] change-instructions ;

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 ;

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

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences layouts accessors combinators namespaces
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 ;

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

@ -1,6 +1,18 @@
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 compiler.cfg.debugger 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 }
@ -82,7 +94,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 +112,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 +134,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 +150,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

3
basis/compiler/cfg/write-barrier/write-barrier-tests.factor
View File

@ -1,5 +1,6 @@
USING: compiler.cfg.write-barrier compiler.cfg.instructions
compiler.cfg.registers cpu.architecture arrays tools.test ;
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
arrays tools.test ;
IN: compiler.cfg.write-barrier.tests
[

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

@ -131,6 +131,14 @@ M: ##string-nth generate-insn
[ temp>> register ]
} cleave %string-nth ;
M: ##set-string-nth-fast generate-insn
{
[ src>> register ]
[ obj>> register ]
[ index>> register ]
[ temp>> register ]
} cleave %set-string-nth-fast ;
: dst/src ( insn -- dst src )
[ dst>> register ] [ src>> register ] bi ; inline
@ -155,6 +163,20 @@ M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
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 ;
M: ##log2 generate-insn dst/src %log2 ;
: 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
@ -215,6 +237,10 @@ M: _gc generate-insn drop %gc ;
M: ##loop-entry generate-insn drop %loop-entry ;
M: ##alien-global generate-insn
[ dst>> register ] [ symbol>> ] [ library>> ] tri
%alien-global ;
! ##alien-invoke
GENERIC: reg-size ( register-class -- n )
@ -235,7 +261,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 +290,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 +326,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 +342,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 )
@ -432,7 +456,7 @@ M: ##alien-indirect generate-insn
TUPLE: callback-context ;
: current-callback 2 getenv ;
: current-callback ( -- id ) 2 getenv ;
: wait-to-return ( token -- )
dup current-callback eq? [
@ -491,9 +515,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 ]

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

@ -1,15 +1,15 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces make sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitwise words.private math.order accessors
growable cpu.architecture compiler.constants ;
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise words.private math.order
accessors growable cpu.architecture compiler.constants ;
IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )
: code-format 22 getenv ;
: code-format ( -- n ) 22 getenv ;
: compiled-offset ( -- n ) building get length code-format * ;
@ -46,28 +46,27 @@ 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 ;

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:"

25
basis/compiler/compiler.factor
View File

@ -1,15 +1,14 @@
! 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
prettyprint io stack-checker stack-checker.state
stack-checker.inlining compiler.errors compiler.units
compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.linear-scan compiler.cfg.stack-frame
compiler.codegen ;
USING: accessors kernel namespaces arrays sequences io
words fry continuations vocabs assocs dlists definitions math
threads graphs generic combinators deques search-deques io
stack-checker stack-checker.state stack-checker.inlining
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder
compiler.cfg.optimizer compiler.cfg.linearization
compiler.cfg.two-operand compiler.cfg.linear-scan
compiler.cfg.stack-frame compiler.codegen ;
IN: compiler
SYMBOL: compile-queue
@ -45,7 +44,7 @@ SYMBOL: +failed+
2bi ;
: start ( word -- )
"trace-compilation" get [ dup . flush ] when
"trace-compilation" get [ dup name>> print flush ] when
H{ } clone dependencies set
H{ } clone generic-dependencies set
f swap compiler-error ;
@ -91,8 +90,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 ;

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

@ -39,13 +39,12 @@ IN: compiler.constants
! 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-stack-chain 8 ; 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 = ]

31
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
@ -82,14 +83,14 @@ FUNCTION: tiny ffi_test_17 int x ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
"int" { } "cdecl" alien-indirect drop ;
{ 1 0 } [ indirect-test-1' ] must-infer-as
[ ] [ "ffi_test_1" f dlsym indirect-test-1' ] unit-test
[ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
[ -1 indirect-test-1 ] must-fail
@ -99,7 +100,7 @@ FUNCTION: tiny ffi_test_17 int x ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
[ 5 ]
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
[ 2 3 &: ffi_test_2 indirect-test-2 ]
unit-test
: indirect-test-3 ( a b c d ptr -- result )
@ -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

37
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
@ -241,3 +241,38 @@ TUPLE: id obj ;
[ "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

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