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

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

Conflicts:

	extra/delegate/delegate.factor
	extra/unicode/data/data.factor
db4
Daniel Ehrenberg 2008-04-30 19:45:12 -05:00
parent eac64bccab 72fcd2b133
commit 43cbb17e17
601 changed files with 53646 additions and 5610 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

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

@ -1,367 +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
! 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

69
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 recursive-state get 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 recursive-state get 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 recursive-state get 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 recursive-state get infer-quot
] "infer" set-word-prop
M: #alien-indirect generate-node
@ -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

20
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
@ -18,6 +18,8 @@ IN: bootstrap.compiler
enable-compiler
: compile-uncompiled [ compiled? not ] filter compile ;
nl
"Compiling..." write flush
@ -42,38 +44,38 @@ nl
find-pair-next namestack*
bitand bitor bitxor bitnot
} compile
} compile-uncompiled
"." write flush
{
+ 1+ 1- 2/ < <= > >= shift min
} compile
+ 1+ 1- 2/ < <= > >= shift
} compile-uncompiled
"." write flush
{
new-sequence nth push pop peek
} compile
} compile-uncompiled
"." write flush
{
hashcode* = get set
} compile
} compile-uncompiled
"." write flush
{
. lines
} compile
} compile-uncompiled
"." write flush
{
malloc calloc free memcpy
} compile
} compile-uncompiled
vocabs [ words [ compiled? not ] subset compile "." write flush ] each
vocabs [ words compile-uncompiled "." write flush ] each
" done" print flush

19
core/bootstrap/image/image-tests.factor
View File

@ -1,5 +1,22 @@
IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test ;
USING: bootstrap.image bootstrap.image.private tools.test
kernel math ;
\ ' must-infer
\ write-image must-infer
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
[ f ] [ [ 2drop 0 ] [ 2drop 0.0 ] eql? ] unit-test
[ t ] [ [ 2drop 0 ] [ 2drop 0 ] eql? ] unit-test
[ f ] [ \ + [ 2drop 0 ] eql? ] unit-test
[ f ] [ 3 [ 0 1 2 ] eql? ] unit-test
[ f ] [ 3 3.0 eql? ] unit-test
[ t ] [ 4.0 4.0 eql? ] unit-test

