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

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

db4
Bruno Deferrari 2008-04-27 21:13:15 -03:00
parent 915e65fa7f 32814ffce5
commit 95df9a295d
493 changed files with 5120 additions and 4099 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -2,6 +2,7 @@
_darcs
*.obj
*.o
*.s
*.exe
Factor/factor
*.a

2
build-support/factor.sh
View File

@ -439,7 +439,7 @@ install_build_system_port() {
}
usage() {
echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap|make-target"
echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target"
echo "If you are behind a firewall, invoke as:"
echo "env GIT_PROTOCOL=http $0 <command>"
}

6
core/alien/alien.factor
View File

@ -28,12 +28,6 @@ M: f expired? drop t ;
: <alien> ( address -- alien )
f <displaced-alien> { simple-c-ptr } declare ; inline
: alien>native-string ( alien -- string )
os windows? [ alien>u16-string ] [ alien>char-string ] if ;
: dll-path ( dll -- string )
(dll-path) alien>native-string ;
M: alien equal?
over alien? [
2dup [ expired? ] either? [

6
core/alien/arrays/arrays-docs.factor
View File

@ -18,7 +18,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
{ $subsection >c-ushort-array }
{ $subsection >c-void*-array }
{ $subsection c-bool-array> }
{ $subsection c-char*-array> }
{ $subsection c-char-array> }
{ $subsection c-double-array> }
{ $subsection c-float-array> }
@ -30,7 +29,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
{ $subsection c-uint-array> }
{ $subsection c-ulong-array> }
{ $subsection c-ulonglong-array> }
{ $subsection c-ushort*-array> }
{ $subsection c-ushort-array> }
{ $subsection c-void*-array> } ;
@ -61,9 +59,7 @@ ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
{ $subsection double-nth }
{ $subsection set-double-nth }
{ $subsection void*-nth }
{ $subsection set-void*-nth }
{ $subsection char*-nth }
{ $subsection ushort*-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" } "."

9
core/alien/arrays/arrays.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays alien.c-types alien.structs
sequences math kernel generator.registers
namespaces libc ;
sequences math kernel namespaces libc cpu.architecture ;
IN: alien.arrays
UNION: value-type array struct-type ;
@ -27,7 +26,9 @@ M: array stack-size drop "void*" stack-size ;
M: value-type c-type-reg-class drop int-regs ;
M: value-type c-type-prep drop f ;
M: value-type c-type-boxer-quot drop f ;
M: value-type c-type-unboxer-quot drop f ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;

56
core/alien/c-types/c-types-docs.factor
View File

@ -62,28 +62,6 @@ HELP: <c-object>
{ <c-object> malloc-object } related-words
HELP: string>char-alien ( string -- array )
{ $values { "string" string } { "array" byte-array } }
{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." } ;
{ string>char-alien alien>char-string malloc-char-string } related-words
HELP: alien>char-string ( c-ptr -- string )
{ $values { "c-ptr" c-ptr } { "string" string } }
{ $description "Reads a null-terminated 8-bit C string from the specified address." } ;
HELP: string>u16-alien ( string -- array )
{ $values { "string" string } { "array" byte-array } }
{ $description "Copies the string to a new byte array in UCS-2 format with a trailing null byte." }
{ $errors "Throws an error if the string contains null characters." } ;
{ string>u16-alien alien>u16-string malloc-u16-string } related-words
HELP: alien>u16-string ( c-ptr -- string )
{ $values { "c-ptr" c-ptr } { "string" string } }
{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
HELP: memory>byte-array
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
@ -111,18 +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: malloc-char-string
{ $values { "string" string } { "alien" c-ptr } }
{ $description "Allocates an unmanaged memory block, and stores a string in 8-bit ASCII encoding with a trailing null byte to the block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
HELP: malloc-u16-string
{ $values { "string" string } { "alien" c-ptr } }
{ $description "Allocates an unmanaged memory block, and stores a string in UCS2 encoding with a trailing null character to the block." }
{ $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." }
@ -202,8 +168,6 @@ $nl
{ $subsection *float }
{ $subsection *double }
{ $subsection *void* }
{ $subsection *char* }
{ $subsection *ushort* }
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
ARTICLE: "c-types-specs" "C type specifiers"
@ -267,26 +231,6 @@ $nl
"A wrapper for temporarily allocating a block of memory:"
{ $subsection with-malloc } ;
ARTICLE: "c-strings" "C strings"
"The C library interface defines two types of C strings:"
{ $table
{ "C type" "Notes" }
{ { $snippet "char*" } "8-bit per character null-terminated ASCII" }
{ { $snippet "ushort*" } "16-bit per character null-terminated UCS-2" }
}
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>char-alien }
{ $subsection string>u16-alien }
{ $subsection malloc-char-string }
{ $subsection malloc-u16-string }
"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
{ $subsection alien>char-string }
{ $subsection alien>u16-string }
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
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."
$nl

28
core/alien/c-types/c-types-tests.factor
View File

@ -1,30 +1,6 @@
IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc ;
[ "\u0000ff" ]
[ "\u0000ff" string>char-alien alien>char-string ]
unit-test
[ "hello world" ]
[ "hello world" string>char-alien alien>char-string ]
unit-test
[ "hello\u00abcdworld" ]
[ "hello\u00abcdworld" string>u16-alien alien>u16-string ]
unit-test
[ t ] [ f expired? ] unit-test
[ "hello world" ] [
"hello world" malloc-char-string
dup alien>char-string swap free
] unit-test
[ "hello world" ] [
"hello world" malloc-u16-string
dup alien>u16-string swap free
] unit-test
sequences system libc alien.strings io.encodings.utf8 ;
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
@ -67,7 +43,7 @@ TYPEDEF: int* MyIntArray
TYPEDEF: uchar* MyLPBYTE
[ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test
[ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>

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

@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bit-arrays byte-arrays float-arrays arrays
generator.registers assocs kernel kernel.private libc math
assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
@ -14,7 +14,7 @@ DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type
boxer prep unboxer
boxer boxer-quot unboxer unboxer-quot
getter setter
reg-class size align stack-align? ;
@ -149,23 +149,12 @@ M: float-array byte-length length "double" heap-size * ;
: malloc-byte-array ( byte-array -- alien )
dup length dup malloc [ -rot memcpy ] keep ;
: malloc-char-string ( string -- alien )
string>char-alien malloc-byte-array ;
: malloc-u16-string ( string -- alien )
string>u16-alien malloc-byte-array ;
: memory>byte-array ( alien len -- byte-array )
dup <byte-array> [ -rot memcpy ] keep ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;
DEFER: >c-ushort-array
: string>u16-memory ( string base -- )
>r >c-ushort-array r> byte-array>memory ;
: (define-nth) ( word type quot -- )
>r heap-size [ rot * ] swap prefix r> append define-inline ;
@ -378,7 +367,7 @@ M: long-long-type box-return ( type -- )
"box_float" >>boxer
"to_float" >>unboxer
single-float-regs >>reg-class
[ >float ] >>prep
[ >float ] >>unboxer-quot
"float" define-primitive-type
<c-type>
@ -389,30 +378,8 @@ M: long-long-type box-return ( type -- )
"box_double" >>boxer
"to_double" >>unboxer
double-float-regs >>reg-class
[ >float ] >>prep
[ >float ] >>unboxer-quot
"double" define-primitive-type
<c-type>
[ alien-cell alien>char-string ] >>getter
[ set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
"box_char_string" >>boxer
"alien_offset" >>unboxer
[ string>char-alien ] >>prep
"char*" define-primitive-type
"char*" "uchar*" typedef
<c-type>
[ alien-cell alien>u16-string ] >>getter
[ set-alien-cell ] >>setter
4 >>size
4 >>align
"box_u16_string" >>boxer
"alien_offset" >>unboxer
[ string>u16-alien ] >>prep
"ushort*" define-primitive-type
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
] with-compilation-unit

746
core/alien/compiler/compiler-tests.factor
View File

@ -1,371 +1,375 @@
IN: alien.compiler.tests
USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects
namespaces.private io io.streams.string memory system threads
tools.test math ;
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test
FUNCTION: int ffi_test_1 ;
[ 3 ] [ ffi_test_1 ] unit-test
FUNCTION: int ffi_test_2 int x int y ;
[ 5 ] [ 2 3 ffi_test_2 ] unit-test
[ "hi" 3 ffi_test_2 ] must-fail
FUNCTION: int ffi_test_3 int x int y int z int t ;
[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
FUNCTION: float ffi_test_4 ;
[ 1.5 ] [ ffi_test_4 ] unit-test
FUNCTION: double ffi_test_5 ;
[ 1.5 ] [ ffi_test_5 ] unit-test
FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
C-STRUCT: foo
{ "int" "x" }
{ "int" "y" }
;
: make-foo ( x y -- foo )
"foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
FUNCTION: int ffi_test_11 int a foo b int c ;
[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
FUNCTION: foo ffi_test_14 int x int y ;
[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
FUNCTION: char* ffi_test_15 char* x char* y ;
[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
[ 1 2 ffi_test_15 ] must-fail
C-STRUCT: bar
{ "long" "x" }
{ "long" "y" }
{ "long" "z" }
;
FUNCTION: bar ffi_test_16 long x long y long z ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
] unit-test
C-STRUCT: tiny
{ "int" "x" }
;
FUNCTION: tiny ffi_test_17 int x ;
[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1
"int" { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
[ -1 indirect-test-1 ] must-fail
: indirect-test-2
"int" { "int" "int" } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
[ 5 ]
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
unit-test
: indirect-test-3
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
gc ;
<< "f-stdcall" f "stdcall" add-library >>
[ f ] [ "f-stdcall" load-library ] unit-test
[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
: ffi_test_18 ( w x y z -- int )
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
alien-invoke gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- bar )
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke gc ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
] unit-test
FUNCTION: double ffi_test_6 float x float y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
[ "a" "b" ffi_test_6 ] must-fail
FUNCTION: double ffi_test_7 double x double y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
FUNCTION: double ffi_test_8 double x float y double z float t int w ;
[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
FUNCTION: void ffi_test_20 double x1, double x2, double x3,
double y1, double y2, double y3,
double z1, double z2, double z3 ;
[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31
"void"
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
FUNCTION: longlong ffi_test_21 long x long y ;
[ 121932631112635269 ]
[ 123456789 987654321 ffi_test_21 ] unit-test
FUNCTION: long ffi_test_22 long x longlong y longlong z ;
[ 987655432 ]
[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
[ 1111 f 123456789 ffi_test_22 ] must-fail
C-STRUCT: rect
{ "float" "x" }
{ "float" "y" }
{ "float" "w" }
{ "float" "h" }
;
: <rect>
"rect" <c-object>
[ set-rect-h ] keep
[ set-rect-w ] keep
[ set-rect-y ] keep
[ set-rect-x ] keep ;
FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
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
! Test odd-size structs
C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
FUNCTION: test-struct-1 ffi_test_24 ;
[ B{ 1 } ] [ ffi_test_24 ] unit-test
C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
FUNCTION: test-struct-2 ffi_test_25 ;
[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
FUNCTION: test-struct-3 ffi_test_26 ;
[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
FUNCTION: test-struct-4 ffi_test_27 ;
[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
FUNCTION: test-struct-5 ffi_test_28 ;
[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
FUNCTION: test-struct-6 ffi_test_29 ;
[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
FUNCTION: test-struct-7 ffi_test_30 ;
[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [
"test-struct-8" <c-object>
1.0 over set-test-struct-8-x
2.0 over set-test-struct-8-y
3 ffi_test_32
] unit-test
C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [
"test-struct-9" <c-object>
1.0 over set-test-struct-9-x
2.0 over set-test-struct-9-y
3 ffi_test_33
] unit-test
C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [
"test-struct-10" <c-object>
1.0 over set-test-struct-10-x
2 over set-test-struct-10-y
3 ffi_test_34
] unit-test
C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [
"test-struct-11" <c-object>
1 over set-test-struct-11-x
2 over set-test-struct-11-y
3 ffi_test_35
] unit-test
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
: make-struct-12
"test-struct-12" <c-object>
[ set-test-struct-12-x ] keep ;
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
[ t ] [ callback-1 alien? ] unit-test
: callback_test_1 "void" { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [
namestack*
3 "x" set callback-3 callback_test_1
namestack* eq?
] unit-test
[ 5 ] [
[
3 "x" set callback-3 callback_test_1 "x" get
] with-scope
] unit-test
: callback-4
"void" { } "cdecl" [ "Hello world" write ] alien-callback
gc ;
[ "Hello world" ] [
[ callback-4 callback_test_1 ] with-string-writer
] unit-test
: callback-5
"void" { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
: callback-5a
"void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
! Hack; if we're on ARM, we probably don't have much RAM, so
! skip this test.
! cpu "arm" = [
! [ "testing" ] [
! "testing" callback-5a callback_test_1
! ] unit-test
! ] unless
: callback-6
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7
"void" { } "cdecl" [ 1000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
: callback-8
"void" { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
: callback-9
"int" { "int" "int" "int" } "cdecl" [
+ + 1+
] alien-callback ;
FUNCTION: int ffi_test_37 ( void* func ) ;
[ 1 ] [ callback-9 ffi_test_37 ] unit-test
[ 7 ] [ callback-9 ffi_test_37 ] unit-test
IN: alien.compiler.tests
USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects
namespaces.private io io.streams.string memory system threads
tools.test math ;
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test
FUNCTION: int ffi_test_1 ;
[ 3 ] [ ffi_test_1 ] unit-test
FUNCTION: int ffi_test_2 int x int y ;
[ 5 ] [ 2 3 ffi_test_2 ] unit-test
[ "hi" 3 ffi_test_2 ] must-fail
FUNCTION: int ffi_test_3 int x int y int z int t ;
[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
FUNCTION: float ffi_test_4 ;
[ 1.5 ] [ ffi_test_4 ] unit-test
FUNCTION: double ffi_test_5 ;
[ 1.5 ] [ ffi_test_5 ] unit-test
FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
C-STRUCT: foo
{ "int" "x" }
{ "int" "y" }
;
: make-foo ( x y -- foo )
"foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
FUNCTION: int ffi_test_11 int a foo b int c ;
[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
FUNCTION: foo ffi_test_14 int x int y ;
[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
FUNCTION: char* ffi_test_15 char* x char* y ;
[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
[ 1 2 ffi_test_15 ] must-fail
C-STRUCT: bar
{ "long" "x" }
{ "long" "y" }
{ "long" "z" }
;
FUNCTION: bar ffi_test_16 long x long y long z ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
] unit-test
C-STRUCT: tiny
{ "int" "x" }
;
FUNCTION: tiny ffi_test_17 int x ;
[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1
"int" { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
[ -1 indirect-test-1 ] must-fail
: indirect-test-2
"int" { "int" "int" } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
[ 5 ]
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
unit-test
: indirect-test-3
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
gc ;
<< "f-stdcall" f "stdcall" add-library >>
[ f ] [ "f-stdcall" load-library ] unit-test
[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
: ffi_test_18 ( w x y z -- int )
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
alien-invoke gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- bar )
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
alien-invoke gc ;
[ 11 6 -7 ] [
11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
] unit-test
FUNCTION: double ffi_test_6 float x float y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
[ "a" "b" ffi_test_6 ] must-fail
FUNCTION: double ffi_test_7 double x double y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
FUNCTION: double ffi_test_8 double x float y double z float t int w ;
[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
FUNCTION: void ffi_test_20 double x1, double x2, double x3,
double y1, double y2, double y3,
double z1, double z2, double z3 ;
[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31
"void"
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
FUNCTION: longlong ffi_test_21 long x long y ;
[ 121932631112635269 ]
[ 123456789 987654321 ffi_test_21 ] unit-test
FUNCTION: long ffi_test_22 long x longlong y longlong z ;
[ 987655432 ]
[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
[ 1111 f 123456789 ffi_test_22 ] must-fail
C-STRUCT: rect
{ "float" "x" }
{ "float" "y" }
{ "float" "w" }
{ "float" "h" }
;
: <rect>
"rect" <c-object>
[ set-rect-h ] keep
[ set-rect-w ] keep
[ set-rect-y ] keep
[ set-rect-x ] keep ;
FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
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
! Test odd-size structs
C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
FUNCTION: test-struct-1 ffi_test_24 ;
[ B{ 1 } ] [ ffi_test_24 ] unit-test
C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
FUNCTION: test-struct-2 ffi_test_25 ;
[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
FUNCTION: test-struct-3 ffi_test_26 ;
[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
FUNCTION: test-struct-4 ffi_test_27 ;
[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
FUNCTION: test-struct-5 ffi_test_28 ;
[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
FUNCTION: test-struct-6 ffi_test_29 ;
[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
FUNCTION: test-struct-7 ffi_test_30 ;
[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
FUNCTION: double ffi_test_32 test-struct-8 x int y ;
[ 9.0 ] [
"test-struct-8" <c-object>
1.0 over set-test-struct-8-x
2.0 over set-test-struct-8-y
3 ffi_test_32
] unit-test
C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
FUNCTION: double ffi_test_33 test-struct-9 x int y ;
[ 9.0 ] [
"test-struct-9" <c-object>
1.0 over set-test-struct-9-x
2.0 over set-test-struct-9-y
3 ffi_test_33
] unit-test
C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_34 test-struct-10 x int y ;
[ 9.0 ] [
"test-struct-10" <c-object>
1.0 over set-test-struct-10-x
2 over set-test-struct-10-y
3 ffi_test_34
] unit-test
C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
FUNCTION: double ffi_test_35 test-struct-11 x int y ;
[ 9.0 ] [
"test-struct-11" <c-object>
1 over set-test-struct-11-x
2 over set-test-struct-11-y
3 ffi_test_35
] unit-test
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
: make-struct-12
"test-struct-12" <c-object>
[ set-test-struct-12-x ] keep ;
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
[ t ] [ callback-1 alien? ] unit-test
: callback_test_1 "void" { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [
namestack*
3 "x" set callback-3 callback_test_1
namestack* eq?
] unit-test
[ 5 ] [
[
3 "x" set callback-3 callback_test_1 "x" get
] with-scope
] unit-test
: callback-4
"void" { } "cdecl" [ "Hello world" write ] alien-callback
gc ;
[ "Hello world" ] [
[ callback-4 callback_test_1 ] with-string-writer
] unit-test
: callback-5
"void" { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
: callback-5a
"void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
! Hack; if we're on ARM, we probably don't have much RAM, so
! skip this test.
! cpu "arm" = [
! [ "testing" ] [
! "testing" callback-5a callback_test_1
! ] unit-test
! ] unless
: callback-6
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7
"void" { } "cdecl" [ 1000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
: callback-8
"void" { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
: callback-9
"int" { "int" "int" "int" } "cdecl" [
+ + 1+
] alien-callback ;
FUNCTION: void ffi_test_36_point_5 ( ) ;
[ ] [ ffi_test_36_point_5 ] unit-test
FUNCTION: int ffi_test_37 ( void* func ) ;
[ 1 ] [ callback-9 ffi_test_37 ] unit-test
[ 7 ] [ callback-9 ffi_test_37 ] unit-test

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

@ -3,10 +3,11 @@
USING: arrays generator generator.registers generator.fixup
hashtables kernel math namespaces sequences words
inference.state inference.backend inference.dataflow system
math.parser classes alien.arrays alien.c-types alien.structs
alien.syntax cpu.architecture alien inspector quotations assocs
kernel.private threads continuations.private libc combinators
compiler.errors continuations layouts accessors ;
math.parser classes alien.arrays alien.c-types alien.strings
alien.structs alien.syntax cpu.architecture alien inspector
quotations assocs kernel.private threads continuations.private
libc combinators compiler.errors continuations layouts accessors
;
IN: alien.compiler
TUPLE: #alien-node < node return parameters abi ;
@ -20,9 +21,7 @@ TUPLE: #alien-invoke < #alien-node library function ;
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
] [
drop f
] if ;
] [ drop f ] if ;
: alien-node-parameters* ( node -- seq )
dup parameters>>
@ -162,17 +161,16 @@ M: long-long-type flatten-value-type ( type -- )
dup return>> "void" = 0 1 ?
swap produce-values ;
: (make-prep-quot) ( parameters -- )
: (param-prep-quot) ( parameters -- )
dup empty? [
drop
] [
unclip c-type c-type-prep %
\ >r , (make-prep-quot) \ r> ,
unclip c-type c-type-unboxer-quot %
\ >r , (param-prep-quot) \ r> ,
] if ;
: make-prep-quot ( node -- quot )
parameters>>
[ <reversed> (make-prep-quot) ] [ ] make ;
: param-prep-quot ( node -- quot )
parameters>> [ <reversed> (param-prep-quot) ] [ ] make ;
: unbox-parameters ( offset node -- )
parameters>> [
@ -200,6 +198,20 @@ M: long-long-type flatten-value-type ( type -- )
: box-return* ( node -- )
return>> [ ] [ box-return ] if-void ;
: (return-prep-quot) ( parameters -- )
dup empty? [
drop
] [
unclip c-type c-type-boxer-quot %
\ >r , (return-prep-quot) \ r> ,
] if ;
: callback-prep-quot ( node -- quot )
parameters>> [ <reversed> (return-prep-quot) ] [ ] make ;
: return-prep-quot ( node -- quot )
[ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ;
M: alien-invoke-error summary
drop
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
@ -258,15 +270,15 @@ M: no-such-symbol compiler-error-type
pop-literal nip >>library
pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
dup param-prep-quot f infer-quot
! Set ABI
dup library>>
library [ abi>> ] [ "cdecl" ] if*
>>abi
dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
! Add node to IR
dup node,
! Magic #: consume exactly the number of inputs
0 alien-invoke-stack
dup 0 alien-invoke-stack
! Quotation which coerces return value to required type
return-prep-quot f infer-quot
] "infer" set-word-prop
M: #alien-invoke generate-node
@ -294,11 +306,13 @@ M: alien-indirect-error summary
pop-parameters >>parameters
pop-literal nip >>return
! Quotation which coerces parameters to required types
dup make-prep-quot [ dip ] curry recursive-state get infer-quot
dup param-prep-quot [ dip ] curry f infer-quot
! Add node to IR
dup node,
! Magic #: consume the function pointer, too
1 alien-invoke-stack
dup 1 alien-invoke-stack
! Quotation which coerces return value to required type
return-prep-quot f infer-quot
] "infer" set-word-prop
M: #alien-indirect generate-node
@ -331,7 +345,7 @@ M: alien-callback-error summary
: callback-bottom ( node -- )
xt>> [ word-xt drop <alien> ] curry
recursive-state get infer-quot ;
f infer-quot ;
\ alien-callback [
4 ensure-values
@ -371,16 +385,18 @@ TUPLE: callback-context ;
slip
wait-to-return ; inline
: prepare-callback-return ( ctype -- quot )
: callback-return-quot ( ctype -- quot )
return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
[ c-type c-type-prep ]
[ c-type c-type-unboxer-quot ]
} cond ;
: wrap-callback-quot ( node -- quot )
[
[ quot>> ] [ prepare-callback-return ] bi append ,
[ callback-prep-quot ]
[ quot>> ]
[ callback-return-quot ] tri 3append ,
[ callback-context new do-callback ] %
] [ ] make ;
@ -405,9 +421,10 @@ TUPLE: callback-context ;
init-templates
%prologue-later
dup alien-stack-frame [
dup registers>objects
dup wrap-callback-quot %alien-callback
%callback-return
[ registers>objects ]
[ wrap-callback-quot %alien-callback ]
[ %callback-return ]
tri
] with-stack-frame
] with-generator ;

8
core/alien/remote-control/remote-control.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types parser threads words kernel.private
kernel ;
USING: alien alien.c-types alien.strings parser threads words
kernel.private kernel io.encodings.utf8 ;
IN: alien.remote-control
: eval-callback
"void*" { "char*" } "cdecl"
[ eval>string malloc-char-string ] alien-callback ;
[ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback
"void" { } "cdecl" [ yield ] alien-callback ;

52
core/alien/strings/strings-docs.factor Normal file
View File

@ -0,0 +1,52 @@
USING: help.markup help.syntax strings byte-arrays alien libc
debugger ;
IN: alien.strings
HELP: string>alien
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
{ string>alien alien>string malloc-string } related-words
HELP: alien>string
{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
HELP: malloc-string
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if one of the following conditions occurs:"
{ $list
"the string contains null code points"
"the string contains characters not representable using the encoding specified"
"memory allocation fails"
}
} ;
HELP: string>symbol
{ $values { "str" string } { "alien" alien } }
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
$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
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
$nl
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>alien }
{ $subsection malloc-string }
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsection alien>string }
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
ABOUT: "c-strings"

30
core/alien/strings/strings-tests.factor Normal file
View File

@ -0,0 +1,30 @@
USING: alien.strings tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
io.encodings.ascii alien ;
IN: alien.strings.tests
[ "\u0000ff" ]
[ "\u0000ff" latin1 string>alien latin1 alien>string ]
unit-test
[ "hello world" ]
[ "hello world" latin1 string>alien latin1 alien>string ]
unit-test
[ "hello\u00abcdworld" ]
[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ]
unit-test
[ t ] [ f expired? ] unit-test
[ "hello world" ] [
"hello world" ascii malloc-string
dup ascii alien>string swap free
] unit-test
[ "hello world" ] [
"hello world" utf16n malloc-string
dup utf16n alien>string swap free
] unit-test
[ f ] [ f utf8 alien>string ] unit-test

111
core/alien/strings/strings.factor Normal file
View File

@ -0,0 +1,111 @@
! Copyright (C) 2008 Slava Pestov.
! 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 ;
IN: alien.strings
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
M: c-ptr alien>string
>r <memory-stream> r> <decoder>
"\0" swap stream-read-until drop ;
M: f alien>string
drop ;
ERROR: invalid-c-string string ;
: check-string ( string -- )
0 over memq? [ invalid-c-string ] [ drop ] if ;
GENERIC# string>alien 1 ( string encoding -- byte-array )
M: c-ptr string>alien drop ;
M: string string>alien
over check-string
<byte-writer>
[ stream-write ]
[ 0 swap stream-write1 ]
[ stream>> >byte-array ]
tri ;
: malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ;
PREDICATE: string-type < pair
first2 [ "char*" = ] [ word? ] bi* and ;
M: string-type c-type ;
M: string-type heap-size
drop "void*" heap-size ;
M: string-type c-type-align
drop "void*" c-type-align ;
M: string-type c-type-stack-align?
drop "void*" c-type-stack-align? ;
M: string-type unbox-parameter
drop "void*" unbox-parameter ;
M: string-type unbox-return
drop "void*" unbox-return ;
M: string-type box-parameter
drop "void*" box-parameter ;
M: string-type box-return
drop "void*" box-return ;
M: string-type stack-size
drop "void*" stack-size ;
M: string-type c-type-reg-class
drop int-regs ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;
M: string-type c-type-unboxer
drop "void*" c-type-unboxer ;
M: string-type c-type-boxer-quot
second [ alien>string ] curry [ ] like ;
M: string-type c-type-unboxer-quot
second [ string>alien ] curry [ ] like ;
M: string-type c-type-getter
drop [ alien-cell ] ;
M: string-type c-type-setter
drop [ set-alien-cell ] ;
TUPLE: utf16n ;
! Native-order UTF-16
: 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 ;
: dll-path ( dll -- string )
(dll-path) alien>native-string ;
: string>symbol ( str -- alien )
[ os wince? [ utf16n ] [ utf8 ] if string>alien ]
over string? [ call ] [ map ] if ;
{ "char*" utf8 } "char*" typedef
{ "char*" utf16n } "wchar_t*" typedef
"char*" "uchar*" typedef

28
core/alien/structs/structs-tests.factor
View File

@ -1,6 +1,6 @@
IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc words vocabs namespaces ;
sequences system libc words vocabs namespaces layouts ;
C-STRUCT: bar
{ "int" "x" }
@ -9,20 +9,20 @@ C-STRUCT: bar
[ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
! This was actually only correct on Windows/x86:
C-STRUCT: align-test
{ "int" "x" }
{ "double" "y" } ;
! C-STRUCT: align-test
! { "int" "x" }
! { "double" "y" } ;
!
! [ 16 ] [ "align-test" heap-size ] unit-test
!
! cell 4 = [
! C-STRUCT: one
! { "long" "a" } { "double" "b" } { "int" "c" } ;
!
! [ 24 ] [ "one" heap-size ] unit-test
! ] when
os winnt? cpu x86? and [
[ 16 ] [ "align-test" heap-size ] unit-test
cell 4 = [
C-STRUCT: one
{ "long" "a" } { "double" "b" } { "int" "c" } ;
[ 24 ] [ "one" heap-size ] unit-test
] when
] when
: MAX_FOOS 30 ;

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

@ -20,14 +20,19 @@ IN: alien.structs
: define-getter ( type spec -- )
[ set-reader-props ] keep
dup slot-spec-reader
over slot-spec-type c-getter
[ ]
[ slot-spec-reader ]
[
slot-spec-type
[ c-getter ] [ c-type c-type-boxer-quot ] bi append
] tri
define-struct-slot-word ;
: define-setter ( type spec -- )
[ set-writer-props ] keep
dup slot-spec-writer
over slot-spec-type c-setter
[ ]
[ slot-spec-writer ]
[ slot-spec-type c-setter ] tri
define-struct-slot-word ;
: define-field ( type spec -- )

8
core/alien/syntax/syntax.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays
kernel math namespaces parser sequences words quotations
math.parser splitting effects prettyprint prettyprint.sections
prettyprint.backend assocs combinators ;
alien.strings kernel math namespaces parser sequences words
quotations math.parser splitting effects prettyprint
prettyprint.sections prettyprint.backend assocs combinators ;
IN: alien.syntax
<PRIVATE
@ -40,7 +40,7 @@ PRIVATE>
: FUNCTION:
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] subset
[ "()" subseq? not ] filter
define-function ; parsing
: TYPEDEF:

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

@ -96,7 +96,7 @@ $nl
{ $subsection assoc-each }
{ $subsection assoc-map }
{ $subsection assoc-push-if }
{ $subsection assoc-subset }
{ $subsection assoc-filter }
{ $subsection assoc-contains? }
{ $subsection assoc-all? }
"Three additional combinators:"
@ -203,7 +203,7 @@ HELP: assoc-push-if
{ $values { "accum" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" object } { "value" object } }
{ $description "If the quotation yields true when applied to the key/value pair, adds the key/value pair at the end of " { $snippet "accum" } "." } ;
HELP: assoc-subset
HELP: assoc-filter
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
@ -281,7 +281,7 @@ HELP: assoc-union
HELP: assoc-diff
{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc1" } " whose key is not contained in " { $snippet "assoc2" } "." }
;
HELP: remove-all
{ $values { "assoc" assoc } { "seq" "a sequence" } { "subseq" "a new sequence" } }

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

@ -30,10 +30,10 @@ continuations ;
[ t ] [ H{ { 1 1 } { 2 2 } } [ = ] assoc-all? ] unit-test
[ f ] [ H{ { 1 2 } { 2 2 } } [ = ] assoc-all? ] unit-test
[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-subset ] unit-test
[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-filter ] unit-test
[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
[ drop 3 >= ] assoc-subset
[ drop 3 >= ] assoc-filter
] unit-test
[ 21 ] [

8
core/assocs/assocs.factor
View File

@ -50,7 +50,7 @@ M: assoc assoc-find
: assoc-pusher ( quot -- quot' accum )
V{ } clone [ [ assoc-push-if ] 2curry ] keep ; inline
: assoc-subset ( assoc quot -- subassoc )
: assoc-filter ( assoc quot -- subassoc )
over >r assoc-pusher >r assoc-each r> r> assoc-like ; inline
: assoc-contains? ( assoc quot -- ? )
@ -110,7 +110,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
] { } assoc>map hashcode* ;
: assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-subset ;
swap [ nip key? ] curry assoc-filter ;
: update ( assoc1 assoc2 -- )
swap [ swapd set-at ] curry assoc-each ;
@ -120,10 +120,10 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ rot update ] keep [ swap update ] keep ;
: assoc-diff ( assoc1 assoc2 -- diff )
swap [ nip key? not ] curry assoc-subset ;
[ nip key? not ] curry assoc-filter ;
: remove-all ( assoc seq -- subseq )
swap [ key? not ] curry subset ;
swap [ key? not ] curry filter ;
: (substitute)
[ dupd at* [ nip ] [ drop ] if ] curry ; inline

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

@ -5,7 +5,7 @@ namespaces parser kernel kernel.private classes classes.private
arrays hashtables vectors classes.tuple sbufs inference.dataflow
hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words generator command-line
vocabs io prettyprint libc compiler.units ;
vocabs io prettyprint libc compiler.units math.order ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
@ -74,6 +74,6 @@ nl
malloc calloc free memcpy
} compile
vocabs [ words [ compiled? not ] subset compile "." write flush ] each
vocabs [ words [ compiled? not ] filter compile "." write flush ] each
" done" print flush

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

@ -8,7 +8,7 @@ splitting growable classes classes.builtin classes.tuple
classes.tuple.private words.private io.binary io.files vocabs
vocabs.loader source-files definitions debugger float-arrays
quotations.private sequences.private combinators
io.encodings.binary ;
io.encodings.binary math.order ;
IN: bootstrap.image
: my-arch ( -- arch )
@ -305,7 +305,7 @@ M: float-array ' float-array emit-dummy-array ;
! Tuples
: (emit-tuple) ( tuple -- pointer )
[ tuple>array 1 tail-slice ]
[ tuple>array rest-slice ]
[ class transfer-word tuple-layout ] bi prefix [ ' ] map
tuple type-number dup [ emit-seq ] emit-object ;

6
core/bootstrap/primitives.factor
View File

@ -157,7 +157,7 @@ num-types get f <array> builtins set
! Catch-all class for providing a default method.
"object" "kernel" create
[ f builtins get [ ] subset union-class define-class ]
[ f builtins get [ ] filter union-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]
bi
@ -638,10 +638,6 @@ tuple
{ "set-alien-double" "alien.accessors" }
{ "alien-cell" "alien.accessors" }
{ "set-alien-cell" "alien.accessors" }
{ "alien>char-string" "alien" }
{ "string>char-alien" "alien" }
{ "alien>u16-string" "alien" }
{ "string>u16-alien" "alien" }
{ "(throw)" "kernel.private" }
{ "alien-address" "alien" }
{ "slot" "slots.private" }

6
core/bootstrap/stage2.factor
View File

@ -22,13 +22,13 @@ SYMBOL: bootstrap-time
xref-sources ;
: load-components ( -- )
"exclude" "include"
[ get-global " " split [ empty? not ] subset ] bi@
"include" "exclude"
[ get-global " " split [ empty? not ] filter ] bi@
diff
[ "bootstrap." prepend require ] each ;
: count-words ( pred -- )
all-words swap subset length number>string write ;
all-words swap filter length number>string write ;
: print-report ( time -- )
1000 /i

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

@ -183,7 +183,7 @@ C: <anonymous-complement> anonymous-complement
: largest-class ( seq -- n elt )
dup [
[ 2dup class< >r swap class< not r> and ]
with subset empty?
with filter empty?
] curry find [ "Topological sort failed" throw ] unless* ;
: sort-classes ( seq -- newseq )
@ -193,7 +193,7 @@ C: <anonymous-complement> anonymous-complement
[ ] unfold nip ;
: min-class ( class seq -- class/f )
over [ classes-intersect? ] curry subset
over [ classes-intersect? ] curry filter
dup empty? [ 2drop f ] [
tuck [ class< ] with all? [ peek ] [ drop f ] if
] if ;

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

@ -55,7 +55,7 @@ HELP: class
{ $values { "object" object } { "class" class } }
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
{ $class-description "The class of all class words." }
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
HELP: classes
{ $values { "seq" "a sequence of class words" } }
@ -63,7 +63,7 @@ HELP: classes
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;

2
core/classes/classes.factor
View File

@ -33,7 +33,7 @@ PREDICATE: class < word
PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
: classes ( -- seq ) all-words [ class? ] subset ;
: classes ( -- seq ) all-words [ class? ] filter ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;

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

@ -31,7 +31,7 @@ TUPLE: check-mixin-class mixin ;
>r >r check-mixin-class 2dup members memq? r> r> if ; inline
: change-mixin-class ( class mixin quot -- )
[ members swap bootstrap-word ] swap compose keep
[ members swap bootstrap-word ] prepose keep
swap redefine-mixin-class ; inline
: add-mixin-instance ( class mixin -- )

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

@ -18,7 +18,7 @@ HELP: SINGLETON:
"Defines a new singleton class. The class word itself is the sole instance of the singleton class."
}
{ $examples
{ $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
{ $example "USING: classes.singleton kernel io ;" "IN: scratchpad" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
} ;
HELP: define-singleton-class

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

@ -341,6 +341,7 @@ HELP: new
{ $examples
{ $example
"USING: kernel prettyprint ;"
"IN: scratchpad"
"TUPLE: employee number name department ;"
"employee new ."
"T{ employee f f f f }"

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

@ -3,7 +3,8 @@ math.constants parser sequences tools.test words assocs
namespaces quotations sequences.private classes continuations
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting inspector ;
calendar prettyprint io.streams.string splitting inspector
columns math.order ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@ -87,7 +88,7 @@ C: <empty> empty
[ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ]
[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
TUPLE: size-test a b c d ;

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

@ -166,7 +166,7 @@ M: tuple-class update-class
3tri ;
: subclasses ( class -- classes )
class-usages keys [ tuple-class? ] subset ;
class-usages keys [ tuple-class? ] filter ;
: each-subclass ( class quot -- )
>r subclasses r> each ; inline

6
core/combinators/combinators.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: combinators
USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
hashtables sorting words sets ;
hashtables sorting words sets math.order ;
IN: combinators
: cleave ( x seq -- )
[ call ] with each ;
@ -150,7 +150,7 @@ M: hashtable hashcode*
drop
] [
dup length 4 <=
over keys [ word? ] contains? or
over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
[
linear-case-quot
] [

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

@ -1,9 +1,9 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: command-line
USING: init continuations debugger hashtables io kernel
kernel.private namespaces parser sequences strings system
splitting io.files ;
IN: command-line
: run-bootstrap-init ( -- )
"user-init" get [
@ -54,7 +54,7 @@ SYMBOL: main-vocab-hook
"none" "run" set-global ;
: parse-command-line ( -- )
cli-args [ cli-arg ] subset
cli-args [ cli-arg ] filter
"script" get [ script-mode ] when
ignore-cli-args? [ drop ] [ [ run-file ] each ] if
"e" get [ eval ] when* ;

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

@ -27,7 +27,7 @@ SYMBOL: with-compiler-errors?
: errors-of-type ( type -- assoc )
compiler-errors get-global
swap [ >r nip compiler-error-type r> eq? ] curry
assoc-subset ;
assoc-filter ;
: compiler-errors. ( type -- )
errors-of-type >alist sort-keys

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

@ -1,11 +1,11 @@
IN: compiler.tests
USING: arrays compiler.units kernel kernel.private math
math.constants math.private sequences strings tools.test words
continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors.private
sbufs.private strings.private slots.private alien
alien.accessors alien.c-types alien.syntax namespaces libc
sequences.private ;
sbufs.private strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii ;
IN: compiler.tests
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test
@ -361,11 +361,11 @@ cell 8 = [
[ ] [ "b" get free ] unit-test
] when
[ ] [ "hello world" malloc-char-string "s" set ] unit-test
[ ] [ "hello world" ascii malloc-string "s" set ] unit-test
"s" get [
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
[ ] [ "s" get free ] unit-test
] when

4
core/compiler/tests/stack-trace.factor
View File

@ -13,11 +13,11 @@ words splitting sorting ;
[ baz ] [ 3 = ] must-fail-with
[ t ] [
symbolic-stack-trace
[ word? ] subset
[ word? ] filter
{ baz bar foo throw } tail?
] unit-test
: bleh [ 3 + ] map [ 0 > ] subset ;
: bleh [ 3 + ] map [ 0 > ] filter ;
: stack-trace-contains? symbolic-stack-trace memq? ;

3
core/compiler/tests/templates-early.factor
View File

@ -2,7 +2,8 @@
IN: compiler.tests
USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
words kernel math effects definitions compiler.units accessors ;
words kernel math effects definitions compiler.units accessors
cpu.architecture ;
: <int-vreg> ( n -- vreg ) int-regs <vreg> ;

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

@ -53,7 +53,7 @@ GENERIC: definitions-changed ( assoc obj -- )
[ definitions-changed ] with each ;
: changed-vocabs ( assoc -- vocabs )
[ drop word? ] assoc-subset
[ drop word? ] assoc-filter
[ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
: updated-definitions ( -- assoc )
@ -73,7 +73,7 @@ SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
: call-recompile-hook ( -- )
changed-definitions get keys [ word? ] subset
changed-definitions get keys [ word? ] filter
compiled-usages recompile-hook get call ;
: call-update-tuples-hook ( -- )

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

@ -1,10 +1,17 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory
namespaces sequences layouts system hashtables classes alien
byte-arrays bit-arrays float-arrays combinators words sets ;
IN: cpu.architecture
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params

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

@ -4,7 +4,7 @@ USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
kernel kernel.private math memory namespaces sequences words
assocs generator generator.registers generator.fixup system
layouts classes words.private alien combinators
compiler.constants ;
compiler.constants math.order ;
IN: cpu.ppc.architecture
! PowerPC register assignments

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

@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generator.fixup generic kernel memory namespaces
words math math.bitfields math.order io.binary ;
IN: cpu.ppc.assembler
USING: generator.fixup generic kernel math memory namespaces
words math.bitfields io.binary ;
! See the Motorola or IBM documentation for details. The opcode
! names are standard, and the operand order is the same as in

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

@ -181,7 +181,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split [ empty? not ] subset ;
] { } make { t } split [ empty? not ] filter ;
: flatten-large-struct ( type -- )
heap-size cell align

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

@ -3,7 +3,8 @@
USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math
memory namespaces sequences words generator generator.registers
generator.fixup system layouts combinators compiler.constants ;
generator.fixup system layouts combinators compiler.constants
math.order ;
IN: cpu.x86.architecture
HOOK: ds-reg cpu

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generator.fixup io.binary kernel
combinators kernel.private math namespaces parser sequences
words system layouts ;
words system layouts math.order ;
IN: cpu.x86.assembler
! A postfix assembler for x86 and AMD64.

17
core/debugger/debugger.factor
View File

@ -6,7 +6,8 @@ strings io.styles vectors words system splitting math.parser
classes.tuple continuations continuations.private combinators
generic.math io.streams.duplex classes.builtin classes
compiler.units generic.standard vocabs threads threads.private
init kernel.private libc io.encodings accessors ;
init kernel.private libc io.encodings mirrors accessors
math.order ;
IN: debugger
GENERIC: error. ( error -- )
@ -96,10 +97,10 @@ M: relative-overflow summary
: assert-depth ( quot -- )
>r datastack r> swap slip >r datastack r>
2dup [ length ] compare sgn {
{ -1 [ trim-datastacks nip relative-underflow ] }
{ 0 [ 2drop ] }
{ 1 [ trim-datastacks drop relative-overflow ] }
2dup [ length ] compare {
{ +lt+ [ trim-datastacks nip relative-underflow ] }
{ +eq+ [ 2drop ] }
{ +gt+ [ trim-datastacks drop relative-overflow ] }
} case ; inline
: expired-error. ( obj -- )
@ -289,6 +290,12 @@ M: encode-error summary drop "Character encoding error" ;
M: decode-error summary drop "Character decoding error" ;
M: no-such-slot summary drop "No such slot" ;
M: immutable-slot summary drop "Slot is immutable" ;
M: bad-create summary drop "Bad parameters to create" ;
<PRIVATE
: init-debugger ( -- )

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

@ -1,6 +1,6 @@
IN: definitions.tests
USING: tools.test generic kernel definitions sequences
compiler.units words ;
IN: definitions.tests
GENERIC: some-generic ( a -- b )

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

@ -79,7 +79,7 @@ IN: dlists.tests
[ dlist-push-all ] keep
[ dlist-delete-all ] keep
dlist>array
] 2keep diff assert-same-elements
] 2keep swap diff assert-same-elements
] unit-test
[ ] [

2
core/dlists/dlists.factor
View File

@ -153,7 +153,7 @@ PRIVATE>
drop ;
: dlist-each ( dlist quot -- )
[ obj>> ] swap compose dlist-each-node ; inline
[ obj>> ] prepose dlist-each-node ; inline
: dlist-slurp ( dlist quot -- )
over dlist-empty?

6
core/generator/fixup/fixup-docs.factor
View File

@ -13,12 +13,6 @@ HELP: add-literal
{ $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
HELP: string>symbol
{ $values { "str" string } { "alien" alien } }
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
$nl
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
HELP: rel-dlsym
{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."

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

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables
kernel kernel.private math namespaces sequences words
quotations strings alien layouts system combinators
math.bitfields words.private cpu.architecture ;
quotations strings alien.strings layouts system combinators
math.bitfields words.private cpu.architecture math.order ;
IN: generator.fixup
: no-stack-frame -1 ; inline
@ -110,10 +110,6 @@ SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get push-new* ;
: string>symbol ( str -- alien )
[ os wince? [ string>u16-alien ] [ string>char-alien ] if ]
over string? [ call ] [ map ] if ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;

1
core/generator/generator.factor
View File

@ -73,6 +73,7 @@ GENERIC: generate-node ( node -- next )
: word-dataflow ( word -- effect dataflow )
[
dup "no-effect" word-prop [ no-effect ] when
dup "no-compile" word-prop [ no-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] with-infer ;

15
core/generator/registers/registers.factor
View File

@ -4,7 +4,7 @@ USING: arrays assocs classes classes.private classes.algebra
combinators cpu.architecture generator.fixup hashtables kernel
layouts math namespaces quotations sequences system vectors
words effects alien byte-arrays bit-arrays float-arrays
accessors sets ;
accessors sets math.order ;
IN: generator.registers
SYMBOL: +input+
@ -13,13 +13,6 @@ SYMBOL: +scratch+
SYMBOL: +clobber+
SYMBOL: known-tag
! Register classes
SINGLETON: int-regs
SINGLETON: single-float-regs
SINGLETON: double-float-regs
UNION: float-regs single-float-regs double-float-regs ;
UNION: reg-class int-regs float-regs ;
<PRIVATE
! Value protocol
@ -321,7 +314,7 @@ M: phantom-retainstack finalize-height
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
[ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-subset
[ live-loc? ] assoc-filter
values ;
: live-locs ( -- seq )
@ -379,7 +372,7 @@ M: value (lazy-load)
: (compute-free-vregs) ( used class -- vector )
#! Find all vregs in 'class' which are not in 'used'.
[ vregs length reverse ] keep
[ <vreg> ] curry map diff
[ <vreg> ] curry map swap diff
>vector ;
: compute-free-vregs ( -- )
@ -491,7 +484,7 @@ M: loc lazy-store
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
[ substitute-vreg? ] assoc-filter >hashtable
[ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- )

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

@ -143,7 +143,7 @@ GENERIC: generic-forget-test-1
M: integer generic-forget-test-1 / ;
[ t ] [
\ / usage [ word? ] subset
\ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
@ -152,7 +152,7 @@ M: integer generic-forget-test-1 / ;
] unit-test
[ f ] [
\ / usage [ word? ] subset
\ / usage [ word? ] filter
[ word-name "generic-forget-test-1/integer" = ] contains?
] unit-test
@ -161,7 +161,7 @@ GENERIC: generic-forget-test-2
M: sequence generic-forget-test-2 = ;
[ t ] [
\ = usage [ word? ] subset
\ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test
@ -170,7 +170,7 @@ M: sequence generic-forget-test-2 = ;
] unit-test
[ f ] [
\ = usage [ word? ] subset
\ = usage [ word? ] filter
[ word-name "generic-forget-test-2/sequence" = ] contains?
] unit-test

4
core/generic/generic.factor
View File

@ -35,7 +35,7 @@ PREDICATE: method-spec < pair
GENERIC: effective-method ( ... generic -- method )
: next-method-class ( class generic -- class/f )
order [ class< ] with subset reverse dup length 1 =
order [ class< ] with filter reverse dup length 1 =
[ drop f ] [ second ] if ;
: next-method ( class generic -- class/f )
@ -137,7 +137,7 @@ M: method-body forget*
all-words [
"methods" word-prop keys
swap [ key? ] curry contains?
] with subset ;
] with filter ;
: implementors ( class -- seq )
dup associate implementors* ;

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

@ -3,7 +3,7 @@
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
sequences.private classes classes.builtin classes.algebra
definitions ;
definitions math.order ;
IN: generic.math
PREDICATE: math-class < class
@ -23,7 +23,7 @@ PREDICATE: math-class < class
} cond ;
: math-class-max ( class class -- class )
[ [ math-precedence ] compare 0 > ] most ;
[ [ math-precedence ] compare +gt+ eq? ] most ;
: (math-upgrade) ( max class -- quot )
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;

4
core/generic/standard/engines/engines.factor
View File

@ -26,8 +26,8 @@ M: method-body engine>quot 1quotation ;
alist>quot ;
: split-methods ( assoc class -- first second )
[ [ nip class< not ] curry assoc-subset ]
[ [ nip class< ] curry assoc-subset ] 2bi ;
[ [ nip class< not ] curry assoc-filter ]
[ [ nip class< ] curry assoc-filter ] 2bi ;
: convert-methods ( assoc class word -- assoc' )
over >r >r split-methods dup assoc-empty? [

4
core/generic/standard/engines/predicate/predicate.factor
View File

@ -17,8 +17,8 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
{
{ [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
{ [ dup length 1 = ] [ first second { } ] }
{ [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
[ [ first second ] [ 1 tail-slice ] bi ]
{ [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
[ [ first second ] [ rest-slice ] bi ]
} cond ;
: sort-methods ( assoc -- assoc' )

2
core/generic/standard/standard-tests.factor
View File

@ -3,7 +3,7 @@ USING: tools.test math math.functions math.constants
generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces
quotations inference vectors growable hashtables sbufs
prettyprint ;
prettyprint byte-vectors bit-vectors float-vectors ;
GENERIC: lo-tag-test

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

@ -10,7 +10,7 @@ continuations ;
[ ] [ 1000 [ dup sq ] H{ } map>assoc "testhash" set ] unit-test
[ V{ } ]
[ 1000 [ dup sq swap "testhash" get at = not ] subset ]
[ 1000 [ dup sq swap "testhash" get at = not ] filter ]
unit-test
[ t ]

3
core/heaps/heaps-docs.factor
View File

@ -1,4 +1,5 @@
USING: heaps.private help.markup help.syntax kernel math assocs ;
USING: heaps.private help.markup help.syntax kernel math assocs
math.order ;
IN: heaps
ARTICLE: "heaps" "Heaps"

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

@ -3,7 +3,7 @@
USING: arrays kernel math namespaces tools.test
heaps heaps.private math.parser random assocs sequences sorting
accessors ;
accessors math.order ;
IN: heaps.tests
[ <min-heap> heap-pop ] must-fail

8
core/heaps/heaps.factor
View File

@ -2,7 +2,7 @@
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs sequences.private
growable accessors ;
growable accessors math.order ;
IN: heaps
MIXIN: priority-queue
@ -92,11 +92,11 @@ M: priority-queue heap-size ( heap -- n )
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
: (heap-compare) drop [ entry-key ] compare 0 ; inline
: (heap-compare) drop [ entry-key ] compare ; inline
M: min-heap heap-compare (heap-compare) > ;
M: min-heap heap-compare (heap-compare) +gt+ eq? ;
M: max-heap heap-compare (heap-compare) < ;
M: max-heap heap-compare (heap-compare) +lt+ eq? ;
: heap-bounds-check? ( m heap -- ? )
heap-size >= ; inline

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

@ -4,7 +4,7 @@ USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
continuations debugger assocs combinators compiler.errors
generic.standard.engines.tuple accessors ;
generic.standard.engines.tuple accessors math.order ;
IN: inference.backend
: recursive-label ( word -- label/f )
@ -60,7 +60,7 @@ M: object value-literal \ literal-expected inference-warning ;
: value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
: add-inputs ( seq stack -- n stack )
tuck [ length ] compare dup 0 >
tuck [ length ] bi@ - dup 0 >
[ dup value-vector [ swapd push-all ] keep ]
[ drop 0 swap ] if ;
@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ;
: balanced? ( in out -- ? )
[ dup [ length - ] [ 2drop f ] if ] 2map
[ ] subset all-equal? ;
[ ] filter all-equal? ;
TUPLE: unbalanced-branches-error quots in out ;
@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ;
2dup balanced? [
over supremum -rot
[ >r dupd r> unify-inputs ] 2map
[ ] subset unify-stacks
[ ] filter unify-stacks
rot drop
] [
unbalanced-branches-error

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

@ -5,7 +5,7 @@ sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts vectors optimizer.math.partial accessors
optimizer.inlining ;
optimizer.inlining math.order ;
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test

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

@ -153,7 +153,7 @@ M: pair constraint-satisfied?
first constraint-satisfied? ;
: extract-keys ( seq assoc -- newassoc )
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
: annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of

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

@ -300,7 +300,7 @@ SYMBOL: node-stack
dup in-d>> first node-class ;
: active-children ( node -- seq )
children>> [ last-node ] map [ #terminate? not ] subset ;
children>> [ last-node ] map [ #terminate? not ] filter ;
DEFER: #tail?

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

@ -92,6 +92,8 @@ M: object infer-call
peek-d infer-call
] "infer" set-word-prop
\ call t "no-compile" set-word-prop
\ execute [
1 ensure-values
pop-literal nip
@ -471,18 +473,6 @@ set-primitive-effect
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
\ alien>char-string make-flushable
\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
\ string>char-alien make-flushable
\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
\ alien>u16-string make-flushable
\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
\ string>u16-alien make-flushable
\ alien-address { alien } { integer } <effect> set-primitive-effect
\ alien-address make-flushable

2
core/inspector/inspector.factor
View File

@ -96,7 +96,7 @@ SYMBOL: +editable+
: namestack. ( seq -- )
[
[ global eq? not ] subset
[ global eq? not ] filter
[ keys ] map concat prune
] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;

9
core/io/encodings/encodings-docs.factor
View File

@ -41,12 +41,13 @@ $low-level-note ;
ARTICLE: "encodings-descriptors" "Encoding descriptors"
"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
{ $vocab-subsection "ASCII" "io.encodings.ascii" }
{ $vocab-subsection "Binary" "io.encodings.binary" }
{ $subsection "io.encodings.binary" }
{ $subsection "io.encodings.utf8" }
{ $subsection "io.encodings.utf16" }
{ $vocab-subsection "Strict encodings" "io.encodings.strict" }
"Legacy encodings:"
{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
{ $vocab-subsection "UTF-8" "io.encodings.utf8" }
{ $vocab-subsection "UTF-16" "io.encodings.utf16" }
{ $vocab-subsection "ASCII" "io.encodings.ascii" }
{ $see-also "encodings-introduction" } ;
ARTICLE: "encodings-protocol" "Encoding protocol"

0
extra/io/encodings/utf16/.utf16.factor.swo → core/io/encodings/utf16/.utf16.factor.swo
View File

0
extra/io/encodings/utf16/authors.txt → core/io/encodings/utf16/authors.txt
View File

0
extra/io/encodings/utf16/summary.txt → core/io/encodings/utf16/summary.txt
View File

0
extra/io/encodings/utf16/tags.txt → core/io/encodings/utf16/tags.txt
View File

9
extra/io/encodings/utf16/utf16-docs.factor → core/io/encodings/utf16/utf16-docs.factor
View File

@ -5,8 +5,7 @@ ARTICLE: "io.encodings.utf16" "UTF-16"
"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
{ $subsection utf16 }
{ $subsection utf16le }
{ $subsection utf16be }
{ $subsection utf16n } ;
{ $subsection utf16be } ;
ABOUT: "io.encodings.utf16"
@ -22,8 +21,4 @@ HELP: utf16
{ $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." }
{ $see-also "encodings-introduction" } ;
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" } ;
{ utf16 utf16le utf16be utf16n } related-words
{ utf16 utf16le utf16be } related-words

2
extra/io/encodings/utf16/utf16-tests.factor → core/io/encodings/utf16/utf16-tests.factor
View File

@ -1,6 +1,6 @@
USING: kernel tools.test io.encodings.utf16 arrays sbufs
io.streams.byte-array sequences io.encodings io unicode
io.encodings.string alien.c-types accessors classes ;
io.encodings.string alien.c-types alien.strings accessors classes ;
IN: io.encodings.utf16.tests
[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test

14
extra/io/encodings/utf16/utf16.factor → core/io/encodings/utf16/utf16.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2006, 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces io.binary
io.encodings combinators splitting io byte-arrays inspector
alien.c-types ;
io.encodings combinators splitting io byte-arrays inspector ;
IN: io.encodings.utf16
TUPLE: utf16be ;
@ -11,8 +10,6 @@ TUPLE: utf16le ;
TUPLE: utf16 ;
TUPLE: utf16n ;
<PRIVATE
! UTF-16BE decoding
@ -124,13 +121,4 @@ M: utf16 <decoder> ( stream utf16 -- decoder )
M: utf16 <encoder> ( stream utf16 -- encoder )
drop bom-le over stream-write utf16le <encoder> ;
! Native-order UTF-16
: native-utf16 ( -- descriptor )
little-endian? utf16le utf16be ? ;
M: utf16n <decoder> drop native-utf16 <decoder> ;
M: utf16n <encoder> drop native-utf16 <encoder> ;
PRIVATE>

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

@ -135,13 +135,13 @@ strings accessors io.encodings.utf8 ;
[ { { "kernel" t } } ] [
"core" resource-path [
"." directory [ first "kernel" = ] subset
"." directory [ first "kernel" = ] filter
] with-directory
] unit-test
[ { { "kernel" t } } ] [
"resource:core" [
"." directory [ first "kernel" = ] subset
"." directory [ first "kernel" = ] filter
] with-directory
] unit-test

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

@ -3,7 +3,7 @@
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
io.encodings.binary init accessors ;
io.encodings.binary init accessors math.order ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@ -54,7 +54,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
[ path-separator? ] left-trim ;
: last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last* ;
[ length 1- ] keep [ path-separator? ] find-last-from ;
HOOK: root-directory? io-backend ( path -- ? )
@ -92,7 +92,7 @@ ERROR: no-parent-directory path ;
: append-path-empty ( path1 path2 -- path' )
{
{ [ dup head.? ] [
1 tail left-trim-separators append-path-empty
rest left-trim-separators append-path-empty
] }
{ [ dup head..? ] [ drop no-parent-directory ] }
[ nip ]
@ -122,7 +122,7 @@ PRIVATE>
{ [ over empty? ] [ append-path-empty ] }
{ [ dup empty? ] [ drop ] }
{ [ dup absolute-path? ] [ nip ] }
{ [ dup head.? ] [ 1 tail left-trim-separators append-path ] }
{ [ dup head.? ] [ rest left-trim-separators append-path ] }
{ [ dup head..? ] [
2 tail left-trim-separators
>r parent-directory r> append-path
@ -232,7 +232,7 @@ HOOK: make-directory io-backend ( path -- )
dup string?
[ tuck append-path directory? 2array ] [ nip ] if
] with map
[ first { "." ".." } member? not ] subset ;
[ first { "." ".." } member? not ] filter ;
: directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ;

13
core/io/streams/memory/memory.factor Normal file
View File

@ -0,0 +1,13 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors alien.accessors math io ;
IN: io.streams.memory
TUPLE: memory-stream alien index ;
: <memory-stream> ( alien -- stream )
0 memory-stream boa ;
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
[ [ 1+ ] change-index drop ] bi ;

2
core/io/streams/string/string.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces sequences sbufs strings
generic splitting growable continuations io.streams.plain
io.encodings io.encodings.private ;
io.encodings io.encodings.private math.order ;
IN: io.streams.string
M: growable dispose drop ;

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

@ -1,7 +1,7 @@
USING: generic help.markup help.syntax math memory
namespaces sequences kernel.private layouts sorting classes
kernel.private vectors combinators quotations strings words
assocs arrays ;
assocs arrays math.order ;
IN: kernel
ARTICLE: "shuffle-words" "Shuffle words"
@ -393,29 +393,8 @@ HELP: identity-tuple
{ $unchecked-example "T{ foo } dup clone = ." "f" }
} ;
HELP: <=>
{ $values { "obj1" object } { "obj2" object } { "n" real } }
{ $contract
"Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
$nl
"The output value is one of the following:"
{ $list
{ "positive - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } }
{ "zero - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } }
{ "negative - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } }
}
"The default implementation treats the two objects as sequences, and recursively compares their elements. So no extra work is required to compare sequences lexicographically."
} ;
{ <=> compare natural-sort sort-keys sort-values } related-words
HELP: compare
{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "n" integer } }
{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
{ $examples
{ $example "USING: kernel prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "3" }
} ;
HELP: clone
{ $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;

7
core/kernel/kernel.factor
View File

@ -133,8 +133,6 @@ M: identity-tuple equal? 2drop f ;
: = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [ equal? ] if ; inline
GENERIC: <=> ( obj1 obj2 -- n )
GENERIC: clone ( obj -- cloned )
M: object clone ;
@ -158,6 +156,9 @@ M: callstack clone (clone) ;
: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
: prepose ( quot1 quot2 -- curry )
swap compose ; inline
: 3compose ( quot1 quot2 quot3 -- curry )
compose compose ; inline
@ -176,8 +177,6 @@ M: callstack clone (clone) ;
: either? ( x y quot -- ? ) bi@ or ; inline
: compare ( obj1 obj2 quot -- n ) bi@ <=> ; inline
: most ( x y quot -- z )
>r 2dup r> call [ drop ] [ nip ] if ; inline

2
core/layouts/layouts.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel assocs classes
kernel.private ;
math.order kernel.private ;
IN: layouts
SYMBOL: tag-mask

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

@ -1,4 +1,4 @@
USING: help.markup help.syntax math ;
USING: help.markup help.syntax math math.order ;
IN: math.intervals
ARTICLE: "math-intervals-new" "Creating intervals"

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

@ -1,5 +1,5 @@
USING: math.intervals kernel sequences words math arrays
prettyprint tools.test random vocabs combinators ;
USING: math.intervals kernel sequences words math math.order
arrays prettyprint tools.test random vocabs combinators ;
IN: math.intervals.tests
[ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test

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

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
! Based on Slate's src/unfinished/interval.slate by Brian Rice.
USING: kernel sequences arrays math combinators ;
USING: kernel sequences arrays math combinators math.order ;
IN: math.intervals
TUPLE: interval from to ;

39
core/math/math-docs.factor
View File

@ -79,28 +79,6 @@ HELP: >=
{ $values { "x" real } { "y" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
HELP: before?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: before=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
{ before? after? before=? after=? } related-words
HELP: +
{ $values { "x" number } { "y" number } { "z" number } }
@ -275,19 +253,6 @@ HELP: recip
{ $description "Computes a number's multiplicative inverse." }
{ $errors "Throws an error if " { $snippet "x" } " is the integer 0." } ;
HELP: max
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the greatest of two real numbers." } ;
HELP: min
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the smallest of two real numbers." } ;
HELP: between?
{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
HELP: rem
{ $values { "x" integer } { "y" integer } { "z" integer } }
{ $description
@ -333,10 +298,6 @@ HELP: times
{ $description "Calls the quotation " { $snippet "n" } " times." }
{ $notes "If you need to pass the current index to the quotation, use " { $link each } "." } ;
HELP: [-]
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;
HELP: fp-nan?
{ $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;

22
core/math/math.factor
View File

@ -17,11 +17,6 @@ MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
: after? ( obj1 obj2 -- ? ) <=> 0 > ; inline
: before? ( obj1 obj2 -- ? ) <=> 0 < ; inline
: after=? ( obj1 obj2 -- ? ) <=> 0 >= ; inline
: before=? ( obj1 obj2 -- ? ) <=> 0 <= ; inline
MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable
MATH: * ( x y -- z ) foldable
@ -61,23 +56,14 @@ M: object zero? drop f ;
: sq ( x -- y ) dup * ; inline
: neg ( x -- -x ) 0 swap - ; inline
: recip ( x -- y ) 1 swap / ; inline
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: ?1+ [ 1+ ] [ 0 ] if* ; inline
: /f ( x y -- z ) >r >float r> >float float/f ; inline
: max ( x y -- z ) [ > ] most ; inline
: min ( x y -- z ) [ < ] most ; inline
: between? ( x y z -- ? )
pick >= [ >= ] [ 2drop f ] if ; inline
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: [-] ( x y -- z ) - 0 max ; inline
: 2^ ( n -- 2^n ) 1 swap shift ; inline
: even? ( n -- ? ) 1 bitand zero? ;
@ -96,13 +82,9 @@ M: number equal? number= ;
M: real hashcode* nip >fixnum ;
M: real <=> - ;
! real and sequence overlap. we disambiguate:
M: integer hashcode* nip >fixnum ;
M: integer <=> - ;
GENERIC: fp-nan? ( x -- ? )
M: object fp-nan?
@ -161,7 +143,7 @@ PRIVATE>
iterate-prep (each-integer) ; inline
: times ( n quot -- )
[ drop ] swap compose each-integer ; inline
[ drop ] prepose each-integer ; inline
: find-integer ( n quot -- i )
iterate-prep (find-integer) ; inline

72
core/math/order/order-docs.factor Normal file
View File

@ -0,0 +1,72 @@
USING: help.markup help.syntax kernel math sequences quotations
math.private ;
IN: math.order
HELP: <=>
{ $values { "obj1" object } { "obj2" object } { "n" real } }
{ $contract
"Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
$nl
"The output value is one of the following:"
{ $list
{ { $link +lt+ } " - indicating that " { $snippet "obj1" } " precedes " { $snippet "obj2" } }
{ { $link +eq+ } " - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } }
{ { $link +gt+ } " - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } }
}
"The default implementation treats the two objects as sequences, and recursively compares their elements. So no extra work is required to compare sequences lexicographically."
} ;
HELP: +lt+
{ $description "Returned by " { $link <=> } " when the first object is strictly less than the second object." } ;
HELP: +eq+
{ $description "Returned by " { $link <=> } " when the first object is equal to the second object." } ;
HELP: +gt+
{ $description "Returned by " { $link <=> } " when the first object is strictly greater than the second object." } ;
HELP: compare
{ $values { "obj1" object } { "obj2" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "symbol" "a comparison symbol, +lt+, +eq+, or +gt+" } }
{ $description "Compares the results of applying the quotation to both objects via " { $link <=> } "." }
{ $examples { $example "USING: kernel math.order prettyprint sequences ;" "\"hello\" \"hi\" [ length ] compare ." "+gt+" }
} ;
HELP: max
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the greatest of two real numbers." } ;
HELP: min
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Outputs the smallest of two real numbers." } ;
HELP: between?
{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
{ $notes "As per the closed interval notation, the end-points are included in the interval." } ;
HELP: before?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: before=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
HELP: after=?
{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
{ $notes "Implemented using " { $link <=> } "." } ;
{ before? after? before=? after=? } related-words
HELP: [-]
{ $values { "x" real } { "y" real } { "z" real } }
{ $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ;

9
core/math/order/order-tests.factor Normal file
View File

@ -0,0 +1,9 @@
USING: kernel math.order tools.test ;
IN: math.order.tests
[ +lt+ ] [ "ab" "abc" <=> ] unit-test
[ +gt+ ] [ "abc" "ab" <=> ] unit-test
[ +lt+ ] [ 3 4 <=> ] unit-test
[ +eq+ ] [ 4 4 <=> ] unit-test
[ +gt+ ] [ 4 3 <=> ] unit-test

40
core/math/order/order.factor Normal file
View File

@ -0,0 +1,40 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math ;
IN: math.order
SYMBOL: +lt+
SYMBOL: +eq+
SYMBOL: +gt+
GENERIC: <=> ( obj1 obj2 -- n )
: (<=>) - dup 0 < [ drop +lt+ ] [ zero? +eq+ +gt+ ? ] if ;
M: real <=> (<=>) ;
M: integer <=> (<=>) ;
GENERIC: before? ( obj1 obj2 -- ? )
GENERIC: after? ( obj1 obj2 -- ? )
GENERIC: before=? ( obj1 obj2 -- ? )
GENERIC: after=? ( obj1 obj2 -- ? )
M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ;
M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ;
M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ;
M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ;
M: real before? ( obj1 obj2 -- ? ) < ;
M: real after? ( obj1 obj2 -- ? ) > ;
M: real before=? ( obj1 obj2 -- ? ) <= ;
M: real after=? ( obj1 obj2 -- ? ) >= ;
: min ( x y -- z ) [ before? ] most ; inline
: max ( x y -- z ) [ after? ] most ; inline
: between? ( x y z -- ? )
pick after=? [ after=? ] [ 2drop f ] if ; inline
: [-] ( x y -- z ) - 0 max ; inline
: compare ( obj1 obj2 quot -- n ) bi@ <=> ; inline

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

@ -30,6 +30,7 @@ HELP: <mirror>
{ $examples
{ $example
"USING: assocs mirrors prettyprint ;"
"IN: scratchpad"
"TUPLE: circle center radius ;"
"C: <circle> circle"
"{ 100 50 } 15 <circle> <mirror> >alist ."
@ -37,10 +38,6 @@ HELP: <mirror>
}
} ;
HELP: >mirror<
{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
{ $description "Pushes the object being viewed in the mirror together with its slots." } ;
HELP: make-mirror
{ $values { "obj" object } { "assoc" assoc } }
{ $description "Creates an assoc which reflects the internal structure of the object." } ;

14
core/mirrors/mirrors-tests.factor
View File

@ -1,4 +1,4 @@
USING: mirrors tools.test assocs kernel arrays ;
USING: mirrors tools.test assocs kernel arrays accessors ;
IN: mirrors.tests
TUPLE: foo bar baz ;
@ -14,3 +14,15 @@ C: <foo> foo
[ 3 ] [
3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
] unit-test
[ 3 "hi" 1 2 <foo> <mirror> set-at ] [
[ no-such-slot? ]
[ name>> "hi" = ]
[ object>> foo? ] tri and and
] must-fail-with
[ 3 "numerator" 1/2 <mirror> set-at ] [
[ immutable-slot? ]
[ name>> "numerator" = ]
[ object>> 1/2 = ] tri and and
] must-fail-with

29
core/mirrors/mirrors.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple math vectors
quotations sorting prettyprint ;
quotations sorting prettyprint accessors ;
IN: mirrors
: all-slots ( class -- slots )
@ -16,33 +16,32 @@ TUPLE: mirror object slots ;
: <mirror> ( object -- mirror )
dup object-slots mirror boa ;
: >mirror< ( mirror -- obj slots )
dup mirror-object swap mirror-slots ;
ERROR: no-such-slot object name ;
: mirror@ ( slot-name mirror -- obj slot-spec )
>mirror< swapd slot-named ;
ERROR: immutable-slot object name ;
M: mirror at*
mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
[ nip object>> ] [ slots>> slot-named ] 2bi
dup [ offset>> slot t ] [ 2drop f f ] if ;
M: mirror set-at ( val key mirror -- )
mirror@ dup [
dup slot-spec-writer [
slot-spec-offset set-slot
[ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
dup writer>> [
nip offset>> set-slot
] [
"Immutable slot" throw
drop immutable-slot
] if
] [
"No such slot" throw
drop no-such-slot
] if ;
M: mirror delete-at ( key mirror -- )
f -rot set-at ;
M: mirror >alist ( mirror -- alist )
>mirror<
[ [ slot-spec-offset slot ] with map ] keep
[ slot-spec-name ] map swap zip ;
[ slots>> [ name>> ] map ]
[ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
zip ;
M: mirror assoc-size mirror-slots length ;
@ -50,7 +49,7 @@ INSTANCE: mirror assoc
: sort-assoc ( assoc -- alist )
>alist
[ dup first unparse-short swap ] { } map>assoc
[ [ first unparse-short ] keep ] { } map>assoc
sort-keys values ;
GENERIC: make-mirror ( obj -- assoc )

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

@ -87,7 +87,7 @@ HELP: +@
{ $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." }
{ $side-effects "variable" }
{ $examples
{ $example "USING: namespaces prettyprint ;" "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" }
{ $example "USING: namespaces prettyprint ;" "IN: scratchpad" "SYMBOL: foo\n1 foo +@\n10 foo +@\nfoo get ." "11" }
} ;
HELP: inc

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

@ -1,5 +1,5 @@
IN: namespaces.tests
USING: kernel namespaces tools.test words ;
IN: namespaces.tests
H{ } clone "test-namespace" set

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

@ -87,7 +87,7 @@ M: node optimize-node* drop t f ;
: compute-value-substitutions ( #call/#merge #return/#values -- assoc )
[ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip
[ = not ] assoc-subset >hashtable ;
[ = not ] assoc-filter >hashtable ;
: cleanup-inlining ( #return/#values -- newnode changed? )
dup node-successor [

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

@ -75,7 +75,7 @@ USE: prettyprint
M: #call-label collect-label-info*
node-param label-info get at
node-stack get over third tail
[ [ #label? ] subset [ node-param ] map ] keep
[ [ #label? ] filter [ node-param ] map ] keep
[ node-successor #tail? ] all? 2array
swap second push ;
@ -91,7 +91,7 @@ SYMBOL: potential-loops
: remove-non-tail-calls ( -- )
label-info get
[ nip second [ second ] all? ] assoc-subset
[ nip second [ second ] all? ] assoc-filter
[ first ] assoc-map
potential-loops set ;

4
core/optimizer/def-use/def-use.factor
View File

@ -56,7 +56,7 @@ UNION: #killable
: purge-invariants ( stacks -- seq )
#! Output a sequence of values which are not present in the
#! same position in each sequence of the stacks sequence.
unify-lengths flip [ all-eq? not ] subset concat ;
unify-lengths flip [ all-eq? not ] filter concat ;
M: #label node-def-use
[
@ -75,7 +75,7 @@ M: #branch node-def-use
dup branch-def-use (node-def-use) ;
: compute-dead-literals ( -- values )
def-use get [ >r value? r> empty? and ] assoc-subset ;
def-use get [ >r value? r> empty? and ] assoc-filter ;
DEFER: kill-nodes
SYMBOL: dead-literals

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