74
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 accessors ;
IN: bootstrap.image
: my-arch ( -- arch )
@ -31,6 +31,43 @@ IN: bootstrap.image
<PRIVATE
! Object cache; we only consider numbers equal if they have the
! same type
TUPLE: id obj ;
C: <id> id
M: id hashcode* obj>> hashcode* ;
GENERIC: (eql?) ( obj1 obj2 -- ? )
: eql? ( obj1 obj2 -- ? )
[ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
M: integer (eql?) = ;
M: sequence (eql?)
over sequence? [
2dup [ length ] bi@ =
[ [ eql? ] 2all? ] [ 2drop f ] if
] [ 2drop f ] if ;
M: object (eql?) = ;
M: id equal?
over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
SYMBOL: objects
: (objects) <id> objects get ; inline
: lookup-object ( obj -- n/f ) (objects) at ;
: put-object ( n obj -- ) (objects) set-at ;
: cache-object ( obj quot -- value )
>r (objects) r> [ obj>> ] prepose cache ; inline
! Constants
: image-magic HEX: 0f0e0d0c ; inline
@ -61,9 +98,6 @@ IN: bootstrap.image
! The image being constructed; a vector of word-size integers
SYMBOL: image
! Object cache
SYMBOL: objects
! Image output format
SYMBOL: big-endian
@ -187,7 +221,9 @@ GENERIC: ' ( obj -- ptr )
2tri ;
M: bignum '
bignum tag-number dup [ emit-bignum ] emit-object ;
[
bignum tag-number dup [ emit-bignum ] emit-object
] cache-object ;
! Fixnums
@ -202,9 +238,11 @@ M: fixnum '
! Floats
M: float '
float tag-number dup [
align-here double>bits emit-64
] emit-object ;
[
float tag-number dup [
align-here double>bits emit-64
] emit-object
] cache-object ;
! Special objects
@ -243,7 +281,7 @@ M: f '
] bi
\ word type-number object tag-number
[ emit-seq ] emit-object
] keep objects get set-at ;
] keep put-object ;
: word-error ( word msg -- * )
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
@ -252,7 +290,7 @@ M: f '
[ target-word ] keep or ;
: fixup-word ( word -- offset )
transfer-word dup objects get at
transfer-word dup lookup-object
[ ] [ "Not in image: " word-error ] ?if ;
: fixup-words ( -- )
@ -286,7 +324,7 @@ M: wrapper '
M: string '
#! We pool strings so that each string is only written once
#! to the image
objects get [ emit-string ] cache ;
[ emit-string ] cache-object ;
: assert-empty ( seq -- )
length 0 assert= ;
@ -305,18 +343,18 @@ 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 ;
: emit-tuple ( tuple -- pointer )
dup class word-name "tombstone" =
[ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
[ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
M: tuple ' emit-tuple ;
M: tuple-layout '
objects get [
[
[
{
[ layout-hashcode , ]
@ -328,12 +366,12 @@ M: tuple-layout '
] { } make [ ' ] map
\ tuple-layout type-number
object tag-number [ emit-seq ] emit-object
] cache ;
] cache-object ;
M: tombstone '
delegate
"((tombstone))" "((empty))" ? "hashtables.private" lookup
word-def first objects get [ emit-tuple ] cache ;
word-def first [ emit-tuple ] cache-object ;
! Arrays
M: array '
@ -343,7 +381,7 @@ M: array '
! Quotations
M: quotation '
objects get [
[
quotation-array '
quotation type-number object tag-number [
emit ! array
@ -351,7 +389,7 @@ M: quotation '
0 emit ! xt
0 emit ! code
] emit-object
] cache ;
] cache-object ;
! End of the image

57
core/bootstrap/primitives.factor
View File

@ -58,16 +58,13 @@ num-types get f <array> builtins set
"alien.accessors"
"arrays"
"bit-arrays"
"bit-vectors"
"byte-arrays"
"byte-vectors"
"classes.private"
"classes.tuple"
"classes.tuple.private"
"compiler.units"
"continuations.private"
"float-arrays"
"float-vectors"
"generator"
"growable"
"hashtables"
@ -160,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
@ -455,54 +452,6 @@ tuple
}
} define-tuple-class
"byte-vector" "byte-vectors" create
tuple
{
{
{ "byte-array" "byte-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"bit-vector" "bit-vectors" create
tuple
{
{
{ "bit-array" "bit-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"float-vector" "float-vectors" create
tuple
{
{
{ "float-array" "float-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"curry" "kernel" create
tuple
{
@ -689,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

3
core/bootstrap/syntax.factor
View File

@ -14,16 +14,13 @@ IN: bootstrap.syntax
";"
"<PRIVATE"
"?{"
"?V{"
"BIN:"
"B{"
"BV{"
"C:"
"CHAR:"
"DEFER:"
"ERROR:"
"F{"
"FV{"
"FORGET:"
"GENERIC#"
"GENERIC:"

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

@ -4,7 +4,7 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects kernel.private ;
random inference effects kernel.private sbufs ;
: class= [ class< ] 2keep swap class< and ;
@ -144,6 +144,48 @@ UNION: z1 b1 c1 ;
[ f ] [ null class-not null class= ] unit-test
[ t ] [
fixnum class-not
fixnum fixnum class-not class-or
class<
] unit-test
! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test
[ string ] [
\ string
[ integer string array reversed sbuf
slice vector quotation ]
sort-classes min-class
] unit-test
[ fixnum ] [
\ fixnum
[ fixnum integer object ]
sort-classes min-class
] unit-test
[ integer ] [
\ fixnum
[ integer float object ]
sort-classes min-class
] unit-test
[ object ] [
\ word
[ integer float object ]
sort-classes min-class
] unit-test
[ reversed ] [
\ reversed
[ integer reversed slice ]
sort-classes min-class
] unit-test
[ f ] [ null { number fixnum null } min-class ] unit-test
! Test for hangs?
: random-class classes random ;

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

@ -77,10 +77,10 @@ C: <anonymous-complement> anonymous-complement
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
{ [ over anonymous-union? ] [ left-anonymous-union< ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ over members ] [ left-union-class< ] }
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ dup members ] [ right-union-class< ] }
{ [ over superclass ] [ superclass< ] }
@ -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,9 +193,8 @@ C: <anonymous-complement> anonymous-complement
[ ] unfold nip ;
: min-class ( class seq -- class/f )
[ dupd classes-intersect? ] subset dup empty? [
2drop f
] [
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

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

@ -95,7 +95,7 @@ HELP: case
"If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
$nl
"The following two phrases are equivalent:"
{ $code "{ { X [ Y ] } { Y [ T ] } } case" }
{ $code "{ { X [ Y ] } { Z [ T ] } } case" }
{ $code "dup X = [ drop Y ] [ dup Z = [ drop T ] [ no-case ] if ] if" }
}
{ $examples

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

10
core/compiler/tests/simple.factor
View File

@ -1,6 +1,6 @@
USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings
alien arrays memory ;
alien arrays memory vocabs parser ;
IN: compiler.tests
! Test empty word
@ -230,3 +230,11 @@ M: f single-combination-test-2 single-combination-test-4 ;
! Regression
[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test
! Regression
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
"USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
] unit-test
] times

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

12
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
@ -187,6 +194,9 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src -- )
! GC check
HOOK: %gc cpu
: operand ( var -- op ) get v>operand ; inline
: unique-operands ( operands quot -- )

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

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.ppc.architecture cpu.ppc.assembler
kernel.private namespaces math sequences generic arrays
@ -7,7 +7,7 @@ cpu.architecture alien ;
IN: cpu.ppc.allot
: load-zone-ptr ( reg -- )
"nursery" f pick %load-dlsym dup 0 LWZ ;
>r "nursery" f r> %load-dlsym ;
: %allot ( header size -- )
#! Store a pointer to 'size' bytes allocated from the
@ -25,6 +25,19 @@ IN: cpu.ppc.allot
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand 11 r> tag-number ORI ;
M: ppc %gc
"end" define-label
12 load-zone-ptr
11 12 cell LWZ ! nursery.here -> r11
12 12 3 cells LWZ ! nursery.end -> r12
11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
11 0 12 CMP ! is here >= end?
"end" get BLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: %allot-float ( reg -- )
#! exits with tagged ptr to object in r12, untagged in r11
float 16 %allot

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/32/32.factor
View File

@ -17,6 +17,8 @@ M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 stack-save-reg EDX ;
M: x86.32 temp-reg-1 EAX ;
M: x86.32 temp-reg-2 ECX ;
M: temp-reg v>operand drop EBX ;

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

@ -12,6 +12,8 @@ M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M: x86.64 stack-reg RSP ;
M: x86.64 stack-save-reg RSI ;
M: x86.64 temp-reg-1 RAX ;
M: x86.64 temp-reg-2 RCX ;
M: temp-reg v>operand drop RBX ;
@ -179,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

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

@ -16,12 +16,12 @@ IN: cpu.x86.allot
: object@ ( n -- operand ) cells (object@) ;
: load-zone-ptr ( -- )
: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
"nursery" f allot-reg %alien-global ;
0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
: load-allot-ptr ( -- )
load-zone-ptr
allot-reg load-zone-ptr
allot-reg PUSH
allot-reg dup cell [+] MOV ;
@ -29,6 +29,19 @@ IN: cpu.x86.allot
allot-reg POP
allot-reg cell [+] swap 8 align ADD ;
M: x86 %gc ( -- )
"end" define-label
temp-reg-1 load-zone-ptr
temp-reg-2 temp-reg-1 cell [+] MOV
temp-reg-2 1024 ADD
temp-reg-1 temp-reg-1 3 cells [+] MOV
temp-reg-2 temp-reg-1 CMP
"end" get JLE
0 frame-required
%prepare-alien-invoke
"minor_gc" f %alien-invoke
"end" resolve-label ;
: store-header ( header -- )
0 object@ swap type-number tag-fixnum MOV ;

7
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
@ -34,6 +35,10 @@ GENERIC: push-return-reg ( reg-class -- )
GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-return-reg ( stack@ reg-class -- )
! Only used by inline allocation
HOOK: temp-reg-1 cpu
HOOK: temp-reg-2 cpu
HOOK: address-operand cpu ( address -- operand )
HOOK: fixnum>slot@ 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 ;

7
core/generator/generator.factor
View File

@ -40,16 +40,16 @@ SYMBOL: current-label-start
compiled-stack-traces?
compiling-word get f ?
1vector literal-table set
f compiling-word get compiled get set-at ;
f compiling-label get compiled get set-at ;
: finish-compiling ( literals relocation labels code -- )
: save-machine-code ( literals relocation labels code -- )
4array compiling-label get compiled get set-at ;
: with-generator ( node word label quot -- )
[
>r begin-compiling r>
{ } make fixup
finish-compiling
save-machine-code
] with-scope ; inline
GENERIC: generate-node ( node -- next )
@ -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 ;

20
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 ( -- )
@ -468,11 +461,6 @@ M: loc lazy-store
: finalize-contents ( -- )
finalize-locs finalize-vregs reset-phantoms ;
: %gc ( -- )
0 frame-required
%prepare-alien-invoke
"simple_gc" f %alien-invoke ;
! Loading stacks to vregs
: free-vregs? ( int# float# -- ? )
double-float-regs free-vregs length <=
@ -496,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

7
core/generic/generic.factor
View File

@ -29,10 +29,13 @@ PREDICATE: method-spec < pair
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
: specific-method ( class word -- class )
order min-class ;
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 )
@ -134,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

4
core/inference/backend/backend-docs.factor
View File

@ -48,10 +48,6 @@ HELP: no-effect
{ $description "Throws a " { $link no-effect } " error." }
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
HELP: collect-recursion
{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } }
{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ;
HELP: inline-word
{ $values { "word" word } }
{ $description "Called during inference to infer stack effects of inline words."

47
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
@ -409,6 +409,25 @@ TUPLE: recursive-declare-error word ;
\ recursive-declare-error inference-error
] if* ;
GENERIC: collect-label-info* ( label node -- )
M: node collect-label-info* 2drop ;
: (collect-label-info) ( label node vector -- )
>r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ;
inline
M: #call-label collect-label-info*
over calls>> (collect-label-info) ;
M: #return collect-label-info*
over returns>> (collect-label-info) ;
: collect-label-info ( #label -- )
V{ } clone >>calls
V{ } clone >>returns
dup [ collect-label-info* ] with each-node ;
: nest-node ( -- ) #entry node, ;
: unnest-node ( new-node -- new-node )
@ -419,27 +438,17 @@ TUPLE: recursive-declare-error word ;
: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
: inline-block ( word -- node-block data )
: inline-block ( word -- #label data )
[
copy-inference nest-node
dup word-def swap <inlined-block>
[ infer-quot-recursive ] 2keep
#label unnest-node
dup collect-label-info
] H{ } make-assoc ;
GENERIC: collect-recursion* ( label node -- )
M: node collect-recursion* 2drop ;
M: #call-label collect-recursion*
tuck node-param eq? [ , ] [ drop ] if ;
: collect-recursion ( #label -- seq )
dup node-param
[ [ swap collect-recursion* ] curry each-node ] { } make ;
: join-values ( node -- )
collect-recursion [ node-in-d ] map meta-d get suffix
: join-values ( #label -- )
calls>> [ node-in-d ] map meta-d get suffix
unify-lengths unify-stacks
meta-d [ length tail* ] change ;
@ -460,7 +469,7 @@ M: #call-label collect-recursion*
drop join-values inline-block apply-infer
r> over set-node-in-d
dup node,
collect-recursion [
calls>> [
[ flatten-curries ] modify-values
] each
] [

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

@ -4,7 +4,12 @@ inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts vectors ;
system layouts vectors optimizer.math.partial accessors
optimizer.inlining math.order ;
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
[ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
@ -13,9 +18,15 @@ system layouts vectors ;
! Ensure type inference works as it is supposed to by checking
! if various methods get inlined
: inlined? ( quot word -- ? )
: inlined? ( quot seq/word -- ? )
dup word? [ 1array ] when
swap dataflow optimize
[ node-param eq? ] with node-exists? not ;
[ node-param swap member? ] with node-exists? not ;
[ f ] [
[ { integer } declare >fixnum ]
\ >fixnum inlined?
] unit-test
GENERIC: mynot ( x -- y )
@ -109,12 +120,17 @@ M: object xyz ;
[ { fixnum } declare [ ] times ] \ fixnum+ inlined?
] unit-test
[ f ] [
[ t ] [
[ { integer fixnum } declare dupd < [ 1 + ] when ]
\ + inlined?
] unit-test
[ f ] [ [ dup 0 < [ neg ] when ] \ neg inlined? ] unit-test
[ f ] [
[ { integer fixnum } declare dupd < [ 1 + ] when ]
\ +-integer-fixnum inlined?
] unit-test
[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
[ f ] [
[
@ -137,13 +153,13 @@ M: object xyz ;
DEFER: blah
[ t ] [
[ ] [
[
\ blah
[ dup V{ } eq? [ foo ] when ] dup second dup push define
] with-compilation-unit
\ blah compiled?
\ blah word-def dataflow optimize drop
] unit-test
GENERIC: detect-fx ( n -- n )
@ -158,14 +174,20 @@ M: fixnum detect-fx ;
] \ detect-fx inlined?
] unit-test
[ t ] [
[
1000000000000000000000000000000000 [ ] times
] \ + inlined?
] unit-test
[ f ] [
[
1000000000000000000000000000000000 [ ] times
] \ 1+ inlined?
] \ +-integer-fixnum inlined?
] unit-test
[ f ] [
[ { bignum } declare [ ] times ] \ 1+ inlined?
[ { bignum } declare [ ] times ]
\ +-integer-fixnum inlined?
] unit-test
@ -251,19 +273,24 @@ M: float detect-float ;
[ 3 + = ] \ equal? inlined?
] unit-test
[ t ] [
[ f ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
\ shift inlined?
\ fixnum-shift-fast inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
\ fixnum-shift inlined?
{ shift fixnum-shift } inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
\ fixnum-shift inlined?
{ shift fixnum-shift } inlined?
] unit-test
[ f ] [
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
{ fixnum-shift-fast } inlined?
] unit-test
cell-bits 32 = [
@ -278,6 +305,11 @@ cell-bits 32 = [
] unit-test
] when
[ f ] [
[ { integer } declare -63 shift 4095 bitand ]
\ shift inlined?
] unit-test
[ t ] [
[ B{ 1 0 } *short 0 number= ]
\ number= inlined?
@ -323,3 +355,228 @@ cell-bits 32 = [
] when
] \ + inlined?
] unit-test
[ f ] [
[
256 mod
] { mod fixnum-mod } inlined?
] unit-test
[ f ] [
[
dup 0 >= [ 256 mod ] when
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare dup 0 >= [ 256 mod ] when
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare 256 rem
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [
[
{ integer } declare [ 256 rem ] map
] { mod fixnum-mod rem } inlined?
] unit-test
[ t ] [
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test
: rec ( a -- b )
dup 0 > [ 1 - rec ] when ; inline
[ t ] [
[ { fixnum } declare rec 1 + ]
{ > - + } inlined?
] unit-test
: fib ( m -- n )
dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline
[ t ] [
[ 27.0 fib ] { < - + } inlined?
] unit-test
[ f ] [
[ 27.0 fib ] { +-integer-integer } inlined?
] unit-test
[ t ] [
[ 27 fib ] { < - + } inlined?
] unit-test
[ t ] [
[ 27 >bignum fib ] { < - + } inlined?
] unit-test
[ f ] [
[ 27/2 fib ] { < - } inlined?
] unit-test
: hang-regression ( m n -- x )
over 0 number= [
nip
] [
dup [
drop 1 hang-regression
] [
dupd hang-regression hang-regression
] if
] if ; inline
[ t ] [
[ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
] { } inlined? ] unit-test
: detect-null ( a -- b ) dup drop ;
\ detect-null {
{ [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] }
} define-optimizers
[ t ] [
[ { null } declare detect-null ] \ detect-null inlined?
] unit-test
[ t ] [
[ { null null } declare + detect-null ] \ detect-null inlined?
] unit-test
[ f ] [
[ { null fixnum } declare + detect-null ] \ detect-null inlined?
] unit-test
GENERIC: detect-integer ( a -- b )
M: integer detect-integer ;
[ t ] [
[ { null fixnum } declare + detect-integer ] \ detect-integer inlined?
] unit-test
[ t ] [
[ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
] unit-test
[ f ] [
[ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
] unit-test
[ f ] [
[ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
\ fixnum-bitand inlined?
] unit-test
[ t ] [
[ { integer } declare 127 bitand 3 + ]
{ + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
] unit-test
[ f ] [
[ { integer } declare 127 bitand 3 + ]
{ >fixnum } inlined?
] unit-test
[ t ] [
[ { fixnum } declare [ drop ] each-integer ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare length [ drop ] each-integer ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare [ drop ] each ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare 0 [ + ] reduce ]
{ < <-integer-fixnum } inlined?
] unit-test
[ f ] [
[ { fixnum } declare 0 [ + ] reduce ]
\ +-integer-fixnum inlined?
] unit-test
[ t ] [
[
{ integer } declare
dup 0 >= [
615949 * 797807 + 20 2^ mod dup 19 2^ -
] [ dup ] if
] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
] unit-test
[ t ] [
[
{ fixnum } declare
615949 * 797807 + 20 2^ mod dup 19 2^ -
] { >fixnum } inlined?
] unit-test
[ f ] [
[
{ integer } declare [ ] map
] \ >fixnum inlined?
] unit-test
[ f ] [
[
{ integer } declare { } set-nth-unsafe
] \ >fixnum inlined?
] unit-test
[ f ] [
[
{ integer } declare 1 + { } set-nth-unsafe
] \ >fixnum inlined?
] unit-test
[ t ] [
[
{ integer } declare 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
] unit-test
[ t ] [
[
{ fixnum } declare 0 swap
[
drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
] map
] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
] unit-test
[ t ] [
[ { integer } declare bitnot detect-integer ]
\ detect-integer inlined?
] unit-test
! Later
! [ t ] [
! [
! { integer } declare [ 256 mod ] map
! ] { mod fixnum-mod } inlined?
! ] unit-test
!
! [ t ] [
! [
! { integer } declare [ 0 >= ] map
! ] { >= fixnum>= } inlined?
! ] unit-test

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

@ -1,9 +1,9 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables inference kernel
math namespaces sequences words parser math.intervals
effects classes classes.algebra inference.dataflow
inference.backend combinators ;
inference.backend combinators accessors ;
IN: inference.class
! Class inference
@ -25,12 +25,10 @@ C: <literal-constraint> literal-constraint
M: literal-constraint equal?
over literal-constraint? [
2dup
[ literal-constraint-literal ] bi@ eql? >r
[ literal-constraint-value ] bi@ = r> and
] [
2drop f
] if ;
[ [ literal>> ] bi@ eql? ]
[ [ value>> ] bi@ = ]
2bi and
] [ 2drop f ] if ;
TUPLE: class-constraint class value ;
@ -43,8 +41,8 @@ C: <interval-constraint> interval-constraint
GENERIC: apply-constraint ( constraint -- )
GENERIC: constraint-satisfied? ( constraint -- ? )
: `input node get node-in-d nth ;
: `output node get node-out-d nth ;
: `input node get in-d>> nth ;
: `output node get out-d>> nth ;
: class, <class-constraint> , ;
: literal, <literal-constraint> , ;
: interval, <interval-constraint> , ;
@ -84,14 +82,12 @@ SYMBOL: value-classes
set-value-interval* ;
M: interval-constraint apply-constraint
dup interval-constraint-interval
swap interval-constraint-value intersect-value-interval ;
[ interval>> ] [ value>> ] bi intersect-value-interval ;
: set-class-interval ( class value -- )
over class? [
over "interval" word-prop [
>r "interval" word-prop r> set-value-interval*
] [ 2drop ] if
>r "interval" word-prop r> over
[ set-value-interval* ] [ 2drop ] if
] [ 2drop ] if ;
: value-class* ( value -- class )
@ -110,18 +106,21 @@ M: interval-constraint apply-constraint
[ value-class* class-and ] keep set-value-class* ;
M: class-constraint apply-constraint
dup class-constraint-class
swap class-constraint-value intersect-value-class ;
[ class>> ] [ value>> ] bi intersect-value-class ;
: literal-interval ( value -- interval/f )
dup real? [ [a,a] ] [ drop f ] if ;
: set-value-literal* ( literal value -- )
over class over set-value-class*
over real? [ over [a,a] over set-value-interval* ] when
2dup <literal-constraint> assume
value-literals get set-at ;
{
[ >r class r> set-value-class* ]
[ >r literal-interval r> set-value-interval* ]
[ <literal-constraint> assume ]
[ value-literals get set-at ]
} 2cleave ;
M: literal-constraint apply-constraint
dup literal-constraint-literal
swap literal-constraint-value set-value-literal* ;
[ literal>> ] [ value>> ] bi set-value-literal* ;
! For conditionals, an assoc of child node # --> constraint
GENERIC: child-constraints ( node -- seq )
@ -133,19 +132,18 @@ GENERIC: infer-classes-around ( node -- )
M: node infer-classes-before drop ;
M: node child-constraints
node-children length
children>> length
dup zero? [ drop f ] [ f <repetition> ] if ;
: value-literal* ( value -- obj ? )
value-literals get at* ;
M: literal-constraint constraint-satisfied?
dup literal-constraint-value value-literal*
[ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
dup value>> value-literal*
[ swap literal>> eql? ] [ 2drop f ] if ;
M: class-constraint constraint-satisfied?
dup class-constraint-value value-class*
swap class-constraint-class class< ;
[ value>> value-class* ] [ class>> ] bi class< ;
M: pair apply-constraint
first2 2dup constraints get set-at
@ -154,19 +152,18 @@ M: pair apply-constraint
M: pair constraint-satisfied?
first constraint-satisfied? ;
: extract-keys ( assoc seq -- newassoc )
dup length <hashtable> swap [
dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if
] each nip f assoc-like ;
: extract-keys ( seq assoc -- newassoc )
[ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
: annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of
#! value classes.
dup node-values
value-intervals get over extract-keys pick set-node-intervals
value-classes get over extract-keys pick set-node-classes
value-literals get over extract-keys pick set-node-literals
2drop ;
dup node-values {
[ value-intervals get extract-keys >>intervals ]
[ value-classes get extract-keys >>classes ]
[ value-literals get extract-keys >>literals ]
[ 2drop ]
} cleave ;
: intersect-classes ( classes values -- )
[ intersect-value-class ] 2each ;
@ -190,31 +187,29 @@ M: pair constraint-satisfied?
] 2bi ;
: compute-constraints ( #call -- )
dup node-param "constraints" word-prop [
dup param>> "constraints" word-prop [
call
] [
dup node-param "predicating" word-prop dup
dup param>> "predicating" word-prop dup
[ swap predicate-constraints ] [ 2drop ] if
] if* ;
: compute-output-classes ( node word -- classes intervals )
dup node-param "output-classes" word-prop
dup param>> "output-classes" word-prop
dup [ call ] [ 2drop f f ] if ;
: output-classes ( node -- classes intervals )
dup compute-output-classes >r
[ ] [ node-param "default-output-classes" word-prop ] ?if
[ ] [ param>> "default-output-classes" word-prop ] ?if
r> ;
M: #call infer-classes-before
dup compute-constraints
dup node-out-d swap output-classes
>r over intersect-classes
r> swap intersect-intervals ;
[ compute-constraints ] keep
[ output-classes ] [ out-d>> ] bi
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
M: #push infer-classes-before
node-out-d
[ [ value-literal ] keep set-value-literal* ] each ;
out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
M: #if child-constraints
[
@ -224,19 +219,17 @@ M: #if child-constraints
M: #dispatch child-constraints
dup [
node-children length [
0 `input literal,
] each
children>> length [ 0 `input literal, ] each
] make-constraints ;
M: #declare infer-classes-before
dup node-param swap node-in-d
[ param>> ] [ in-d>> ] bi
[ intersect-value-class ] 2each ;
DEFER: (infer-classes)
: infer-children ( node -- )
dup node-children swap child-constraints [
[ children>> ] [ child-constraints ] bi [
[
value-classes [ clone ] change
value-literals [ clone ] change
@ -251,27 +244,27 @@ DEFER: (infer-classes)
>r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
: (merge-classes) ( nodes -- seq )
[ node-input-classes ] map
null pad-all flip [ null [ class-or ] reduce ] map ;
dup length 1 = [
first node-input-classes
] [
[ node-input-classes ] map null pad-all flip
[ null [ class-or ] reduce ] map
] if ;
: set-classes ( seq node -- )
node-out-d [ set-value-class* ] 2reverse-each ;
out-d>> [ set-value-class* ] 2reverse-each ;
: merge-classes ( nodes node -- )
>r (merge-classes) r> set-classes ;
: (merge-intervals) ( nodes quot -- seq )
>r
[ node-input-intervals ] map
f pad-all flip
r> map ; inline
: set-intervals ( seq node -- )
node-out-d [ set-value-interval* ] 2reverse-each ;
out-d>> [ set-value-interval* ] 2reverse-each ;
: merge-intervals ( nodes node -- )
>r [ dup first [ interval-union ] reduce ]
(merge-intervals) r> set-intervals ;
>r
[ node-input-intervals ] map f pad-all flip
[ dup first [ interval-union ] reduce ] map
r> set-intervals ;
: annotate-merge ( nodes #merge/#entry -- )
[ merge-classes ] [ merge-intervals ] 2bi ;
@ -280,28 +273,68 @@ DEFER: (infer-classes)
dup node-successor dup #merge? [
swap active-children dup empty?
[ 2drop ] [ swap annotate-merge ] if
] [
2drop
] if ;
] [ 2drop ] if ;
: classes= ( inferred current -- ? )
2dup min-length [ tail* ] curry bi@ sequence= ;
SYMBOL: fixed-point?
SYMBOL: nested-labels
: annotate-entry ( nodes #label -- )
node-child merge-classes ;
>r (merge-classes) r> node-child
2dup node-output-classes classes=
[ 2drop ] [ set-classes fixed-point? off ] if ;
: init-recursive-calls ( #label -- )
#! We set recursive calls to output the empty type, then
#! repeat inference until a fixed point is reached.
#! Hopefully, our type functions are monotonic so this
#! will always converge.
returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
M: #label infer-classes-before ( #label -- )
#! First, infer types under the hypothesis which hold on
#! entry to the recursive label.
[ 1array ] keep annotate-entry ;
[ init-recursive-calls ]
[ [ 1array ] keep annotate-entry ] bi ;
: infer-label-loop ( #label -- )
fixed-point? on
dup node-child (infer-classes)
dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
fixed-point? get [ drop ] [ infer-label-loop ] if ;
M: #label infer-classes-around ( #label -- )
#! Now merge the types at every recursion point with the
#! entry types.
{
[ annotate-node ]
[ infer-classes-before ]
[ infer-children ]
[ [ collect-recursion ] [ suffix ] [ annotate-entry ] tri ]
[ node-child (infer-classes) ]
} cleave ;
[
{
[ nested-labels get push ]
[ annotate-node ]
[ infer-classes-before ]
[ infer-label-loop ]
[ drop nested-labels get pop* ]
} cleave
] with-scope ;
: find-label ( param -- #label )
param>> nested-labels get [ param>> eq? ] with find nip ;
M: #call-label infer-classes-before ( #call-label -- )
[ find-label returns>> (merge-classes) ] [ out-d>> ] bi
[ set-value-class* ] 2each ;
M: #return infer-classes-around
nested-labels get length 0 > [
dup param>> nested-labels get peek param>> eq? [
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
classes= not [
fixed-point? off
[ in-d>> value-classes get extract-keys ] keep
set-node-classes
] [ drop ] if
] [ call-next-method ] if
] [ call-next-method ] if ;
M: object infer-classes-around
{
@ -314,11 +347,13 @@ M: object infer-classes-around
: (infer-classes) ( node -- )
[
[ infer-classes-around ]
[ node-successor (infer-classes) ] bi
[ node-successor ] bi
(infer-classes)
] when* ;
: infer-classes-with ( node classes literals intervals -- )
[
V{ } clone nested-labels set
H{ } assoc-like value-intervals set
H{ } assoc-like value-literals set
H{ } assoc-like value-classes set
@ -326,13 +361,11 @@ M: object infer-classes-around
(infer-classes)
] with-scope ;
: infer-classes ( node -- )
f f f infer-classes-with ;
: infer-classes ( node -- node )
dup f f f infer-classes-with ;
: infer-classes/node ( node existing -- )
#! Infer classes, using the existing node's class info as a
#! starting point.
dup node-classes
over node-literals
rot node-intervals
[ classes>> ] [ literals>> ] [ intervals>> ] tri
infer-classes-with ;

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

@ -90,7 +90,7 @@ M: object flatten-curry , ;
: node-child node-children first ;
TUPLE: #label < node word loop? ;
TUPLE: #label < node word loop? returns calls ;
: #label ( word label -- node )
\ #label param-node swap >>word ;
@ -290,6 +290,9 @@ SYMBOL: node-stack
: node-input-classes ( node -- seq )
dup in-d>> [ node-class ] with map ;
: node-output-classes ( node -- seq )
dup out-d>> [ node-class ] with map ;
: node-input-intervals ( node -- seq )
dup in-d>> [ node-interval ] with map ;
@ -297,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 ;

38
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
namespaces sequences kernel.private layouts classes
kernel.private vectors combinators quotations strings words
assocs arrays ;
assocs arrays math.order ;
IN: kernel
ARTICLE: "shuffle-words" "Shuffle words"
@ -241,7 +241,7 @@ ARTICLE: "conditionals" "Conditionals and logic"
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "equality" "Equality and comparison testing"
ARTICLE: "equality" "Equality"
"There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense."
$nl
"Identity comparison:"
@ -250,15 +250,8 @@ $nl
{ $subsection = }
"Custom value comparison methods:"
{ $subsection equal? }
"Utility class:"
{ $subsection identity-tuple }
"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
{ $subsection <=> }
{ $subsection compare }
"Utilities for comparing objects:"
{ $subsection after? }
{ $subsection before? }
{ $subsection after=? }
{ $subsection before=? }
"An object can be cloned; the clone has distinct identity but equal value:"
{ $subsection clone } ;
@ -393,29 +386,6 @@ 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

5
core/math/floats/floats.factor
View File

@ -6,8 +6,6 @@ IN: math.floats.private
M: fixnum >float fixnum>float ;
M: bignum >float bignum>float ;
M: float zero? dup 0.0 float= swap -0.0 float= or ;
M: float >fixnum float>fixnum ;
M: float >bignum float>bignum ;
M: float >float ;
@ -22,4 +20,7 @@ M: float + float+ ;
M: float - float- ;
M: float * float* ;
M: float / float/f ;
M: float /f float/f ;
M: float mod float-mod ;
M: real abs dup 0 < [ neg ] when ;

39
core/math/integers/integers-tests.factor
View File

@ -1,5 +1,5 @@
USING: kernel math namespaces prettyprint
math.private continuations tools.test sequences ;
USING: kernel math math.functions namespaces prettyprint
math.private continuations tools.test sequences random ;
IN: math.integers.tests
[ "-8" ] [ -8 unparse ] unit-test
@ -184,3 +184,38 @@ unit-test
[ HEX: 988a259c3433f237 ] [
B{ HEX: 37 HEX: f2 HEX: 33 HEX: 34 HEX: 9c HEX: 25 HEX: 8a HEX: 98 } byte-array>bignum
] unit-test
[ t ] [ 256 power-of-2? ] unit-test
[ f ] [ 123 power-of-2? ] unit-test
[ f ] [ -128 power-of-2? ] unit-test
[ f ] [ 0 power-of-2? ] unit-test
[ t ] [ 1 power-of-2? ] unit-test
: ratio>float [ >bignum ] bi@ /f ;
[ 5. ] [ 5 1 ratio>float ] unit-test
[ 4. ] [ 4 1 ratio>float ] unit-test
[ 2. ] [ 2 1 ratio>float ] unit-test
[ .5 ] [ 1 2 ratio>float ] unit-test
[ .75 ] [ 3 4 ratio>float ] unit-test
[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test
[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test
[ 0.4 ] [ 6 15 ratio>float ] unit-test
[ HEX: 3fe553522d230931 ]
[ 61967020039 92984792073 ratio>float double>bits ] unit-test
: random-integer
32 random-bits
1 random zero? [ neg ] when
1 random zero? [ >bignum ] when ;
[ t ] [
1000 [
drop
random-integer
random-integer
[ >float / ] [ /f ] 2bi 0.1 ~
] all?
] unit-test

58
core/math/integers/integers.factor
View File

@ -1,4 +1,5 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2008, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private sequences
sequences.private math math.private combinators ;
@ -22,6 +23,8 @@ M: fixnum + fixnum+ ;
M: fixnum - fixnum- ;
M: fixnum * fixnum* ;
M: fixnum /i fixnum/i ;
M: fixnum /f >r >float r> >float float/f ;
M: fixnum mod fixnum-mod ;
M: fixnum /mod fixnum/mod ;
@ -67,4 +70,57 @@ M: bignum bitnot bignum-bitnot ;
M: bignum bit? bignum-bit? ;
M: bignum (log2) bignum-log2 ;
M: integer zero? 0 number= ;
! Converting ratios to floats. Based on FLOAT-RATIO from
! sbcl/src/code/float.lisp, which has the following license:
! "The software is in the public domain and is
! provided with absolutely no warranty."
! First step: pre-scaling
: twos ( x -- y ) dup 1- bitxor log2 ; inline
: scale-denonimator ( den -- scaled-den scale' )
dup twos neg [ shift ] keep ; inline
: pre-scale ( num den -- scale shifted-num scaled-den )
2dup [ log2 ] bi@ -
tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi*
-rot ; inline
! Second step: loop
: shift-mantissa ( scale mantissa -- scale' mantissa' )
[ 1+ ] [ 2/ ] bi* ; inline
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
[ 2dup /i log2 53 > ]
[ >r shift-mantissa r> ]
[ ] while /mod ; inline
! Third step: post-scaling
: unscaled-float ( mantissa -- n )
52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
: scale-float ( scale mantissa -- float' )
>r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline
: post-scale ( scale mantissa -- n )
2/ dup log2 52 > [ shift-mantissa ] when
unscaled-float scale-float ; inline
! Main word
: /f-abs ( m n -- f )
over zero? [
2drop 0.0
] [
dup zero? [
2drop 1.0/0.0
] [
pre-scale
/f-loop over odd?
[ zero? [ 1+ ] unless ] [ drop ] if
post-scale
] if
] if ; inline
M: bignum /f ( m n -- f )
[ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;

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

4
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 ;
@ -96,6 +96,8 @@ C: <interval> interval
: interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
: interval-sq ( i1 -- i2 ) dup interval* ;
: make-interval ( from to -- int )
over first over first {
{ [ 2dup > ] [ 2drop 2drop f ] }

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

@ -1,5 +1,5 @@
USING: help.markup help.syntax kernel sequences quotations
math.private math.functions ;
math.private ;
IN: math
ARTICLE: "division-by-zero" "Division by zero"
@ -26,17 +26,13 @@ $nl
{ $subsection < }
{ $subsection <= }
{ $subsection > }
{ $subsection >= }
"Inexact comparison:"
{ $subsection ~ } ;
{ $subsection >= } ;
ARTICLE: "modular-arithmetic" "Modular arithmetic"
{ $subsection mod }
{ $subsection rem }
{ $subsection /mod }
{ $subsection /i }
{ $subsection mod-inv }
{ $subsection ^mod }
{ $see-also "integer-functions" } ;
ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
@ -83,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 } }
@ -279,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
@ -337,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 } "." } ;
@ -363,6 +320,10 @@ HELP: next-power-of-2
{ $values { "m" "a non-negative integer" } { "n" "an integer" } }
{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;
HELP: power-of-2?
{ $values { "n" integer } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
HELP: each-integer
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." }

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