Merge git://factorcode.org/git/factor
Chris Double
commit
c977d4a7fd
10
Makefile
10
Makefile
|
|
@ -56,6 +56,8 @@ default:
|
||||||
@echo "linux-arm"
|
@echo "linux-arm"
|
||||||
@echo "openbsd-x86-32"
|
@echo "openbsd-x86-32"
|
||||||
@echo "openbsd-x86-64"
|
@echo "openbsd-x86-64"
|
||||||
|
@echo "netbsd-x86-32"
|
||||||
|
@echo "netbsd-x86-64"
|
||||||
@echo "macosx-x86-32"
|
@echo "macosx-x86-32"
|
||||||
@echo "macosx-x86-64"
|
@echo "macosx-x86-64"
|
||||||
@echo "macosx-ppc"
|
@echo "macosx-ppc"
|
||||||
|
|
@ -83,6 +85,12 @@ freebsd-x86-32:
|
||||||
freebsd-x86-64:
|
freebsd-x86-64:
|
||||||
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.64
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.64
|
||||||
|
|
||||||
|
netbsd-x86-32:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.32
|
||||||
|
|
||||||
|
netbsd-x86-64:
|
||||||
|
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.64
|
||||||
|
|
||||||
macosx-freetype:
|
macosx-freetype:
|
||||||
ln -sf libfreetype.6.dylib \
|
ln -sf libfreetype.6.dylib \
|
||||||
Factor.app/Contents/Frameworks/libfreetype.dylib
|
Factor.app/Contents/Frameworks/libfreetype.dylib
|
||||||
|
|
@ -140,7 +148,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
rm -f vm/*.o
|
rm -f vm/*.o
|
||||||
rm -f libfactor.a
|
rm -f factor*.dll libfactor*.*
|
||||||
|
|
||||||
vm/resources.o:
|
vm/resources.o:
|
||||||
windres vm/factor.rs vm/resources.o
|
windres vm/factor.rs vm/resources.o
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,7 @@
|
||||||
USING: byte-arrays arrays help.syntax help.markup
|
USING: byte-arrays arrays help.syntax help.markup
|
||||||
alien.syntax alien.c-types compiler definitions math libc
|
alien.syntax compiler definitions math libc
|
||||||
debugger parser io io.backend system bit-arrays float-arrays ;
|
debugger parser io io.backend system bit-arrays float-arrays
|
||||||
|
alien.accessors ;
|
||||||
IN: alien
|
IN: alien
|
||||||
|
|
||||||
HELP: alien
|
HELP: alien
|
||||||
|
|
@ -156,36 +157,6 @@ ARTICLE: "aliens" "Alien addresses"
|
||||||
$nl
|
$nl
|
||||||
"Usually alien objects do not have to created and dereferenced directly; instead declaring C function parameters and return values as having a pointer type such as " { $snippet "void*" } " takes care of the details. See " { $link "c-types-specs" } "." ;
|
"Usually alien objects do not have to created and dereferenced directly; instead declaring C function parameters and return values as having a pointer type such as " { $snippet "void*" } " takes care of the details. See " { $link "c-types-specs" } "." ;
|
||||||
|
|
||||||
ARTICLE: "c-structs" "C structure types"
|
|
||||||
"A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."
|
|
||||||
{ $subsection POSTPONE: C-STRUCT: }
|
|
||||||
"Great care must be taken when working with C structures since no type or bounds checking is possible."
|
|
||||||
$nl
|
|
||||||
"An example:"
|
|
||||||
{ $code
|
|
||||||
"C-STRUCT: XVisualInfo"
|
|
||||||
" { \"Visual*\" \"visual\" }"
|
|
||||||
" { \"VisualID\" \"visualid\" }"
|
|
||||||
" { \"int\" \"screen\" }"
|
|
||||||
" { \"uint\" \"depth\" }"
|
|
||||||
" { \"int\" \"class\" }"
|
|
||||||
" { \"ulong\" \"red_mask\" }"
|
|
||||||
" { \"ulong\" \"green_mask\" }"
|
|
||||||
" { \"ulong\" \"blue_mask\" }"
|
|
||||||
" { \"int\" \"colormap_size\" }"
|
|
||||||
" { \"int\" \"bits_per_rgb\" } ;"
|
|
||||||
}
|
|
||||||
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
|
||||||
$nl
|
|
||||||
"Arrays of C structures can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-STRUCT: } "." ;
|
|
||||||
|
|
||||||
ARTICLE: "c-unions" "C unions"
|
|
||||||
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
|
|
||||||
{ $subsection POSTPONE: C-UNION: }
|
|
||||||
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
|
||||||
$nl
|
|
||||||
"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
|
|
||||||
|
|
||||||
ARTICLE: "reading-writing-memory" "Reading and writing memory directly"
|
ARTICLE: "reading-writing-memory" "Reading and writing memory directly"
|
||||||
"Numerical values can be read from memory addresses and converted to Factor objects using the various typed memory accessor words:"
|
"Numerical values can be read from memory addresses and converted to Factor objects using the various typed memory accessor words:"
|
||||||
{ $subsection alien-signed-1 }
|
{ $subsection alien-signed-1 }
|
||||||
|
|
@ -253,211 +224,6 @@ $nl
|
||||||
{ $subsection dlsym }
|
{ $subsection dlsym }
|
||||||
{ $subsection dlclose } ;
|
{ $subsection dlclose } ;
|
||||||
|
|
||||||
ARTICLE: "c-types-specs" "C type specifiers"
|
|
||||||
"C types are identified by strings, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words, as well as " { $link POSTPONE: C-STRUCT: } ", " { $link POSTPONE: C-UNION: } " and " { $link POSTPONE: TYPEDEF: } "."
|
|
||||||
$nl
|
|
||||||
"The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:"
|
|
||||||
{ $table
|
|
||||||
{ "C type" "Notes" }
|
|
||||||
{ { $snippet "char" } "always 1 byte" }
|
|
||||||
{ { $snippet "uchar" } { } }
|
|
||||||
{ { $snippet "short" } "always 2 bytes" }
|
|
||||||
{ { $snippet "ushort" } { } }
|
|
||||||
{ { $snippet "int" } "always 4 bytes" }
|
|
||||||
{ { $snippet "uint" } { } }
|
|
||||||
{ { $snippet "long" } { "same size as CPU word size and " { $snippet "void*" } ", except on 64-bit Windows, where it is 4 bytes" } }
|
|
||||||
{ { $snippet "ulong" } { } }
|
|
||||||
{ { $snippet "longlong" } "always 8 bytes" }
|
|
||||||
{ { $snippet "ulonglong" } { } }
|
|
||||||
{ { $snippet "float" } { } }
|
|
||||||
{ { $snippet "double" } { "same format as " { $link float } " objects" } }
|
|
||||||
}
|
|
||||||
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision."
|
|
||||||
$nl
|
|
||||||
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $snippet "void*" } ", which denotes a generic pointer; " { $snippet "void" } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned."
|
|
||||||
$nl
|
|
||||||
"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
|
|
||||||
{ $code "int[3][4]" }
|
|
||||||
"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation."
|
|
||||||
$nl
|
|
||||||
"Structure and union types are specified by the name of the structure or union." ;
|
|
||||||
|
|
||||||
ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
|
|
||||||
"Instances of the " { $link byte-array } ", " { $link bit-array } " and " { $link float-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
|
|
||||||
$nl
|
|
||||||
"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
|
|
||||||
{ $subsection <c-object> }
|
|
||||||
{ $subsection <c-array> }
|
|
||||||
{ $warning
|
|
||||||
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the function does not store a pointer to the byte array in some global structure, or retain it in any way after returning."
|
|
||||||
$nl
|
|
||||||
"Long-lived data for use by C libraries can be allocated manually, just as when programming in C. See " { $link "malloc" } "." }
|
|
||||||
{ $see-also "c-arrays" } ;
|
|
||||||
|
|
||||||
ARTICLE: "malloc" "Manual memory management"
|
|
||||||
"Sometimes data passed to C functions must be allocated at a fixed address, and so garbage collector managed byte arrays cannot be used. See the warning at the bottom of " { $link "c-byte-arrays" } " for a description of when this is the case."
|
|
||||||
$nl
|
|
||||||
"Allocating a C datum with a fixed address:"
|
|
||||||
{ $subsection malloc-object }
|
|
||||||
{ $subsection malloc-array }
|
|
||||||
{ $subsection malloc-byte-array }
|
|
||||||
"There is a set of words in the " { $vocab-link "libc" } " vocabulary which directly call C standard library memory management functions:"
|
|
||||||
{ $subsection malloc }
|
|
||||||
{ $subsection calloc }
|
|
||||||
{ $subsection realloc }
|
|
||||||
"The return value of the above three words must always be checked for a memory allocation failure:"
|
|
||||||
{ $subsection check-ptr }
|
|
||||||
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
|
|
||||||
{ $subsection free }
|
|
||||||
"You can unsafely copy a range of bytes from one memory location to another:"
|
|
||||||
{ $subsection memcpy }
|
|
||||||
"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 } "."
|
|
||||||
$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 }
|
|
||||||
{ $subsection memory>string }
|
|
||||||
{ $subsection string>memory } ;
|
|
||||||
|
|
||||||
ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
|
|
||||||
"Each primitive C type has a pair of words, " { $snippet ">" { $emphasis "type" } "-array" } " and " { $snippet { $emphasis "type" } "-array>" } ", for converting an array of Factor objects to and from a " { $link byte-array } " of C values. This set of words consists of:"
|
|
||||||
{ $subsection >c-bool-array }
|
|
||||||
{ $subsection >c-char-array }
|
|
||||||
{ $subsection >c-double-array }
|
|
||||||
{ $subsection >c-float-array }
|
|
||||||
{ $subsection >c-int-array }
|
|
||||||
{ $subsection >c-long-array }
|
|
||||||
{ $subsection >c-longlong-array }
|
|
||||||
{ $subsection >c-short-array }
|
|
||||||
{ $subsection >c-uchar-array }
|
|
||||||
{ $subsection >c-uint-array }
|
|
||||||
{ $subsection >c-ulong-array }
|
|
||||||
{ $subsection >c-ulonglong-array }
|
|
||||||
{ $subsection >c-ushort-array }
|
|
||||||
{ $subsection >c-void*-array }
|
|
||||||
{ $subsection c-bool-array> }
|
|
||||||
{ $subsection c-char*-array> }
|
|
||||||
{ $subsection c-char-array> }
|
|
||||||
{ $subsection c-double-array> }
|
|
||||||
{ $subsection c-float-array> }
|
|
||||||
{ $subsection c-int-array> }
|
|
||||||
{ $subsection c-long-array> }
|
|
||||||
{ $subsection c-longlong-array> }
|
|
||||||
{ $subsection c-short-array> }
|
|
||||||
{ $subsection c-uchar-array> }
|
|
||||||
{ $subsection c-uint-array> }
|
|
||||||
{ $subsection c-ulong-array> }
|
|
||||||
{ $subsection c-ulonglong-array> }
|
|
||||||
{ $subsection c-ushort*-array> }
|
|
||||||
{ $subsection c-ushort-array> }
|
|
||||||
{ $subsection c-void*-array> } ;
|
|
||||||
|
|
||||||
ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
|
|
||||||
"Each C type has a pair of words, " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } ", for reading and writing values of this type stored in an array. This set of words includes but is not limited to:"
|
|
||||||
{ $subsection char-nth }
|
|
||||||
{ $subsection set-char-nth }
|
|
||||||
{ $subsection uchar-nth }
|
|
||||||
{ $subsection set-uchar-nth }
|
|
||||||
{ $subsection short-nth }
|
|
||||||
{ $subsection set-short-nth }
|
|
||||||
{ $subsection ushort-nth }
|
|
||||||
{ $subsection set-ushort-nth }
|
|
||||||
{ $subsection int-nth }
|
|
||||||
{ $subsection set-int-nth }
|
|
||||||
{ $subsection uint-nth }
|
|
||||||
{ $subsection set-uint-nth }
|
|
||||||
{ $subsection long-nth }
|
|
||||||
{ $subsection set-long-nth }
|
|
||||||
{ $subsection ulong-nth }
|
|
||||||
{ $subsection set-ulong-nth }
|
|
||||||
{ $subsection longlong-nth }
|
|
||||||
{ $subsection set-longlong-nth }
|
|
||||||
{ $subsection ulonglong-nth }
|
|
||||||
{ $subsection set-ulonglong-nth }
|
|
||||||
{ $subsection float-nth }
|
|
||||||
{ $subsection set-float-nth }
|
|
||||||
{ $subsection double-nth }
|
|
||||||
{ $subsection set-double-nth }
|
|
||||||
{ $subsection void*-nth }
|
|
||||||
{ $subsection set-void*-nth }
|
|
||||||
{ $subsection char*-nth }
|
|
||||||
{ $subsection ushort*-nth } ;
|
|
||||||
|
|
||||||
ARTICLE: "c-arrays" "C arrays"
|
|
||||||
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
|
|
||||||
$nl
|
|
||||||
"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
|
|
||||||
{ $subsection "c-arrays-factor" }
|
|
||||||
{ $subsection "c-arrays-get/set" } ;
|
|
||||||
|
|
||||||
ARTICLE: "c-out-params" "Output parameters in C"
|
|
||||||
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
|
|
||||||
$nl
|
|
||||||
"Each numerical C type, together with " { $snippet "void*" } ", has an associated " { $emphasis "out parameter constructor" } " word which takes a Factor object as input, constructs a byte array of the correct size, and converts the Factor object to a C value stored into the byte array:"
|
|
||||||
{ $subsection <char> }
|
|
||||||
{ $subsection <uchar> }
|
|
||||||
{ $subsection <short> }
|
|
||||||
{ $subsection <ushort> }
|
|
||||||
{ $subsection <int> }
|
|
||||||
{ $subsection <uint> }
|
|
||||||
{ $subsection <long> }
|
|
||||||
{ $subsection <ulong> }
|
|
||||||
{ $subsection <longlong> }
|
|
||||||
{ $subsection <ulonglong> }
|
|
||||||
{ $subsection <float> }
|
|
||||||
{ $subsection <double> }
|
|
||||||
{ $subsection <void*> }
|
|
||||||
"You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using the next set of words:"
|
|
||||||
{ $subsection *char }
|
|
||||||
{ $subsection *uchar }
|
|
||||||
{ $subsection *short }
|
|
||||||
{ $subsection *ushort }
|
|
||||||
{ $subsection *int }
|
|
||||||
{ $subsection *uint }
|
|
||||||
{ $subsection *long }
|
|
||||||
{ $subsection *ulong }
|
|
||||||
{ $subsection *longlong }
|
|
||||||
{ $subsection *ulonglong }
|
|
||||||
{ $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-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. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
|
|
||||||
{ $subsection "c-types-specs" }
|
|
||||||
{ $subsection "c-byte-arrays" }
|
|
||||||
{ $subsection "malloc" }
|
|
||||||
{ $subsection "c-strings" }
|
|
||||||
{ $subsection "c-arrays" }
|
|
||||||
{ $subsection "c-out-params" }
|
|
||||||
"C-style enumerated types are supported:"
|
|
||||||
{ $subsection POSTPONE: C-ENUM: }
|
|
||||||
"C types can be aliased for convenience and consitency with native library documentation:"
|
|
||||||
{ $subsection POSTPONE: TYPEDEF: }
|
|
||||||
"New C types can be defined:"
|
|
||||||
{ $subsection "c-structs" }
|
|
||||||
{ $subsection "c-unions" }
|
|
||||||
{ $subsection "reading-writing-memory" } ;
|
|
||||||
|
|
||||||
ARTICLE: "embedding-api" "Factor embedding API"
|
ARTICLE: "embedding-api" "Factor embedding API"
|
||||||
"The Factor embedding API is defined in " { $snippet "vm/master.h" } "."
|
"The Factor embedding API is defined in " { $snippet "vm/master.h" } "."
|
||||||
$nl
|
$nl
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
IN: temporary
|
IN: temporary
|
||||||
USING: alien byte-arrays
|
USING: alien alien.accessors byte-arrays arrays kernel
|
||||||
arrays kernel kernel.private namespaces tools.test sequences
|
kernel.private namespaces tools.test sequences libc math system
|
||||||
libc math system prettyprint ;
|
prettyprint ;
|
||||||
|
|
||||||
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
|
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs kernel math namespaces sequences system
|
USING: assocs kernel math namespaces sequences system
|
||||||
kernel.private tuples ;
|
kernel.private tuples bit-arrays byte-arrays float-arrays ;
|
||||||
IN: alien
|
IN: alien
|
||||||
|
|
||||||
! Some predicate classes used by the compiler for optimization
|
! Some predicate classes used by the compiler for optimization
|
||||||
|
|
@ -9,16 +9,11 @@ IN: alien
|
||||||
PREDICATE: alien simple-alien
|
PREDICATE: alien simple-alien
|
||||||
underlying-alien not ;
|
underlying-alien not ;
|
||||||
|
|
||||||
! These mixins are not intended to be extended by user code.
|
UNION: simple-c-ptr
|
||||||
! They are not unions, because if they were we'd have a circular
|
simple-alien POSTPONE: f byte-array bit-array float-array ;
|
||||||
! dependency between alien and {byte,bit,float}-arrays.
|
|
||||||
MIXIN: simple-c-ptr
|
|
||||||
INSTANCE: simple-alien simple-c-ptr
|
|
||||||
INSTANCE: f simple-c-ptr
|
|
||||||
|
|
||||||
MIXIN: c-ptr
|
UNION: c-ptr
|
||||||
INSTANCE: alien c-ptr
|
alien POSTPONE: f byte-array bit-array float-array ;
|
||||||
INSTANCE: f c-ptr
|
|
||||||
|
|
||||||
DEFER: pinned-c-ptr?
|
DEFER: pinned-c-ptr?
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,73 @@
|
||||||
|
IN: alien.arrays
|
||||||
|
USING: help.syntax help.markup byte-arrays alien.c-types ;
|
||||||
|
|
||||||
|
ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays"
|
||||||
|
"Each primitive C type has a pair of words, " { $snippet ">" { $emphasis "type" } "-array" } " and " { $snippet { $emphasis "type" } "-array>" } ", for converting an array of Factor objects to and from a " { $link byte-array } " of C values. This set of words consists of:"
|
||||||
|
{ $subsection >c-bool-array }
|
||||||
|
{ $subsection >c-char-array }
|
||||||
|
{ $subsection >c-double-array }
|
||||||
|
{ $subsection >c-float-array }
|
||||||
|
{ $subsection >c-int-array }
|
||||||
|
{ $subsection >c-long-array }
|
||||||
|
{ $subsection >c-longlong-array }
|
||||||
|
{ $subsection >c-short-array }
|
||||||
|
{ $subsection >c-uchar-array }
|
||||||
|
{ $subsection >c-uint-array }
|
||||||
|
{ $subsection >c-ulong-array }
|
||||||
|
{ $subsection >c-ulonglong-array }
|
||||||
|
{ $subsection >c-ushort-array }
|
||||||
|
{ $subsection >c-void*-array }
|
||||||
|
{ $subsection c-bool-array> }
|
||||||
|
{ $subsection c-char*-array> }
|
||||||
|
{ $subsection c-char-array> }
|
||||||
|
{ $subsection c-double-array> }
|
||||||
|
{ $subsection c-float-array> }
|
||||||
|
{ $subsection c-int-array> }
|
||||||
|
{ $subsection c-long-array> }
|
||||||
|
{ $subsection c-longlong-array> }
|
||||||
|
{ $subsection c-short-array> }
|
||||||
|
{ $subsection c-uchar-array> }
|
||||||
|
{ $subsection c-uint-array> }
|
||||||
|
{ $subsection c-ulong-array> }
|
||||||
|
{ $subsection c-ulonglong-array> }
|
||||||
|
{ $subsection c-ushort*-array> }
|
||||||
|
{ $subsection c-ushort-array> }
|
||||||
|
{ $subsection c-void*-array> } ;
|
||||||
|
|
||||||
|
ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays"
|
||||||
|
"Each C type has a pair of words, " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } ", for reading and writing values of this type stored in an array. This set of words includes but is not limited to:"
|
||||||
|
{ $subsection char-nth }
|
||||||
|
{ $subsection set-char-nth }
|
||||||
|
{ $subsection uchar-nth }
|
||||||
|
{ $subsection set-uchar-nth }
|
||||||
|
{ $subsection short-nth }
|
||||||
|
{ $subsection set-short-nth }
|
||||||
|
{ $subsection ushort-nth }
|
||||||
|
{ $subsection set-ushort-nth }
|
||||||
|
{ $subsection int-nth }
|
||||||
|
{ $subsection set-int-nth }
|
||||||
|
{ $subsection uint-nth }
|
||||||
|
{ $subsection set-uint-nth }
|
||||||
|
{ $subsection long-nth }
|
||||||
|
{ $subsection set-long-nth }
|
||||||
|
{ $subsection ulong-nth }
|
||||||
|
{ $subsection set-ulong-nth }
|
||||||
|
{ $subsection longlong-nth }
|
||||||
|
{ $subsection set-longlong-nth }
|
||||||
|
{ $subsection ulonglong-nth }
|
||||||
|
{ $subsection set-ulonglong-nth }
|
||||||
|
{ $subsection float-nth }
|
||||||
|
{ $subsection set-float-nth }
|
||||||
|
{ $subsection double-nth }
|
||||||
|
{ $subsection set-double-nth }
|
||||||
|
{ $subsection void*-nth }
|
||||||
|
{ $subsection set-void*-nth }
|
||||||
|
{ $subsection char*-nth }
|
||||||
|
{ $subsection ushort*-nth } ;
|
||||||
|
|
||||||
|
ARTICLE: "c-arrays" "C arrays"
|
||||||
|
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."
|
||||||
|
$nl
|
||||||
|
"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
|
||||||
|
{ $subsection "c-arrays-factor" }
|
||||||
|
{ $subsection "c-arrays-get/set" } ;
|
||||||
|
|
@ -1,8 +1,10 @@
|
||||||
USING: alien alien.c-types help.syntax help.markup libc
|
IN: alien.c-types
|
||||||
kernel.private byte-arrays math strings ;
|
USING: alien help.syntax help.markup libc kernel.private
|
||||||
|
byte-arrays math strings hashtables alien.syntax
|
||||||
|
bit-arrays float-arrays debugger ;
|
||||||
|
|
||||||
HELP: <c-type>
|
HELP: <c-type>
|
||||||
{ $values { "type" "a hashtable" } }
|
{ $values { "type" hashtable } }
|
||||||
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
|
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
|
||||||
|
|
||||||
HELP: no-c-type
|
HELP: no-c-type
|
||||||
|
|
@ -14,12 +16,12 @@ HELP: c-types
|
||||||
{ $var-description "Global variable holding a hashtable mapping C type names to C types. Use the " { $link c-type } " word to look up C types." } ;
|
{ $var-description "Global variable holding a hashtable mapping C type names to C types. Use the " { $link c-type } " word to look up C types." } ;
|
||||||
|
|
||||||
HELP: c-type
|
HELP: c-type
|
||||||
{ $values { "name" string } { "type" "a hashtable" } }
|
{ $values { "name" string } { "type" hashtable } }
|
||||||
{ $description "Looks up a C type by name." }
|
{ $description "Looks up a C type by name." }
|
||||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||||
|
|
||||||
HELP: heap-size
|
HELP: heap-size
|
||||||
{ $values { "type" string } { "size" "an integer" } }
|
{ $values { "type" string } { "size" integer } }
|
||||||
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
|
{ $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
|
||||||
{ $examples
|
{ $examples
|
||||||
"On a 32-bit system, you will get the following output:"
|
"On a 32-bit system, you will get the following output:"
|
||||||
|
|
@ -28,7 +30,7 @@ HELP: heap-size
|
||||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||||
|
|
||||||
HELP: stack-size
|
HELP: stack-size
|
||||||
{ $values { "type" string } { "size" "an integer" } }
|
{ $values { "type" string } { "size" integer } }
|
||||||
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
|
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
|
||||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||||
|
|
||||||
|
|
@ -78,13 +80,31 @@ HELP: alien>u16-string ( c-ptr -- string )
|
||||||
{ $values { "c-ptr" c-ptr } { "string" string } }
|
{ $values { "c-ptr" c-ptr } { "string" string } }
|
||||||
{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
|
{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
|
||||||
|
|
||||||
HELP: memory>string ( base len -- string )
|
HELP: memory>byte-array ( base len -- string )
|
||||||
{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } }
|
{ $values { "base" 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 Factor string." } ;
|
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
|
||||||
|
|
||||||
HELP: string>memory ( string base -- )
|
HELP: memory>char-string ( base len -- string )
|
||||||
|
{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } }
|
||||||
|
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new string." } ;
|
||||||
|
|
||||||
|
HELP: memory>u16-string ( base len -- string )
|
||||||
|
{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } }
|
||||||
|
{ $description "Reads " { $snippet "len" } " UCS2 characters starting from " { $snippet "base" } " and stores them in a new string." } ;
|
||||||
|
|
||||||
|
HELP: byte-array>memory ( string base -- )
|
||||||
|
{ $values { "byte-array" byte-array } { "base" c-ptr } }
|
||||||
|
{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
|
||||||
|
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
|
||||||
|
|
||||||
|
HELP: string>char-memory ( string base -- )
|
||||||
{ $values { "string" string } { "base" c-ptr } }
|
{ $values { "string" string } { "base" c-ptr } }
|
||||||
{ $description "Writes the string to memory starting from the " { $snippet "base" } " address." }
|
{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." }
|
||||||
|
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
|
||||||
|
|
||||||
|
HELP: string>u16-memory ( string base -- )
|
||||||
|
{ $values { "string" string } { "base" c-ptr } }
|
||||||
|
{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." }
|
||||||
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
|
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
|
||||||
|
|
||||||
HELP: malloc-array
|
HELP: malloc-array
|
||||||
|
|
@ -151,3 +171,143 @@ HELP: define-out
|
||||||
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
|
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
|
||||||
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
|
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
|
||||||
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
|
||||||
|
|
||||||
|
ARTICLE: "c-out-params" "Output parameters in C"
|
||||||
|
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
|
||||||
|
$nl
|
||||||
|
"Each numerical C type, together with " { $snippet "void*" } ", has an associated " { $emphasis "out parameter constructor" } " word which takes a Factor object as input, constructs a byte array of the correct size, and converts the Factor object to a C value stored into the byte array:"
|
||||||
|
{ $subsection <char> }
|
||||||
|
{ $subsection <uchar> }
|
||||||
|
{ $subsection <short> }
|
||||||
|
{ $subsection <ushort> }
|
||||||
|
{ $subsection <int> }
|
||||||
|
{ $subsection <uint> }
|
||||||
|
{ $subsection <long> }
|
||||||
|
{ $subsection <ulong> }
|
||||||
|
{ $subsection <longlong> }
|
||||||
|
{ $subsection <ulonglong> }
|
||||||
|
{ $subsection <float> }
|
||||||
|
{ $subsection <double> }
|
||||||
|
{ $subsection <void*> }
|
||||||
|
"You call the out parameter constructor with the required initial value, then pass the byte array to the C function, which receives a pointer to the start of the byte array's data area. The C function then returns, leaving the result in the byte array; you read it back using the next set of words:"
|
||||||
|
{ $subsection *char }
|
||||||
|
{ $subsection *uchar }
|
||||||
|
{ $subsection *short }
|
||||||
|
{ $subsection *ushort }
|
||||||
|
{ $subsection *int }
|
||||||
|
{ $subsection *uint }
|
||||||
|
{ $subsection *long }
|
||||||
|
{ $subsection *ulong }
|
||||||
|
{ $subsection *longlong }
|
||||||
|
{ $subsection *ulonglong }
|
||||||
|
{ $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"
|
||||||
|
"C types are identified by strings, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words, as well as " { $link POSTPONE: C-STRUCT: } ", " { $link POSTPONE: C-UNION: } " and " { $link POSTPONE: TYPEDEF: } "."
|
||||||
|
$nl
|
||||||
|
"The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:"
|
||||||
|
{ $table
|
||||||
|
{ "C type" "Notes" }
|
||||||
|
{ { $snippet "char" } "always 1 byte" }
|
||||||
|
{ { $snippet "uchar" } { } }
|
||||||
|
{ { $snippet "short" } "always 2 bytes" }
|
||||||
|
{ { $snippet "ushort" } { } }
|
||||||
|
{ { $snippet "int" } "always 4 bytes" }
|
||||||
|
{ { $snippet "uint" } { } }
|
||||||
|
{ { $snippet "long" } { "same size as CPU word size and " { $snippet "void*" } ", except on 64-bit Windows, where it is 4 bytes" } }
|
||||||
|
{ { $snippet "ulong" } { } }
|
||||||
|
{ { $snippet "longlong" } "always 8 bytes" }
|
||||||
|
{ { $snippet "ulonglong" } { } }
|
||||||
|
{ { $snippet "float" } { } }
|
||||||
|
{ { $snippet "double" } { "same format as " { $link float } " objects" } }
|
||||||
|
}
|
||||||
|
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision."
|
||||||
|
$nl
|
||||||
|
"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $snippet "void*" } ", which denotes a generic pointer; " { $snippet "void" } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned."
|
||||||
|
$nl
|
||||||
|
"Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:"
|
||||||
|
{ $code "int[3][4]" }
|
||||||
|
"Fixed-size arrays differ from pointers in that they are allocated inside structures and unions; however when used as function parameters they behave exactly like pointers and thus the dimensions only serve as documentation."
|
||||||
|
$nl
|
||||||
|
"Structure and union types are specified by the name of the structure or union." ;
|
||||||
|
|
||||||
|
ARTICLE: "c-byte-arrays" "Passing data in byte arrays"
|
||||||
|
"Instances of the " { $link byte-array } ", " { $link bit-array } " and " { $link float-array } " class can be passed to C functions; the C function receives a pointer to the first element of the array."
|
||||||
|
$nl
|
||||||
|
"Byte arrays can be allocated directly with a byte count using the " { $link <byte-array> } " word. However in most cases, instead of computing a size in bytes directly, it is easier to use a higher-level word which expects C type and outputs a byte array large enough to hold that type:"
|
||||||
|
{ $subsection <c-object> }
|
||||||
|
{ $subsection <c-array> }
|
||||||
|
{ $warning
|
||||||
|
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the function does not store a pointer to the byte array in some global structure, or retain it in any way after returning."
|
||||||
|
$nl
|
||||||
|
"Long-lived data for use by C libraries can be allocated manually, just as when programming in C. See " { $link "malloc" } "." }
|
||||||
|
{ $see-also "c-arrays" } ;
|
||||||
|
|
||||||
|
ARTICLE: "malloc" "Manual memory management"
|
||||||
|
"Sometimes data passed to C functions must be allocated at a fixed address, and so garbage collector managed byte arrays cannot be used. See the warning at the bottom of " { $link "c-byte-arrays" } " for a description of when this is the case."
|
||||||
|
$nl
|
||||||
|
"Allocating a C datum with a fixed address:"
|
||||||
|
{ $subsection malloc-object }
|
||||||
|
{ $subsection malloc-array }
|
||||||
|
{ $subsection malloc-byte-array }
|
||||||
|
"There is a set of words in the " { $vocab-link "libc" } " vocabulary which directly call C standard library memory management functions:"
|
||||||
|
{ $subsection malloc }
|
||||||
|
{ $subsection calloc }
|
||||||
|
{ $subsection realloc }
|
||||||
|
"The return value of the above three words must always be checked for a memory allocation failure:"
|
||||||
|
{ $subsection check-ptr }
|
||||||
|
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
|
||||||
|
{ $subsection free }
|
||||||
|
"You can unsafely copy a range of bytes from one memory location to another:"
|
||||||
|
{ $subsection memcpy }
|
||||||
|
"You can copy a range of bytes from memory into a byte array:"
|
||||||
|
{ $subsection memory>byte-array }
|
||||||
|
"You can copy a byte array to memory unsafely:"
|
||||||
|
{ $subsection byte-array>memory }
|
||||||
|
"A wrapper for temporarily allocating a block of memory:"
|
||||||
|
{ $subsection with-malloc } ;
|
||||||
|
|
||||||
|
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 } "."
|
||||||
|
$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 }
|
||||||
|
{ $subsection memory>char-string }
|
||||||
|
{ $subsection memory>u16-string }
|
||||||
|
{ $subsection string>char-memory }
|
||||||
|
{ $subsection string>u16-memory } ;
|
||||||
|
|
||||||
|
ARTICLE: "c-data" "Passing data between Factor and C"
|
||||||
|
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
|
||||||
|
{ $subsection "c-types-specs" }
|
||||||
|
{ $subsection "c-byte-arrays" }
|
||||||
|
{ $subsection "malloc" }
|
||||||
|
{ $subsection "c-strings" }
|
||||||
|
{ $subsection "c-arrays" }
|
||||||
|
{ $subsection "c-out-params" }
|
||||||
|
"C-style enumerated types are supported:"
|
||||||
|
{ $subsection POSTPONE: C-ENUM: }
|
||||||
|
"C types can be aliased for convenience and consitency with native library documentation:"
|
||||||
|
{ $subsection POSTPONE: TYPEDEF: }
|
||||||
|
"New C types can be defined:"
|
||||||
|
{ $subsection "c-structs" }
|
||||||
|
{ $subsection "c-unions" }
|
||||||
|
{ $subsection "reading-writing-memory" } ;
|
||||||
|
|
|
||||||
|
|
@ -2,16 +2,16 @@ IN: temporary
|
||||||
USING: alien alien.syntax alien.c-types kernel tools.test
|
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||||
sequences system libc ;
|
sequences system libc ;
|
||||||
|
|
||||||
[ "\u00ff" ]
|
[ "\u0000ff" ]
|
||||||
[ "\u00ff" string>char-alien alien>char-string ]
|
[ "\u0000ff" string>char-alien alien>char-string ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
[ "hello world" ]
|
[ "hello world" ]
|
||||||
[ "hello world" string>char-alien alien>char-string ]
|
[ "hello world" string>char-alien alien>char-string ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
[ "hello\uabcdworld" ]
|
[ "hello\u00abcdworld" ]
|
||||||
[ "hello\uabcdworld" string>u16-alien alien>u16-string ]
|
[ "hello\u00abcdworld" string>u16-alien alien>u16-string ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
[ t ] [ f expired? ] unit-test
|
[ t ] [ f expired? ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
USING: byte-arrays arrays generator.registers assocs
|
USING: byte-arrays arrays generator.registers assocs
|
||||||
kernel kernel.private libc math namespaces parser sequences
|
kernel kernel.private libc math namespaces parser sequences
|
||||||
strings words assocs splitting math.parser cpu.architecture
|
strings words assocs splitting math.parser cpu.architecture
|
||||||
alien quotations system compiler.units ;
|
alien alien.accessors quotations system compiler.units ;
|
||||||
IN: alien.c-types
|
IN: alien.c-types
|
||||||
|
|
||||||
TUPLE: c-type
|
TUPLE: c-type
|
||||||
|
|
@ -138,6 +138,28 @@ M: c-type stack-size c-type-size ;
|
||||||
: malloc-u16-string ( string -- alien )
|
: malloc-u16-string ( string -- alien )
|
||||||
string>u16-alien malloc-byte-array ;
|
string>u16-alien malloc-byte-array ;
|
||||||
|
|
||||||
|
: memory>byte-array ( alien len -- byte-array )
|
||||||
|
dup <byte-array> [ -rot memcpy ] keep ;
|
||||||
|
|
||||||
|
: memory>char-string ( alien len -- string )
|
||||||
|
memory>byte-array >string ;
|
||||||
|
|
||||||
|
DEFER: c-ushort-array>
|
||||||
|
|
||||||
|
: memory>u16-string ( alien len -- string )
|
||||||
|
[ memory>byte-array ] keep 2/ c-ushort-array> >string ;
|
||||||
|
|
||||||
|
: byte-array>memory ( byte-array base -- )
|
||||||
|
swap dup length memcpy ;
|
||||||
|
|
||||||
|
: string>char-memory ( string base -- )
|
||||||
|
>r >byte-array r> byte-array>memory ;
|
||||||
|
|
||||||
|
DEFER: >c-ushort-array
|
||||||
|
|
||||||
|
: string>u16-memory ( string base -- )
|
||||||
|
>r >c-ushort-array r> byte-array>memory ;
|
||||||
|
|
||||||
: (define-nth) ( word type quot -- )
|
: (define-nth) ( word type quot -- )
|
||||||
>r heap-size [ rot * ] swap add* r> append define-inline ;
|
>r heap-size [ rot * ] swap add* r> append define-inline ;
|
||||||
|
|
||||||
|
|
@ -358,4 +380,7 @@ M: long-long-type box-return ( type -- )
|
||||||
"ushort*" define-primitive-type
|
"ushort*" define-primitive-type
|
||||||
|
|
||||||
[ string>u16-alien ] "ushort*" c-type set-c-type-prep
|
[ string>u16-alien ] "ushort*" c-type set-c-type-prep
|
||||||
|
|
||||||
|
win64? "longlong" "long" ? "ptrdiff_t" typedef
|
||||||
|
|
||||||
] with-compilation-unit
|
] with-compilation-unit
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,37 @@
|
||||||
USING: alien.structs alien.c-types strings help.markup
|
IN: alien.structs
|
||||||
sequences io arrays ;
|
USING: alien.c-types strings help.markup help.syntax
|
||||||
|
alien.syntax sequences io arrays ;
|
||||||
|
|
||||||
M: string slot-specs c-type struct-type-fields ;
|
M: string slot-specs c-type struct-type-fields ;
|
||||||
|
|
||||||
M: array ($instance) first ($instance) " array" write ;
|
M: array ($instance) first ($instance) " array" write ;
|
||||||
|
|
||||||
|
ARTICLE: "c-structs" "C structure types"
|
||||||
|
"A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."
|
||||||
|
{ $subsection POSTPONE: C-STRUCT: }
|
||||||
|
"Great care must be taken when working with C structures since no type or bounds checking is possible."
|
||||||
|
$nl
|
||||||
|
"An example:"
|
||||||
|
{ $code
|
||||||
|
"C-STRUCT: XVisualInfo"
|
||||||
|
" { \"Visual*\" \"visual\" }"
|
||||||
|
" { \"VisualID\" \"visualid\" }"
|
||||||
|
" { \"int\" \"screen\" }"
|
||||||
|
" { \"uint\" \"depth\" }"
|
||||||
|
" { \"int\" \"class\" }"
|
||||||
|
" { \"ulong\" \"red_mask\" }"
|
||||||
|
" { \"ulong\" \"green_mask\" }"
|
||||||
|
" { \"ulong\" \"blue_mask\" }"
|
||||||
|
" { \"int\" \"colormap_size\" }"
|
||||||
|
" { \"int\" \"bits_per_rgb\" } ;"
|
||||||
|
}
|
||||||
|
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||||
|
$nl
|
||||||
|
"Arrays of C structures can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-STRUCT: } "." ;
|
||||||
|
|
||||||
|
ARTICLE: "c-unions" "C unions"
|
||||||
|
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
|
||||||
|
{ $subsection POSTPONE: C-UNION: }
|
||||||
|
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
|
||||||
|
$nl
|
||||||
|
"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,6 @@
|
||||||
USING: alien alien.c-types alien.structs alien.syntax
|
IN: alien.syntax
|
||||||
alien.syntax.private help.markup help.syntax ;
|
USING: alien alien.c-types alien.structs alien.syntax.private
|
||||||
|
help.markup help.syntax ;
|
||||||
|
|
||||||
HELP: DLL"
|
HELP: DLL"
|
||||||
{ $syntax "DLL\" path\"" }
|
{ $syntax "DLL\" path\"" }
|
||||||
|
|
@ -50,7 +51,13 @@ $nl
|
||||||
HELP: TYPEDEF:
|
HELP: TYPEDEF:
|
||||||
{ $syntax "TYPEDEF: old new" }
|
{ $syntax "TYPEDEF: old new" }
|
||||||
{ $values { "old" "a C type" } { "new" "a C type" } }
|
{ $values { "old" "a C type" } { "new" "a C type" } }
|
||||||
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if ." }
|
||||||
|
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
|
||||||
|
|
||||||
|
HELP: TYPEDEF-IF:
|
||||||
|
{ $syntax "TYPEDEF-IF: word old new" }
|
||||||
|
{ $values { "word" "a word with stack effect " { $snippet "( -- ? )" } } { "old" "a C type" } { "new" "a C type" } }
|
||||||
|
{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } " if " { $snippet "word" } " evaluates to a true value." }
|
||||||
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
|
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
|
||||||
|
|
||||||
HELP: C-STRUCT:
|
HELP: C-STRUCT:
|
||||||
|
|
@ -81,7 +88,7 @@ HELP: typedef
|
||||||
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
||||||
{ $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
|
{ $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ;
|
||||||
|
|
||||||
{ typedef POSTPONE: TYPEDEF: } related-words
|
{ POSTPONE: TYPEDEF-IF: POSTPONE: TYPEDEF: typedef } related-words
|
||||||
|
|
||||||
HELP: c-struct?
|
HELP: c-struct?
|
||||||
{ $values { "type" "a string" } { "?" "a boolean" } }
|
{ $values { "type" "a string" } { "?" "a boolean" } }
|
||||||
|
|
|
||||||
|
|
@ -23,6 +23,15 @@ IN: alien.syntax
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
: indirect-quot ( function-ptr-quot return types abi -- quot )
|
||||||
|
[ alien-indirect ] 3curry compose ;
|
||||||
|
|
||||||
|
: define-indirect ( abi return function-ptr-quot function-name parameters -- )
|
||||||
|
>r pick r> parse-arglist
|
||||||
|
rot create-in dup reset-generic
|
||||||
|
>r >r swapd roll indirect-quot r> r>
|
||||||
|
-rot define-declared ;
|
||||||
|
|
||||||
: DLL" skip-blank parse-string dlopen parsed ; parsing
|
: DLL" skip-blank parse-string dlopen parsed ; parsing
|
||||||
|
|
||||||
: ALIEN: scan string>number <alien> parsed ; parsing
|
: ALIEN: scan string>number <alien> parsed ; parsing
|
||||||
|
|
@ -37,6 +46,9 @@ PRIVATE>
|
||||||
: TYPEDEF:
|
: TYPEDEF:
|
||||||
scan scan typedef ; parsing
|
scan scan typedef ; parsing
|
||||||
|
|
||||||
|
: TYPEDEF-IF:
|
||||||
|
scan-word execute scan scan rot [ typedef ] [ 2drop ] if ; parsing
|
||||||
|
|
||||||
: C-STRUCT:
|
: C-STRUCT:
|
||||||
scan in get
|
scan in get
|
||||||
parse-definition
|
parse-definition
|
||||||
|
|
|
||||||
|
|
@ -64,6 +64,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
|
||||||
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
|
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
|
||||||
"Utility operations built up from the " { $link "assocs-protocol" } ":"
|
"Utility operations built up from the " { $link "assocs-protocol" } ":"
|
||||||
{ $subsection delete-at* }
|
{ $subsection delete-at* }
|
||||||
|
{ $subsection delete-any }
|
||||||
{ $subsection rename-at }
|
{ $subsection rename-at }
|
||||||
{ $subsection change-at }
|
{ $subsection change-at }
|
||||||
{ $subsection at+ }
|
{ $subsection at+ }
|
||||||
|
|
@ -220,6 +221,12 @@ HELP: delete-at*
|
||||||
{ $description "Removes an entry from the assoc and outputs the previous value together with a boolean indicating whether it was present." }
|
{ $description "Removes an entry from the assoc and outputs the previous value together with a boolean indicating whether it was present." }
|
||||||
{ $side-effects "assoc" } ;
|
{ $side-effects "assoc" } ;
|
||||||
|
|
||||||
|
HELP: delete-any
|
||||||
|
{ $values { "assoc" assoc } { "key" "a key" } { "value" "a value" } }
|
||||||
|
{ $description "Removes an undetermined entry from the assoc and outputs it." }
|
||||||
|
{ $errors "Throws an error if the assoc is empty." }
|
||||||
|
{ $notes "This word is useful when using an assoc as an unordered queue which requires constant-time membership tests. Entries are enqueued with " { $link set-at } " and dequeued with " { $link delete-any } "." } ;
|
||||||
|
|
||||||
HELP: rename-at
|
HELP: rename-at
|
||||||
{ $values { "newkey" object } { "key" object } { "assoc" assoc } }
|
{ $values { "newkey" object } { "key" object } { "assoc" assoc } }
|
||||||
{ $description "Removes the values associated to " { $snippet "key" } " and re-adds it as " { $snippet "newkey" } ". Does nothing if the assoc does not contain " { $snippet "key" } "." }
|
{ $description "Removes the values associated to " { $snippet "key" } " and re-adds it as " { $snippet "newkey" } ". Does nothing if the assoc does not contain " { $snippet "key" } "." }
|
||||||
|
|
|
||||||
|
|
@ -77,6 +77,12 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
||||||
: rename-at ( newkey key assoc -- )
|
: rename-at ( newkey key assoc -- )
|
||||||
tuck delete-at* [ -rot set-at ] [ 3drop ] if ;
|
tuck delete-at* [ -rot set-at ] [ 3drop ] if ;
|
||||||
|
|
||||||
|
: delete-any ( assoc -- key value )
|
||||||
|
[
|
||||||
|
[ 2drop t ] assoc-find
|
||||||
|
[ "Assoc is empty" throw ] unless over
|
||||||
|
] keep delete-at ;
|
||||||
|
|
||||||
: assoc-empty? ( assoc -- ? )
|
: assoc-empty? ( assoc -- ? )
|
||||||
assoc-size zero? ;
|
assoc-size zero? ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -46,3 +46,9 @@ IN: temporary
|
||||||
[ ?{ f } ] [
|
[ ?{ f } ] [
|
||||||
1 2 { t f t f } <slice> >bit-array
|
1 2 { t f t f } <slice> >bit-array
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ ?{ t f t f f f } ] [ 6 ?{ t f t } resize-bit-array ] unit-test
|
||||||
|
|
||||||
|
[ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test
|
||||||
|
|
||||||
|
[ -10 ?{ } resize-bit-array ] unit-test-fails
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: math alien kernel kernel.private sequences
|
USING: math alien.accessors kernel kernel.private sequences
|
||||||
sequences.private ;
|
sequences.private ;
|
||||||
IN: bit-arrays
|
IN: bit-arrays
|
||||||
|
|
||||||
|
|
@ -48,6 +48,7 @@ M: bit-array new drop <bit-array> ;
|
||||||
M: bit-array equal?
|
M: bit-array equal?
|
||||||
over bit-array? [ sequence= ] [ 2drop f ] if ;
|
over bit-array? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: bit-array resize
|
||||||
|
resize-bit-array ;
|
||||||
|
|
||||||
INSTANCE: bit-array sequence
|
INSTANCE: bit-array sequence
|
||||||
INSTANCE: bit-array simple-c-ptr
|
|
||||||
INSTANCE: bit-array c-ptr
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,33 @@
|
||||||
|
USING: arrays bit-arrays help.markup help.syntax kernel
|
||||||
|
bit-vectors.private combinators ;
|
||||||
|
IN: bit-vectors
|
||||||
|
|
||||||
|
ARTICLE: "bit-vectors" "Bit vectors"
|
||||||
|
"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
|
||||||
|
$nl
|
||||||
|
"Bit vectors form a class:"
|
||||||
|
{ $subsection bit-vector }
|
||||||
|
{ $subsection bit-vector? }
|
||||||
|
"Creating bit vectors:"
|
||||||
|
{ $subsection >bit-vector }
|
||||||
|
{ $subsection <bit-vector> }
|
||||||
|
"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"
|
||||||
|
{ $code "?V{ } clone" } ;
|
||||||
|
|
||||||
|
ABOUT: "bit-vectors"
|
||||||
|
|
||||||
|
HELP: bit-vector
|
||||||
|
{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;
|
||||||
|
|
||||||
|
HELP: <bit-vector>
|
||||||
|
{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }
|
||||||
|
{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
|
||||||
|
|
||||||
|
HELP: >bit-vector
|
||||||
|
{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }
|
||||||
|
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
|
||||||
|
|
||||||
|
HELP: bit-array>vector
|
||||||
|
{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }
|
||||||
|
{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }
|
||||||
|
{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ;
|
||||||
|
|
@ -0,0 +1,14 @@
|
||||||
|
IN: temporary
|
||||||
|
USING: tools.test bit-vectors vectors sequences kernel math ;
|
||||||
|
|
||||||
|
[ 0 ] [ 123 <bit-vector> length ] unit-test
|
||||||
|
|
||||||
|
: do-it
|
||||||
|
1234 swap [ >r even? r> push ] curry each ;
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
3 <bit-vector> dup do-it
|
||||||
|
3 <vector> dup do-it sequence=
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [ ?V{ } bit-vector? ] unit-test
|
||||||
|
|
@ -0,0 +1,33 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: arrays kernel kernel.private math sequences
|
||||||
|
sequences.private growable bit-arrays ;
|
||||||
|
IN: bit-vectors
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: bit-array>vector ( bit-array length -- bit-vector )
|
||||||
|
bit-vector construct-boa ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: <bit-vector> ( n -- bit-vector )
|
||||||
|
<bit-array> 0 bit-array>vector ; inline
|
||||||
|
|
||||||
|
: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ;
|
||||||
|
|
||||||
|
M: bit-vector like
|
||||||
|
drop dup bit-vector? [
|
||||||
|
dup bit-array?
|
||||||
|
[ dup length bit-array>vector ] [ >bit-vector ] if
|
||||||
|
] unless ;
|
||||||
|
|
||||||
|
M: bit-vector new
|
||||||
|
drop [ <bit-array> ] keep >fixnum bit-array>vector ;
|
||||||
|
|
||||||
|
M: bit-vector equal?
|
||||||
|
over bit-vector? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: bit-array new-resizable drop <bit-vector> ;
|
||||||
|
|
||||||
|
INSTANCE: bit-vector growable
|
||||||
|
|
@ -17,8 +17,6 @@ IN: bootstrap.image
|
||||||
: image-magic HEX: 0f0e0d0c ; inline
|
: image-magic HEX: 0f0e0d0c ; inline
|
||||||
: image-version 4 ; inline
|
: image-version 4 ; inline
|
||||||
|
|
||||||
: char bootstrap-cell 2/ ; inline
|
|
||||||
|
|
||||||
: data-base 1024 ; inline
|
: data-base 1024 ; inline
|
||||||
|
|
||||||
: userenv-size 40 ; inline
|
: userenv-size 40 ; inline
|
||||||
|
|
@ -244,21 +242,19 @@ M: wrapper '
|
||||||
[ emit ] emit-object ;
|
[ emit ] emit-object ;
|
||||||
|
|
||||||
! Strings
|
! Strings
|
||||||
: 16be> 0 [ swap 16 shift bitor ] reduce ;
|
|
||||||
: 16le> <reversed> 16be> ;
|
|
||||||
|
|
||||||
: emit-chars ( seq -- )
|
: emit-chars ( seq -- )
|
||||||
char <groups>
|
bootstrap-cell <groups>
|
||||||
big-endian get [ [ 16be> ] map ] [ [ 16le> ] map ] if
|
big-endian get [ [ be> ] map ] [ [ le> ] map ] if
|
||||||
emit-seq ;
|
emit-seq ;
|
||||||
|
|
||||||
: pack-string ( string -- newstr )
|
: pack-string ( string -- newstr )
|
||||||
dup length 1+ char align 0 pad-right ;
|
dup length 1+ bootstrap-cell align 0 pad-right ;
|
||||||
|
|
||||||
: emit-string ( string -- ptr )
|
: emit-string ( string -- ptr )
|
||||||
string type-number object tag-number [
|
string type-number object tag-number [
|
||||||
dup length emit-fixnum
|
dup length emit-fixnum
|
||||||
f ' emit
|
f ' emit
|
||||||
|
f ' emit
|
||||||
pack-string emit-chars
|
pack-string emit-chars
|
||||||
] emit-object ;
|
] emit-object ;
|
||||||
|
|
||||||
|
|
@ -320,24 +316,33 @@ M: quotation '
|
||||||
! Vectors and sbufs
|
! Vectors and sbufs
|
||||||
|
|
||||||
M: vector '
|
M: vector '
|
||||||
dup underlying ' swap length
|
dup length swap underlying '
|
||||||
vector type-number object tag-number [
|
tuple type-number tuple tag-number [
|
||||||
emit-fixnum ! length
|
4 emit-fixnum
|
||||||
|
vector ' emit
|
||||||
|
f ' emit
|
||||||
emit ! array ptr
|
emit ! array ptr
|
||||||
|
emit-fixnum ! length
|
||||||
] emit-object ;
|
] emit-object ;
|
||||||
|
|
||||||
M: sbuf '
|
M: sbuf '
|
||||||
dup underlying ' swap length
|
dup length swap underlying '
|
||||||
sbuf type-number object tag-number [
|
tuple type-number tuple tag-number [
|
||||||
emit-fixnum ! length
|
4 emit-fixnum
|
||||||
|
sbuf ' emit
|
||||||
|
f ' emit
|
||||||
emit ! array ptr
|
emit ! array ptr
|
||||||
|
emit-fixnum ! length
|
||||||
] emit-object ;
|
] emit-object ;
|
||||||
|
|
||||||
! Hashes
|
! Hashes
|
||||||
|
|
||||||
M: hashtable '
|
M: hashtable '
|
||||||
[ hash-array ' ] keep
|
[ hash-array ' ] keep
|
||||||
hashtable type-number object tag-number [
|
tuple type-number tuple tag-number [
|
||||||
|
5 emit-fixnum
|
||||||
|
hashtable ' emit
|
||||||
|
f ' emit
|
||||||
dup hash-count emit-fixnum
|
dup hash-count emit-fixnum
|
||||||
hash-deleted emit-fixnum
|
hash-deleted emit-fixnum
|
||||||
emit ! array ptr
|
emit ! array ptr
|
||||||
|
|
@ -427,32 +432,22 @@ M: curry '
|
||||||
"Writing image to " write dup write "..." print flush
|
"Writing image to " write dup write "..." print flush
|
||||||
<file-writer> [ (write-image) ] with-stream ;
|
<file-writer> [ (write-image) ] with-stream ;
|
||||||
|
|
||||||
: prepare-profile ( arch -- )
|
: prepare-image ( -- )
|
||||||
"resource:core/bootstrap/layouts/layouts.factor" run-file
|
|
||||||
"resource:core/cpu/" swap {
|
|
||||||
{ "x86.32" "x86/32" }
|
|
||||||
{ "x86.64" "x86/64" }
|
|
||||||
{ "linux-ppc" "ppc/linux" }
|
|
||||||
{ "macosx-ppc" "ppc/macosx" }
|
|
||||||
{ "arm" "arm" }
|
|
||||||
} at "/bootstrap.factor" 3append ?resource-path run-file ;
|
|
||||||
|
|
||||||
: prepare-image ( arch -- )
|
|
||||||
dup architecture set prepare-profile
|
|
||||||
bootstrapping? on
|
bootstrapping? on
|
||||||
load-help? off
|
load-help? off
|
||||||
800000 <vector> image set 20000 <hashtable> objects set ;
|
800000 <vector> image set
|
||||||
|
20000 <hashtable> objects set ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: make-image ( arch -- )
|
: make-image ( arch -- )
|
||||||
[
|
architecture [
|
||||||
prepare-image
|
prepare-image
|
||||||
begin-image
|
begin-image
|
||||||
"resource:/core/bootstrap/stage1.factor" run-file
|
"resource:/core/bootstrap/stage1.factor" run-file
|
||||||
end-image
|
end-image
|
||||||
image get image-name write-image
|
image get image-name write-image
|
||||||
] with-scope ;
|
] with-variable ;
|
||||||
|
|
||||||
: my-arch ( -- arch )
|
: my-arch ( -- arch )
|
||||||
cpu dup "ppc" = [ os "-" rot 3append ] when ;
|
cpu dup "ppc" = [ os "-" rot 3append ] when ;
|
||||||
|
|
@ -460,7 +455,7 @@ PRIVATE>
|
||||||
: make-images ( -- )
|
: make-images ( -- )
|
||||||
{
|
{
|
||||||
"x86.32"
|
"x86.32"
|
||||||
! "x86.64"
|
"x86.64"
|
||||||
"linux-ppc" "macosx-ppc"
|
"linux-ppc" "macosx-ppc"
|
||||||
! "arm"
|
! "arm"
|
||||||
} [ make-image ] each ;
|
} [ make-image ] each ;
|
||||||
|
|
|
||||||
|
|
@ -8,7 +8,7 @@ BIN: 111 tag-mask set
|
||||||
8 num-tags set
|
8 num-tags set
|
||||||
3 tag-bits set
|
3 tag-bits set
|
||||||
|
|
||||||
23 num-types set
|
20 num-types set
|
||||||
|
|
||||||
H{
|
H{
|
||||||
{ fixnum BIN: 000 }
|
{ fixnum BIN: 000 }
|
||||||
|
|
@ -24,17 +24,14 @@ H{
|
||||||
tag-numbers get H{
|
tag-numbers get H{
|
||||||
{ array 8 }
|
{ array 8 }
|
||||||
{ wrapper 9 }
|
{ wrapper 9 }
|
||||||
{ hashtable 10 }
|
{ float-array 10 }
|
||||||
{ vector 11 }
|
{ callstack 11 }
|
||||||
{ string 12 }
|
{ string 12 }
|
||||||
{ sbuf 13 }
|
{ curry 13 }
|
||||||
{ quotation 14 }
|
{ quotation 14 }
|
||||||
{ dll 15 }
|
{ dll 15 }
|
||||||
{ alien 16 }
|
{ alien 16 }
|
||||||
{ word 17 }
|
{ word 17 }
|
||||||
{ byte-array 18 }
|
{ byte-array 18 }
|
||||||
{ bit-array 19 }
|
{ bit-array 19 }
|
||||||
{ float-array 20 }
|
|
||||||
{ curry 21 }
|
|
||||||
{ callstack 22 }
|
|
||||||
} union type-numbers set
|
} union type-numbers set
|
||||||
|
|
|
||||||
|
|
@ -5,35 +5,52 @@ USING: alien arrays byte-arrays generic hashtables
|
||||||
hashtables.private io kernel math namespaces parser sequences
|
hashtables.private io kernel math namespaces parser sequences
|
||||||
strings vectors words quotations assocs layouts classes tuples
|
strings vectors words quotations assocs layouts classes tuples
|
||||||
kernel.private vocabs vocabs.loader source-files definitions
|
kernel.private vocabs vocabs.loader source-files definitions
|
||||||
slots classes.union compiler.units ;
|
slots classes.union compiler.units bootstrap.image.private
|
||||||
|
io.files ;
|
||||||
|
|
||||||
"Creating primitives and basic runtime structures..." print flush
|
"Creating primitives and basic runtime structures..." print flush
|
||||||
|
|
||||||
load-help? off
|
|
||||||
crossref off
|
crossref off
|
||||||
|
|
||||||
! Bring up a bare cross-compiling vocabulary.
|
|
||||||
"syntax" vocab vocab-words bootstrap-syntax set
|
|
||||||
|
|
||||||
"resource:core/bootstrap/syntax.factor" parse-file
|
"resource:core/bootstrap/syntax.factor" parse-file
|
||||||
|
|
||||||
|
"resource:core/cpu/" architecture get {
|
||||||
|
{ "x86.32" "x86/32" }
|
||||||
|
{ "x86.64" "x86/64" }
|
||||||
|
{ "linux-ppc" "ppc/linux" }
|
||||||
|
{ "macosx-ppc" "ppc/macosx" }
|
||||||
|
{ "arm" "arm" }
|
||||||
|
} at "/bootstrap.factor" 3append parse-file
|
||||||
|
|
||||||
|
"resource:core/bootstrap/layouts/layouts.factor" parse-file
|
||||||
|
|
||||||
|
! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
|
||||||
|
|
||||||
|
! Bring up a bare cross-compiling vocabulary.
|
||||||
|
"syntax" vocab vocab-words bootstrap-syntax set
|
||||||
H{ } clone dictionary set
|
H{ } clone dictionary set
|
||||||
H{ } clone changed-words set
|
H{ } clone changed-words set
|
||||||
[ drop ] recompile-hook set
|
[ drop ] recompile-hook set
|
||||||
|
|
||||||
|
call
|
||||||
|
call
|
||||||
call
|
call
|
||||||
|
|
||||||
! Create some empty vocabs where the below primitives and
|
! Create some empty vocabs where the below primitives and
|
||||||
! classes will go
|
! classes will go
|
||||||
{
|
{
|
||||||
"alien"
|
"alien"
|
||||||
|
"alien.accessors"
|
||||||
"arrays"
|
"arrays"
|
||||||
"bit-arrays"
|
"bit-arrays"
|
||||||
|
"bit-vectors"
|
||||||
"byte-arrays"
|
"byte-arrays"
|
||||||
|
"byte-vectors"
|
||||||
"classes.private"
|
"classes.private"
|
||||||
"compiler.units"
|
"compiler.units"
|
||||||
"continuations.private"
|
"continuations.private"
|
||||||
"float-arrays"
|
"float-arrays"
|
||||||
|
"float-vectors"
|
||||||
"generator"
|
"generator"
|
||||||
"growable"
|
"growable"
|
||||||
"hashtables"
|
"hashtables"
|
||||||
|
|
@ -86,12 +103,6 @@ H{ } clone update-map set
|
||||||
: register-builtin ( class -- )
|
: register-builtin ( class -- )
|
||||||
dup "type" word-prop builtins get set-nth ;
|
dup "type" word-prop builtins get set-nth ;
|
||||||
|
|
||||||
: intern-slots ( spec -- spec )
|
|
||||||
[
|
|
||||||
[ dup array? [ first2 create ] when ] map
|
|
||||||
{ slot-spec f } swap append >tuple
|
|
||||||
] map ;
|
|
||||||
|
|
||||||
: lookup-type-number ( word -- n )
|
: lookup-type-number ( word -- n )
|
||||||
global [ target-word ] bind type-number ;
|
global [ target-word ] bind type-number ;
|
||||||
|
|
||||||
|
|
@ -100,8 +111,8 @@ H{ } clone update-map set
|
||||||
dup dup lookup-type-number "type" set-word-prop
|
dup dup lookup-type-number "type" set-word-prop
|
||||||
dup f f builtin-class define-class
|
dup f f builtin-class define-class
|
||||||
dup r> builtin-predicate
|
dup r> builtin-predicate
|
||||||
dup r> intern-slots 2dup "slots" set-word-prop
|
dup r> 1 simple-slots 2dup "slots" set-word-prop
|
||||||
define-slots
|
dupd define-slots
|
||||||
register-builtin ;
|
register-builtin ;
|
||||||
|
|
||||||
H{ } clone typemap set
|
H{ } clone typemap set
|
||||||
|
|
@ -127,14 +138,12 @@ num-types get f <array> builtins set
|
||||||
{
|
{
|
||||||
{ "integer" "math" }
|
{ "integer" "math" }
|
||||||
"numerator"
|
"numerator"
|
||||||
1
|
|
||||||
{ "numerator" "math" }
|
{ "numerator" "math" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
{
|
{
|
||||||
{ "integer" "math" }
|
{ "integer" "math" }
|
||||||
"denominator"
|
"denominator"
|
||||||
2
|
|
||||||
{ "denominator" "math" }
|
{ "denominator" "math" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
|
|
@ -148,14 +157,12 @@ num-types get f <array> builtins set
|
||||||
{
|
{
|
||||||
{ "real" "math" }
|
{ "real" "math" }
|
||||||
"real-part"
|
"real-part"
|
||||||
1
|
|
||||||
{ "real-part" "math" }
|
{ "real-part" "math" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
{
|
{
|
||||||
{ "real" "math" }
|
{ "real" "math" }
|
||||||
"imaginary-part"
|
"imaginary-part"
|
||||||
2
|
|
||||||
{ "imaginary-part" "math" }
|
{ "imaginary-part" "math" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
|
|
@ -172,78 +179,23 @@ num-types get f <array> builtins set
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"wrapped"
|
"wrapped"
|
||||||
1
|
|
||||||
{ "wrapped" "kernel" }
|
{ "wrapped" "kernel" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
"hashtable" "hashtables" create "hashtable?" "hashtables" create
|
|
||||||
{
|
|
||||||
{
|
|
||||||
{ "array-capacity" "sequences.private" }
|
|
||||||
"count"
|
|
||||||
1
|
|
||||||
{ "hash-count" "hashtables.private" }
|
|
||||||
{ "set-hash-count" "hashtables.private" }
|
|
||||||
} {
|
|
||||||
{ "array-capacity" "sequences.private" }
|
|
||||||
"deleted"
|
|
||||||
2
|
|
||||||
{ "hash-deleted" "hashtables.private" }
|
|
||||||
{ "set-hash-deleted" "hashtables.private" }
|
|
||||||
} {
|
|
||||||
{ "array" "arrays" }
|
|
||||||
"array"
|
|
||||||
3
|
|
||||||
{ "hash-array" "hashtables.private" }
|
|
||||||
{ "set-hash-array" "hashtables.private" }
|
|
||||||
}
|
|
||||||
} define-builtin
|
|
||||||
|
|
||||||
"vector" "vectors" create "vector?" "vectors" create
|
|
||||||
{
|
|
||||||
{
|
|
||||||
{ "array-capacity" "sequences.private" }
|
|
||||||
"fill"
|
|
||||||
1
|
|
||||||
{ "length" "sequences" }
|
|
||||||
{ "set-fill" "growable" }
|
|
||||||
} {
|
|
||||||
{ "array" "arrays" }
|
|
||||||
"underlying"
|
|
||||||
2
|
|
||||||
{ "underlying" "growable" }
|
|
||||||
{ "set-underlying" "growable" }
|
|
||||||
}
|
|
||||||
} define-builtin
|
|
||||||
|
|
||||||
"string" "strings" create "string?" "strings" create
|
"string" "strings" create "string?" "strings" create
|
||||||
{
|
{
|
||||||
{
|
{
|
||||||
{ "array-capacity" "sequences.private" }
|
{ "array-capacity" "sequences.private" }
|
||||||
"length"
|
"length"
|
||||||
1
|
|
||||||
{ "length" "sequences" }
|
{ "length" "sequences" }
|
||||||
f
|
f
|
||||||
}
|
} {
|
||||||
} define-builtin
|
{ "object" "kernel" }
|
||||||
|
"aux"
|
||||||
"sbuf" "sbufs" create "sbuf?" "sbufs" create
|
{ "string-aux" "strings.private" }
|
||||||
{
|
{ "set-string-aux" "strings.private" }
|
||||||
{
|
|
||||||
{ "array-capacity" "sequences.private" }
|
|
||||||
"length"
|
|
||||||
1
|
|
||||||
{ "length" "sequences" }
|
|
||||||
{ "set-fill" "growable" }
|
|
||||||
}
|
|
||||||
{
|
|
||||||
{ "string" "strings" }
|
|
||||||
"underlying"
|
|
||||||
2
|
|
||||||
{ "underlying" "growable" }
|
|
||||||
{ "set-underlying" "growable" }
|
|
||||||
}
|
}
|
||||||
} define-builtin
|
} define-builtin
|
||||||
|
|
||||||
|
|
@ -252,14 +204,12 @@ num-types get f <array> builtins set
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"array"
|
"array"
|
||||||
1
|
|
||||||
{ "quotation-array" "quotations.private" }
|
{ "quotation-array" "quotations.private" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"compiled?"
|
"compiled?"
|
||||||
2
|
|
||||||
{ "quotation-compiled?" "quotations" }
|
{ "quotation-compiled?" "quotations" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
|
|
@ -270,7 +220,6 @@ num-types get f <array> builtins set
|
||||||
{
|
{
|
||||||
{ "byte-array" "byte-arrays" }
|
{ "byte-array" "byte-arrays" }
|
||||||
"path"
|
"path"
|
||||||
1
|
|
||||||
{ "(dll-path)" "alien" }
|
{ "(dll-path)" "alien" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
|
|
@ -282,13 +231,11 @@ define-builtin
|
||||||
{
|
{
|
||||||
{ "c-ptr" "alien" }
|
{ "c-ptr" "alien" }
|
||||||
"alien"
|
"alien"
|
||||||
1
|
|
||||||
{ "underlying-alien" "alien" }
|
{ "underlying-alien" "alien" }
|
||||||
f
|
f
|
||||||
} {
|
} {
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"expired?"
|
"expired?"
|
||||||
2
|
|
||||||
{ "expired?" "alien" }
|
{ "expired?" "alien" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
|
|
@ -297,45 +244,40 @@ define-builtin
|
||||||
|
|
||||||
"word" "words" create "word?" "words" create
|
"word" "words" create "word?" "words" create
|
||||||
{
|
{
|
||||||
|
f
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"name"
|
"name"
|
||||||
2
|
|
||||||
{ "word-name" "words" }
|
{ "word-name" "words" }
|
||||||
{ "set-word-name" "words" }
|
{ "set-word-name" "words" }
|
||||||
}
|
}
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"vocabulary"
|
"vocabulary"
|
||||||
3
|
|
||||||
{ "word-vocabulary" "words" }
|
{ "word-vocabulary" "words" }
|
||||||
{ "set-word-vocabulary" "words" }
|
{ "set-word-vocabulary" "words" }
|
||||||
}
|
}
|
||||||
{
|
{
|
||||||
{ "quotation" "quotations" }
|
{ "quotation" "quotations" }
|
||||||
"def"
|
"def"
|
||||||
4
|
|
||||||
{ "word-def" "words" }
|
{ "word-def" "words" }
|
||||||
{ "set-word-def" "words.private" }
|
{ "set-word-def" "words.private" }
|
||||||
}
|
}
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"props"
|
"props"
|
||||||
5
|
|
||||||
{ "word-props" "words" }
|
{ "word-props" "words" }
|
||||||
{ "set-word-props" "words" }
|
{ "set-word-props" "words" }
|
||||||
}
|
}
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"?"
|
"?"
|
||||||
6
|
|
||||||
{ "compiled?" "words" }
|
{ "compiled?" "words" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
{
|
{
|
||||||
{ "fixnum" "math" }
|
{ "fixnum" "math" }
|
||||||
"counter"
|
"counter"
|
||||||
7
|
|
||||||
{ "profile-counter" "tools.profiler.private" }
|
{ "profile-counter" "tools.profiler.private" }
|
||||||
{ "set-profile-counter" "tools.profiler.private" }
|
{ "set-profile-counter" "tools.profiler.private" }
|
||||||
}
|
}
|
||||||
|
|
@ -359,14 +301,12 @@ define-builtin
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"obj"
|
"obj"
|
||||||
1
|
|
||||||
{ "curry-obj" "kernel" }
|
{ "curry-obj" "kernel" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
{
|
{
|
||||||
{ "object" "kernel" }
|
{ "object" "kernel" }
|
||||||
"obj"
|
"obj"
|
||||||
2
|
|
||||||
{ "curry-quot" "kernel" }
|
{ "curry-quot" "kernel" }
|
||||||
f
|
f
|
||||||
}
|
}
|
||||||
|
|
@ -404,6 +344,102 @@ builtins get num-tags get tail f union-class define-class
|
||||||
"tombstone" "hashtables.private" lookup t
|
"tombstone" "hashtables.private" lookup t
|
||||||
2array >tuple 1quotation define-inline
|
2array >tuple 1quotation define-inline
|
||||||
|
|
||||||
|
! Some tuple classes
|
||||||
|
"hashtable" "hashtables" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "array-capacity" "sequences.private" }
|
||||||
|
"count"
|
||||||
|
{ "hash-count" "hashtables.private" }
|
||||||
|
{ "set-hash-count" "hashtables.private" }
|
||||||
|
} {
|
||||||
|
{ "array-capacity" "sequences.private" }
|
||||||
|
"deleted"
|
||||||
|
{ "hash-deleted" "hashtables.private" }
|
||||||
|
{ "set-hash-deleted" "hashtables.private" }
|
||||||
|
} {
|
||||||
|
{ "array" "arrays" }
|
||||||
|
"array"
|
||||||
|
{ "hash-array" "hashtables.private" }
|
||||||
|
{ "set-hash-array" "hashtables.private" }
|
||||||
|
}
|
||||||
|
} define-tuple-class
|
||||||
|
|
||||||
|
"sbuf" "sbufs" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "string" "strings" }
|
||||||
|
"underlying"
|
||||||
|
{ "underlying" "growable" }
|
||||||
|
{ "set-underlying" "growable" }
|
||||||
|
} {
|
||||||
|
{ "array-capacity" "sequences.private" }
|
||||||
|
"length"
|
||||||
|
{ "length" "sequences" }
|
||||||
|
{ "set-fill" "growable" }
|
||||||
|
}
|
||||||
|
} define-tuple-class
|
||||||
|
|
||||||
|
"vector" "vectors" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "array" "arrays" }
|
||||||
|
"underlying"
|
||||||
|
{ "underlying" "growable" }
|
||||||
|
{ "set-underlying" "growable" }
|
||||||
|
} {
|
||||||
|
{ "array-capacity" "sequences.private" }
|
||||||
|
"fill"
|
||||||
|
{ "length" "sequences" }
|
||||||
|
{ "set-fill" "growable" }
|
||||||
|
}
|
||||||
|
} define-tuple-class
|
||||||
|
|
||||||
|
"byte-vector" "byte-vectors" create
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "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
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "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
|
||||||
|
{
|
||||||
|
{
|
||||||
|
{ "float-array" "float-arrays" }
|
||||||
|
"underlying"
|
||||||
|
{ "underlying" "growable" }
|
||||||
|
{ "set-underlying" "growable" }
|
||||||
|
} {
|
||||||
|
{ "array-capacity" "sequences.private" }
|
||||||
|
"fill"
|
||||||
|
{ "length" "sequences" }
|
||||||
|
{ "set-fill" "growable" }
|
||||||
|
}
|
||||||
|
} define-tuple-class
|
||||||
|
|
||||||
! Primitive words
|
! Primitive words
|
||||||
: make-primitive ( word vocab n -- )
|
: make-primitive ( word vocab n -- )
|
||||||
>r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
|
>r create dup reset-word r> [ do-primitive ] curry [ ] like define ;
|
||||||
|
|
@ -412,7 +448,6 @@ builtins get num-tags get tail f union-class define-class
|
||||||
{ "(execute)" "words.private" }
|
{ "(execute)" "words.private" }
|
||||||
{ "(call)" "kernel.private" }
|
{ "(call)" "kernel.private" }
|
||||||
{ "uncurry" "kernel.private" }
|
{ "uncurry" "kernel.private" }
|
||||||
{ "string>sbuf" "sbufs.private" }
|
|
||||||
{ "bignum>fixnum" "math.private" }
|
{ "bignum>fixnum" "math.private" }
|
||||||
{ "float>fixnum" "math.private" }
|
{ "float>fixnum" "math.private" }
|
||||||
{ "fixnum>bignum" "math.private" }
|
{ "fixnum>bignum" "math.private" }
|
||||||
|
|
@ -527,47 +562,44 @@ builtins get num-tags get tail f union-class define-class
|
||||||
{ "<byte-array>" "byte-arrays" }
|
{ "<byte-array>" "byte-arrays" }
|
||||||
{ "<bit-array>" "bit-arrays" }
|
{ "<bit-array>" "bit-arrays" }
|
||||||
{ "<displaced-alien>" "alien" }
|
{ "<displaced-alien>" "alien" }
|
||||||
{ "alien-signed-cell" "alien" }
|
{ "alien-signed-cell" "alien.accessors" }
|
||||||
{ "set-alien-signed-cell" "alien" }
|
{ "set-alien-signed-cell" "alien.accessors" }
|
||||||
{ "alien-unsigned-cell" "alien" }
|
{ "alien-unsigned-cell" "alien.accessors" }
|
||||||
{ "set-alien-unsigned-cell" "alien" }
|
{ "set-alien-unsigned-cell" "alien.accessors" }
|
||||||
{ "alien-signed-8" "alien" }
|
{ "alien-signed-8" "alien.accessors" }
|
||||||
{ "set-alien-signed-8" "alien" }
|
{ "set-alien-signed-8" "alien.accessors" }
|
||||||
{ "alien-unsigned-8" "alien" }
|
{ "alien-unsigned-8" "alien.accessors" }
|
||||||
{ "set-alien-unsigned-8" "alien" }
|
{ "set-alien-unsigned-8" "alien.accessors" }
|
||||||
{ "alien-signed-4" "alien" }
|
{ "alien-signed-4" "alien.accessors" }
|
||||||
{ "set-alien-signed-4" "alien" }
|
{ "set-alien-signed-4" "alien.accessors" }
|
||||||
{ "alien-unsigned-4" "alien" }
|
{ "alien-unsigned-4" "alien.accessors" }
|
||||||
{ "set-alien-unsigned-4" "alien" }
|
{ "set-alien-unsigned-4" "alien.accessors" }
|
||||||
{ "alien-signed-2" "alien" }
|
{ "alien-signed-2" "alien.accessors" }
|
||||||
{ "set-alien-signed-2" "alien" }
|
{ "set-alien-signed-2" "alien.accessors" }
|
||||||
{ "alien-unsigned-2" "alien" }
|
{ "alien-unsigned-2" "alien.accessors" }
|
||||||
{ "set-alien-unsigned-2" "alien" }
|
{ "set-alien-unsigned-2" "alien.accessors" }
|
||||||
{ "alien-signed-1" "alien" }
|
{ "alien-signed-1" "alien.accessors" }
|
||||||
{ "set-alien-signed-1" "alien" }
|
{ "set-alien-signed-1" "alien.accessors" }
|
||||||
{ "alien-unsigned-1" "alien" }
|
{ "alien-unsigned-1" "alien.accessors" }
|
||||||
{ "set-alien-unsigned-1" "alien" }
|
{ "set-alien-unsigned-1" "alien.accessors" }
|
||||||
{ "alien-float" "alien" }
|
{ "alien-float" "alien.accessors" }
|
||||||
{ "set-alien-float" "alien" }
|
{ "set-alien-float" "alien.accessors" }
|
||||||
{ "alien-double" "alien" }
|
{ "alien-double" "alien.accessors" }
|
||||||
{ "set-alien-double" "alien" }
|
{ "set-alien-double" "alien.accessors" }
|
||||||
{ "alien-cell" "alien" }
|
{ "alien-cell" "alien.accessors" }
|
||||||
{ "set-alien-cell" "alien" }
|
{ "set-alien-cell" "alien.accessors" }
|
||||||
{ "alien>char-string" "alien" }
|
{ "alien>char-string" "alien" }
|
||||||
{ "string>char-alien" "alien" }
|
{ "string>char-alien" "alien" }
|
||||||
{ "alien>u16-string" "alien" }
|
{ "alien>u16-string" "alien" }
|
||||||
{ "string>u16-alien" "alien" }
|
{ "string>u16-alien" "alien" }
|
||||||
{ "(throw)" "kernel.private" }
|
{ "(throw)" "kernel.private" }
|
||||||
{ "string>memory" "alien" }
|
|
||||||
{ "memory>string" "alien" }
|
|
||||||
{ "alien-address" "alien" }
|
{ "alien-address" "alien" }
|
||||||
{ "slot" "slots.private" }
|
{ "slot" "slots.private" }
|
||||||
{ "set-slot" "slots.private" }
|
{ "set-slot" "slots.private" }
|
||||||
{ "char-slot" "strings.private" }
|
{ "string-nth" "strings.private" }
|
||||||
{ "set-char-slot" "strings.private" }
|
{ "set-string-nth" "strings.private" }
|
||||||
{ "resize-array" "arrays" }
|
{ "resize-array" "arrays" }
|
||||||
{ "resize-string" "strings" }
|
{ "resize-string" "strings" }
|
||||||
{ "(hashtable)" "hashtables.private" }
|
|
||||||
{ "<array>" "arrays" }
|
{ "<array>" "arrays" }
|
||||||
{ "begin-scan" "memory" }
|
{ "begin-scan" "memory" }
|
||||||
{ "next-object" "memory" }
|
{ "next-object" "memory" }
|
||||||
|
|
@ -582,7 +614,6 @@ builtins get num-tags get tail f union-class define-class
|
||||||
{ "fclose" "io.streams.c" }
|
{ "fclose" "io.streams.c" }
|
||||||
{ "<wrapper>" "kernel" }
|
{ "<wrapper>" "kernel" }
|
||||||
{ "(clone)" "kernel" }
|
{ "(clone)" "kernel" }
|
||||||
{ "array>vector" "vectors.private" }
|
|
||||||
{ "<string>" "strings" }
|
{ "<string>" "strings" }
|
||||||
{ "(>tuple)" "tuples.private" }
|
{ "(>tuple)" "tuples.private" }
|
||||||
{ "array>quotation" "quotations.private" }
|
{ "array>quotation" "quotations.private" }
|
||||||
|
|
@ -602,6 +633,9 @@ builtins get num-tags get tail f union-class define-class
|
||||||
{ "set-innermost-frame-quot" "kernel.private" }
|
{ "set-innermost-frame-quot" "kernel.private" }
|
||||||
{ "call-clear" "kernel" }
|
{ "call-clear" "kernel" }
|
||||||
{ "(os-envs)" "system" }
|
{ "(os-envs)" "system" }
|
||||||
|
{ "resize-byte-array" "byte-arrays" }
|
||||||
|
{ "resize-bit-array" "bit-arrays" }
|
||||||
|
{ "resize-float-array" "float-arrays" }
|
||||||
}
|
}
|
||||||
dup length [ >r first2 r> make-primitive ] 2each
|
dup length [ >r first2 r> make-primitive ] 2each
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -12,7 +12,7 @@ IN: bootstrap.stage2
|
||||||
! you can see what went wrong, instead of dealing with a
|
! you can see what went wrong, instead of dealing with a
|
||||||
! fep
|
! fep
|
||||||
[
|
[
|
||||||
vm file-name windows? [ >lower ".exe" ?tail drop ] when
|
vm file-name windows? [ "." split1 drop ] when
|
||||||
".image" append "output-image" set-global
|
".image" append "output-image" set-global
|
||||||
|
|
||||||
"math tools help compiler ui ui.tools io" "include" set-global
|
"math tools help compiler ui ui.tools io" "include" set-global
|
||||||
|
|
@ -48,8 +48,13 @@ IN: bootstrap.stage2
|
||||||
|
|
||||||
"Compiling remaining words..." print flush
|
"Compiling remaining words..." print flush
|
||||||
|
|
||||||
all-words [ compiled? not ] subset recompile-hook get call
|
"bootstrap.compiler" vocab [
|
||||||
|
vocabs [
|
||||||
|
words "compile" "compiler" lookup execute
|
||||||
|
] each
|
||||||
|
] when
|
||||||
] with-compiler-errors
|
] with-compiler-errors
|
||||||
|
:errors
|
||||||
|
|
||||||
f error set-global
|
f error set-global
|
||||||
f error-continuation set-global
|
f error-continuation set-global
|
||||||
|
|
@ -82,5 +87,5 @@ IN: bootstrap.stage2
|
||||||
"output-image" get resource-path save-image-and-exit
|
"output-image" get resource-path save-image-and-exit
|
||||||
] if
|
] if
|
||||||
] [
|
] [
|
||||||
error. :c "listener" vocab-main execute
|
print-error :c "listener" vocab-main execute
|
||||||
] recover
|
] recover
|
||||||
|
|
|
||||||
|
|
@ -16,12 +16,15 @@ f swap set-vocab-source-loaded?
|
||||||
";"
|
";"
|
||||||
"<PRIVATE"
|
"<PRIVATE"
|
||||||
"?{"
|
"?{"
|
||||||
|
"?V{"
|
||||||
"BIN:"
|
"BIN:"
|
||||||
"B{"
|
"B{"
|
||||||
|
"BV{"
|
||||||
"C:"
|
"C:"
|
||||||
"CHAR:"
|
"CHAR:"
|
||||||
"DEFER:"
|
"DEFER:"
|
||||||
"F{"
|
"F{"
|
||||||
|
"FV{"
|
||||||
"FORGET:"
|
"FORGET:"
|
||||||
"GENERIC#"
|
"GENERIC#"
|
||||||
"GENERIC:"
|
"GENERIC:"
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,8 @@
|
||||||
|
IN: temporary
|
||||||
|
USING: tools.test byte-arrays ;
|
||||||
|
|
||||||
|
[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test
|
||||||
|
|
||||||
|
[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
|
||||||
|
|
||||||
|
[ -10 B{ } resize-byte-array ] unit-test-fails
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel kernel.private alien sequences sequences.private
|
USING: kernel kernel.private alien.accessors sequences
|
||||||
math ;
|
sequences.private math ;
|
||||||
IN: byte-arrays
|
IN: byte-arrays
|
||||||
|
|
||||||
M: byte-array clone (clone) ;
|
M: byte-array clone (clone) ;
|
||||||
|
|
@ -15,6 +15,7 @@ M: byte-array new drop <byte-array> ;
|
||||||
M: byte-array equal?
|
M: byte-array equal?
|
||||||
over byte-array? [ sequence= ] [ 2drop f ] if ;
|
over byte-array? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: byte-array resize
|
||||||
|
resize-byte-array ;
|
||||||
|
|
||||||
INSTANCE: byte-array sequence
|
INSTANCE: byte-array sequence
|
||||||
INSTANCE: byte-array simple-c-ptr
|
|
||||||
INSTANCE: byte-array c-ptr
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,34 @@
|
||||||
|
USING: arrays byte-arrays help.markup help.syntax kernel
|
||||||
|
byte-vectors.private combinators ;
|
||||||
|
IN: byte-vectors
|
||||||
|
|
||||||
|
ARTICLE: "byte-vectors" "Byte vectors"
|
||||||
|
"A byte vector is a resizable mutable sequence of unsigned bytes. The literal syntax is covered in " { $link "syntax-byte-vectors" } ". Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."
|
||||||
|
$nl
|
||||||
|
"Byte vectors form a class:"
|
||||||
|
{ $subsection byte-vector }
|
||||||
|
{ $subsection byte-vector? }
|
||||||
|
"Creating byte vectors:"
|
||||||
|
{ $subsection >byte-vector }
|
||||||
|
{ $subsection <byte-vector> }
|
||||||
|
"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"
|
||||||
|
{ $code "BV{ } clone" } ;
|
||||||
|
|
||||||
|
ABOUT: "byte-vectors"
|
||||||
|
|
||||||
|
HELP: byte-vector
|
||||||
|
{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;
|
||||||
|
|
||||||
|
HELP: <byte-vector>
|
||||||
|
{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }
|
||||||
|
{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;
|
||||||
|
|
||||||
|
HELP: >byte-vector
|
||||||
|
{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }
|
||||||
|
{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }
|
||||||
|
{ $errors "Throws an error if the sequence contains elements other than integers." } ;
|
||||||
|
|
||||||
|
HELP: byte-array>vector
|
||||||
|
{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }
|
||||||
|
{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }
|
||||||
|
{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;
|
||||||
|
|
@ -0,0 +1,14 @@
|
||||||
|
IN: temporary
|
||||||
|
USING: tools.test byte-vectors vectors sequences kernel ;
|
||||||
|
|
||||||
|
[ 0 ] [ 123 <byte-vector> length ] unit-test
|
||||||
|
|
||||||
|
: do-it
|
||||||
|
123 [ over push ] each ;
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
3 <byte-vector> do-it
|
||||||
|
3 <vector> do-it sequence=
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [ BV{ } byte-vector? ] unit-test
|
||||||
|
|
@ -0,0 +1,33 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: arrays kernel kernel.private math sequences
|
||||||
|
sequences.private growable byte-arrays ;
|
||||||
|
IN: byte-vectors
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: byte-array>vector ( byte-array capacity -- byte-vector )
|
||||||
|
byte-vector construct-boa ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: <byte-vector> ( n -- byte-vector )
|
||||||
|
<byte-array> 0 byte-array>vector ; inline
|
||||||
|
|
||||||
|
: >byte-vector ( seq -- byte-vector ) BV{ } clone-like ;
|
||||||
|
|
||||||
|
M: byte-vector like
|
||||||
|
drop dup byte-vector? [
|
||||||
|
dup byte-array?
|
||||||
|
[ dup length byte-array>vector ] [ >byte-vector ] if
|
||||||
|
] unless ;
|
||||||
|
|
||||||
|
M: byte-vector new
|
||||||
|
drop [ <byte-array> ] keep >fixnum byte-array>vector ;
|
||||||
|
|
||||||
|
M: byte-vector equal?
|
||||||
|
over byte-vector? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: byte-array new-resizable drop <byte-vector> ;
|
||||||
|
|
||||||
|
INSTANCE: byte-vector growable
|
||||||
|
|
@ -207,3 +207,14 @@ DEFER: mixin-forget-test-g
|
||||||
|
|
||||||
[ { } mixin-forget-test-g ] unit-test-fails
|
[ { } mixin-forget-test-g ] unit-test-fails
|
||||||
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
|
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
|
||||||
|
|
||||||
|
! Method flattening interfered with mixin update
|
||||||
|
MIXIN: flat-mx-1
|
||||||
|
TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1
|
||||||
|
TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1
|
||||||
|
TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1
|
||||||
|
TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1
|
||||||
|
MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
|
||||||
|
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
|
||||||
|
|
||||||
|
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -255,7 +255,14 @@ PRIVATE>
|
||||||
>r dup word-props r> union over set-word-props
|
>r dup word-props r> union over set-word-props
|
||||||
t "class" set-word-prop ;
|
t "class" set-word-prop ;
|
||||||
|
|
||||||
GENERIC: update-methods ( class -- )
|
GENERIC: update-predicate ( class -- )
|
||||||
|
|
||||||
|
M: class update-predicate drop ;
|
||||||
|
|
||||||
|
: update-predicates ( assoc -- )
|
||||||
|
[ drop update-predicate ] assoc-each ;
|
||||||
|
|
||||||
|
GENERIC: update-methods ( assoc -- )
|
||||||
|
|
||||||
: define-class ( word members superclass metaclass -- )
|
: define-class ( word members superclass metaclass -- )
|
||||||
#! If it was already a class, update methods after.
|
#! If it was already a class, update methods after.
|
||||||
|
|
@ -264,8 +271,9 @@ GENERIC: update-methods ( class -- )
|
||||||
over class-usages [
|
over class-usages [
|
||||||
uncache-classes
|
uncache-classes
|
||||||
dupd (define-class)
|
dupd (define-class)
|
||||||
] keep cache-classes
|
] keep cache-classes r>
|
||||||
r> [ update-methods ] [ drop ] if ;
|
[ class-usages dup update-predicates update-methods ]
|
||||||
|
[ drop ] if ;
|
||||||
|
|
||||||
GENERIC: class ( object -- class ) inline
|
GENERIC: class ( object -- class ) inline
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -20,6 +20,8 @@ PREDICATE: class union-class
|
||||||
over members union-predicate-quot
|
over members union-predicate-quot
|
||||||
define-predicate ;
|
define-predicate ;
|
||||||
|
|
||||||
|
M: union-class update-predicate define-union-predicate ;
|
||||||
|
|
||||||
: define-union-class ( class members -- )
|
: define-union-class ( class members -- )
|
||||||
dupd f union-class define-class define-union-predicate ;
|
dupd f union-class define-class define-union-predicate ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -7,21 +7,6 @@ optimizer definitions math compiler.errors threads graphs
|
||||||
generic ;
|
generic ;
|
||||||
IN: compiler
|
IN: compiler
|
||||||
|
|
||||||
SYMBOL: compiled-crossref
|
|
||||||
|
|
||||||
compiled-crossref global [ H{ } assoc-like ] change-at
|
|
||||||
|
|
||||||
: compiled-xref ( word dependencies -- )
|
|
||||||
2dup "compiled-uses" set-word-prop
|
|
||||||
compiled-crossref get add-vertex* ;
|
|
||||||
|
|
||||||
: compiled-unxref ( word -- )
|
|
||||||
dup "compiled-uses" word-prop
|
|
||||||
compiled-crossref get remove-vertex* ;
|
|
||||||
|
|
||||||
: compiled-usage ( word -- assoc )
|
|
||||||
compiled-crossref get at ;
|
|
||||||
|
|
||||||
: compiled-usages ( words -- seq )
|
: compiled-usages ( words -- seq )
|
||||||
[ [ dup ] H{ } map>assoc dup ] keep [
|
[ [ dup ] H{ } map>assoc dup ] keep [
|
||||||
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
|
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
|
||||||
|
|
@ -41,7 +26,7 @@ compiled-crossref global [ H{ } assoc-like ] change-at
|
||||||
>r dupd save-effect r>
|
>r dupd save-effect r>
|
||||||
f pick compiler-error
|
f pick compiler-error
|
||||||
over compiled-unxref
|
over compiled-unxref
|
||||||
compiled-xref ;
|
over word-vocabulary [ compiled-xref ] [ 2drop ] if ;
|
||||||
|
|
||||||
: compile-succeeded ( word -- effect dependencies )
|
: compile-succeeded ( word -- effect dependencies )
|
||||||
[
|
[
|
||||||
|
|
@ -57,12 +42,9 @@ compiled-crossref global [ H{ } assoc-like ] change-at
|
||||||
[ dupd compile-failed f save-effect ]
|
[ dupd compile-failed f save-effect ]
|
||||||
recover ;
|
recover ;
|
||||||
|
|
||||||
: delete-any ( assoc -- element )
|
|
||||||
[ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ;
|
|
||||||
|
|
||||||
: compile-loop ( assoc -- )
|
: compile-loop ( assoc -- )
|
||||||
dup assoc-empty? [ drop ] [
|
dup assoc-empty? [ drop ] [
|
||||||
dup delete-any (compile)
|
dup delete-any drop (compile)
|
||||||
yield
|
yield
|
||||||
compile-loop
|
compile-loop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
|
||||||
0
extra/catalyst-talk/authors.txt → core/compiler/constants/authors.txt
Normal file → Executable file
0
extra/catalyst-talk/authors.txt → core/compiler/constants/authors.txt
Normal file → Executable file
|
|
@ -10,7 +10,7 @@ IN: compiler.constants
|
||||||
! These constants must match vm/layouts.h
|
! These constants must match vm/layouts.h
|
||||||
: header-offset object tag-number neg ;
|
: header-offset object tag-number neg ;
|
||||||
: float-offset 8 float tag-number - ;
|
: float-offset 8 float tag-number - ;
|
||||||
: string-offset 3 bootstrap-cells object tag-number - ;
|
: string-offset 4 bootstrap-cells object tag-number - ;
|
||||||
: profile-count-offset 7 bootstrap-cells object tag-number - ;
|
: profile-count-offset 7 bootstrap-cells object tag-number - ;
|
||||||
: byte-array-offset 2 bootstrap-cells object tag-number - ;
|
: byte-array-offset 2 bootstrap-cells object tag-number - ;
|
||||||
: alien-offset 3 bootstrap-cells object tag-number - ;
|
: alien-offset 3 bootstrap-cells object tag-number - ;
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
VM memory layout constants
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Compiler warning and error reporting
|
||||||
|
|
@ -1,10 +1,10 @@
|
||||||
IN: temporary
|
IN: temporary
|
||||||
USING: arrays compiler kernel kernel.private math
|
USING: arrays compiler kernel kernel.private math math.constants
|
||||||
math.constants math.private sequences strings tools.test words
|
math.private sequences strings tools.test words continuations
|
||||||
continuations sequences.private hashtables.private byte-arrays
|
sequences.private hashtables.private byte-arrays strings.private
|
||||||
strings.private system random layouts vectors.private
|
system random layouts vectors.private sbufs.private
|
||||||
sbufs.private strings.private slots.private alien alien.c-types
|
strings.private slots.private alien alien.accessors
|
||||||
alien.syntax namespaces libc combinators.private ;
|
alien.c-types alien.syntax namespaces libc combinators.private ;
|
||||||
|
|
||||||
! Make sure that intrinsic ops compile to correct code.
|
! Make sure that intrinsic ops compile to correct code.
|
||||||
[ ] [ 1 [ drop ] compile-call ] unit-test
|
[ ] [ 1 [ drop ] compile-call ] unit-test
|
||||||
|
|
@ -36,13 +36,13 @@ alien.syntax namespaces libc combinators.private ;
|
||||||
! Write barrier hits on the wrong value were causing segfaults
|
! Write barrier hits on the wrong value were causing segfaults
|
||||||
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
|
[ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
|
||||||
|
|
||||||
[ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
|
! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
|
||||||
[ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
|
! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
|
||||||
[ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
|
! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
|
||||||
|
!
|
||||||
[ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
|
! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
|
||||||
[ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
|
! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
|
||||||
[ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
|
! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
|
||||||
|
|
||||||
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
|
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
|
||||||
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
|
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
|
||||||
|
|
@ -334,10 +334,6 @@ cell 8 = [
|
||||||
|
|
||||||
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
|
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
|
||||||
|
|
||||||
[ H{ } ] [
|
|
||||||
100 [ (hashtable) ] compile-call [ reset-hash ] keep
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ B{ 0 0 0 0 0 } ] [
|
[ B{ 0 0 0 0 0 } ] [
|
||||||
[ 5 <byte-array> ] compile-call
|
[ 5 <byte-array> ] compile-call
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
||||||
|
|
@ -287,3 +287,7 @@ TUPLE: silly-tuple a b ;
|
||||||
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
|
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
|
||||||
|
|
||||||
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
|
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
|
||||||
|
|
||||||
|
: construct-empty-bug construct-empty ;
|
||||||
|
|
||||||
|
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
USING: compiler definitions generic assocs inference math
|
USING: compiler definitions generic assocs inference math
|
||||||
namespaces parser tools.test words kernel sequences arrays io
|
namespaces parser tools.test words kernel sequences arrays io
|
||||||
effects tools.test.inference compiler.units ;
|
effects tools.test.inference compiler.units inference.state ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
|
||||||
DEFER: x-1
|
DEFER: x-1
|
||||||
|
|
@ -205,3 +205,48 @@ DEFER: generic-then-not-generic-test-2
|
||||||
[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
|
[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
|
||||||
|
|
||||||
[ 4 ] [ generic-then-not-generic-test-2 ] unit-test
|
[ 4 ] [ generic-then-not-generic-test-2 ] unit-test
|
||||||
|
|
||||||
|
DEFER: foldable-test-1
|
||||||
|
DEFER: foldable-test-2
|
||||||
|
|
||||||
|
[ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test
|
||||||
|
|
||||||
|
[ +inlined+ ] [ \ foldable-test-2 \ foldable-test-1 compiled-usage at ] unit-test
|
||||||
|
|
||||||
|
[ 3 ] [ foldable-test-2 ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test
|
||||||
|
|
||||||
|
[ 4 ] [ foldable-test-2 ] unit-test
|
||||||
|
|
||||||
|
DEFER: flushable-test-2
|
||||||
|
|
||||||
|
[ ] [ "IN: temporary USE: kernel : flushable-test-1 drop 3 ; flushable" eval ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: temporary USE: kernel : flushable-test-2 V{ } dup flushable-test-1 drop ;" eval ] unit-test
|
||||||
|
|
||||||
|
[ V{ } ] [ flushable-test-2 ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test
|
||||||
|
|
||||||
|
[ V{ 3 } ] [ flushable-test-2 ] unit-test
|
||||||
|
|
||||||
|
: ax ;
|
||||||
|
: bx ax ;
|
||||||
|
[ \ bx forget ] with-compilation-unit
|
||||||
|
|
||||||
|
[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test
|
||||||
|
|
||||||
|
DEFER: defer-redefine-test-2
|
||||||
|
|
||||||
|
[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test
|
||||||
|
|
||||||
|
[ defer-redefine-test-2 ] unit-test-fails
|
||||||
|
|
||||||
|
[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
|
||||||
|
|
||||||
|
[ 2 1 ] [ defer-redefine-test-2 ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -2,8 +2,8 @@
|
||||||
USING: arrays compiler kernel kernel.private math
|
USING: arrays compiler kernel kernel.private math
|
||||||
hashtables.private math.private namespaces sequences
|
hashtables.private math.private namespaces sequences
|
||||||
sequences.private tools.test namespaces.private slots.private
|
sequences.private tools.test namespaces.private slots.private
|
||||||
combinators.private byte-arrays alien layouts words definitions
|
combinators.private byte-arrays alien alien.accessors layouts
|
||||||
compiler.units ;
|
words definitions compiler.units ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
|
||||||
! Oops!
|
! Oops!
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Compilation units group word definitions for compilation
|
||||||
|
|
@ -68,6 +68,15 @@ $nl
|
||||||
|
|
||||||
ABOUT: "continuations"
|
ABOUT: "continuations"
|
||||||
|
|
||||||
|
HELP: dispose
|
||||||
|
{ $values { "object" "a disposable object" } }
|
||||||
|
{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
|
||||||
|
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
|
||||||
|
|
||||||
|
HELP: with-disposal
|
||||||
|
{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
|
||||||
|
{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
|
||||||
|
|
||||||
HELP: catchstack*
|
HELP: catchstack*
|
||||||
{ $values { "catchstack" "a vector of continuations" } }
|
{ $values { "catchstack" "a vector of continuations" } }
|
||||||
{ $description "Outputs the current catchstack." } ;
|
{ $description "Outputs the current catchstack." } ;
|
||||||
|
|
|
||||||
|
|
@ -135,6 +135,11 @@ PRIVATE>
|
||||||
[ [ , f ] compose [ , drop t ] recover ] curry all?
|
[ [ , f ] compose [ , drop t ] recover ] curry all?
|
||||||
] { } make peek swap [ rethrow ] when ; inline
|
] { } make peek swap [ rethrow ] when ; inline
|
||||||
|
|
||||||
|
GENERIC: dispose ( object -- )
|
||||||
|
|
||||||
|
: with-disposal ( object quot -- )
|
||||||
|
over [ dispose ] curry [ ] cleanup ; inline
|
||||||
|
|
||||||
TUPLE: condition restarts continuation ;
|
TUPLE: condition restarts continuation ;
|
||||||
|
|
||||||
: <condition> ( error restarts cc -- condition )
|
: <condition> ( error restarts cc -- condition )
|
||||||
|
|
|
||||||
|
|
@ -51,14 +51,8 @@ HOOK: %save-dispatch-xt compiler-backend ( -- )
|
||||||
|
|
||||||
M: object %save-dispatch-xt %save-word-xt ;
|
M: object %save-dispatch-xt %save-word-xt ;
|
||||||
|
|
||||||
! Call C primitive
|
! Call another word
|
||||||
HOOK: %call-primitive compiler-backend ( label -- )
|
HOOK: %call compiler-backend ( word -- )
|
||||||
|
|
||||||
! Call another label
|
|
||||||
HOOK: %call-label compiler-backend ( label -- )
|
|
||||||
|
|
||||||
! Far jump to C primitive
|
|
||||||
HOOK: %jump-primitive compiler-backend ( label -- )
|
|
||||||
|
|
||||||
! Local jump for branches
|
! Local jump for branches
|
||||||
HOOK: %jump-label compiler-backend ( label -- )
|
HOOK: %jump-label compiler-backend ( label -- )
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
compiler
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -383,41 +383,6 @@ IN: cpu.arm.intrinsics
|
||||||
{ +output+ { "out" } }
|
{ +output+ { "out" } }
|
||||||
} define-intrinsic
|
} define-intrinsic
|
||||||
|
|
||||||
\ (hashtable) [
|
|
||||||
hashtable 4 cells %allot
|
|
||||||
R12 f v>operand MOV
|
|
||||||
R12 1 %set-slot
|
|
||||||
R12 2 %set-slot
|
|
||||||
R12 3 %set-slot
|
|
||||||
! Store tagged ptr in reg
|
|
||||||
"out" get object %store-tagged
|
|
||||||
] H{
|
|
||||||
{ +scratch+ { { f "out" } } }
|
|
||||||
{ +output+ { "out" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ string>sbuf [
|
|
||||||
sbuf 3 cells %allot
|
|
||||||
"length" operand 1 %set-slot
|
|
||||||
"string" operand 2 %set-slot
|
|
||||||
"out" get object %store-tagged
|
|
||||||
] H{
|
|
||||||
{ +input+ { { f "string" } { f "length" } } }
|
|
||||||
{ +scratch+ { { f "out" } } }
|
|
||||||
{ +output+ { "out" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ array>vector [
|
|
||||||
vector 3 cells %allot
|
|
||||||
"length" operand 1 %set-slot
|
|
||||||
"array" operand 2 %set-slot
|
|
||||||
"out" get object %store-tagged
|
|
||||||
] H{
|
|
||||||
{ +input+ { { f "array" } { f "length" } } }
|
|
||||||
{ +scratch+ { { f "out" } } }
|
|
||||||
{ +output+ { "out" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
! Alien intrinsics
|
! Alien intrinsics
|
||||||
: %alien-accessor ( quot -- )
|
: %alien-accessor ( quot -- )
|
||||||
"offset" operand dup %untag-fixnum
|
"offset" operand dup %untag-fixnum
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
compiler
|
||||||
|
|
@ -97,26 +97,14 @@ M: ppc-backend %epilogue ( n -- )
|
||||||
1 1 rot ADDI
|
1 1 rot ADDI
|
||||||
0 MTLR ;
|
0 MTLR ;
|
||||||
|
|
||||||
: %prepare-primitive ( word -- )
|
|
||||||
#! Save stack pointer to stack_chain->callstack_top, load XT
|
|
||||||
4 1 MR
|
|
||||||
0 11 LOAD32
|
|
||||||
rc-absolute-ppc-2/2 rel-primitive ;
|
|
||||||
|
|
||||||
: (%call) 11 MTLR BLRL ;
|
: (%call) 11 MTLR BLRL ;
|
||||||
|
|
||||||
M: ppc-backend %call-primitive ( word -- )
|
|
||||||
%prepare-primitive (%call) ;
|
|
||||||
|
|
||||||
: (%jump) 11 MTCTR BCTR ;
|
: (%jump) 11 MTCTR BCTR ;
|
||||||
|
|
||||||
M: ppc-backend %jump-primitive ( word -- )
|
|
||||||
%prepare-primitive (%jump) ;
|
|
||||||
|
|
||||||
: %load-dlsym ( symbol dll register -- )
|
: %load-dlsym ( symbol dll register -- )
|
||||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||||
|
|
||||||
M: ppc-backend %call-label ( label -- ) BL ;
|
M: ppc-backend %call ( label -- ) BL ;
|
||||||
|
|
||||||
M: ppc-backend %jump-label ( label -- ) B ;
|
M: ppc-backend %jump-label ( label -- ) B ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2005, 2007 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types arrays cpu.ppc.assembler
|
USING: alien alien.accessors alien.c-types arrays cpu.ppc.assembler
|
||||||
cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel
|
cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel
|
||||||
kernel.private math math.private namespaces sequences words
|
kernel.private math math.private namespaces sequences words
|
||||||
generic quotations byte-arrays hashtables hashtables.private
|
generic quotations byte-arrays hashtables hashtables.private
|
||||||
|
|
@ -93,30 +93,6 @@ IN: cpu.ppc.intrinsics
|
||||||
}
|
}
|
||||||
} define-intrinsics
|
} define-intrinsics
|
||||||
|
|
||||||
: (%char-slot)
|
|
||||||
"offset" operand "n" operand 2 SRAWI
|
|
||||||
"offset" operand dup "obj" operand ADD ;
|
|
||||||
|
|
||||||
\ char-slot [
|
|
||||||
(%char-slot)
|
|
||||||
"out" operand "offset" operand string-offset LHZ
|
|
||||||
"out" operand dup %tag-fixnum
|
|
||||||
] H{
|
|
||||||
{ +input+ { { f "n" } { f "obj" } } }
|
|
||||||
{ +scratch+ { { f "out" } { f "offset" } } }
|
|
||||||
{ +output+ { "out" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ set-char-slot [
|
|
||||||
(%char-slot)
|
|
||||||
"val" operand dup %untag-fixnum
|
|
||||||
"val" operand "offset" operand string-offset STH
|
|
||||||
] H{
|
|
||||||
{ +input+ { { f "val" } { f "n" } { f "obj" } } }
|
|
||||||
{ +scratch+ { { f "offset" } } }
|
|
||||||
{ +clobber+ { "val" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
: fixnum-register-op ( op -- pair )
|
: fixnum-register-op ( op -- pair )
|
||||||
[ "out" operand "y" operand "x" operand ] swap add H{
|
[ "out" operand "y" operand "x" operand ] swap add H{
|
||||||
{ +input+ { { f "x" } { f "y" } } }
|
{ +input+ { { f "x" } { f "y" } } }
|
||||||
|
|
@ -586,43 +562,6 @@ IN: cpu.ppc.intrinsics
|
||||||
{ +output+ { "wrapper" } }
|
{ +output+ { "wrapper" } }
|
||||||
} define-intrinsic
|
} define-intrinsic
|
||||||
|
|
||||||
\ (hashtable) [
|
|
||||||
hashtable 4 cells %allot
|
|
||||||
f v>operand 12 LI
|
|
||||||
12 11 1 cells STW
|
|
||||||
12 11 2 cells STW
|
|
||||||
12 11 3 cells STW
|
|
||||||
! Store tagged ptr in reg
|
|
||||||
"hashtable" get object %store-tagged
|
|
||||||
] H{
|
|
||||||
{ +scratch+ { { f "hashtable" } } }
|
|
||||||
{ +output+ { "hashtable" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ string>sbuf [
|
|
||||||
sbuf 3 cells %allot
|
|
||||||
"length" operand 11 1 cells STW
|
|
||||||
"string" operand 11 2 cells STW
|
|
||||||
! Store tagged ptr in reg
|
|
||||||
"sbuf" get object %store-tagged
|
|
||||||
] H{
|
|
||||||
{ +input+ { { f "string" } { f "length" } } }
|
|
||||||
{ +scratch+ { { f "sbuf" } } }
|
|
||||||
{ +output+ { "sbuf" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ array>vector [
|
|
||||||
vector 3 cells %allot
|
|
||||||
"length" operand 11 1 cells STW
|
|
||||||
"array" operand 11 2 cells STW
|
|
||||||
! Store tagged ptr in reg
|
|
||||||
"vector" get object %store-tagged
|
|
||||||
] H{
|
|
||||||
{ +input+ { { f "array" } { f "length" } } }
|
|
||||||
{ +scratch+ { { f "vector" } } }
|
|
||||||
{ +output+ { "vector" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
! Alien intrinsics
|
! Alien intrinsics
|
||||||
: %alien-accessor ( quot -- )
|
: %alien-accessor ( quot -- )
|
||||||
"offset" operand dup %untag-fixnum
|
"offset" operand dup %untag-fixnum
|
||||||
|
|
|
||||||
|
|
@ -1,9 +1,10 @@
|
||||||
! Copyright (C) 2007 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: parser layouts system ;
|
USING: parser layouts system kernel ;
|
||||||
IN: bootstrap.ppc
|
IN: bootstrap.ppc
|
||||||
|
|
||||||
: c-area-size 10 bootstrap-cells ;
|
: c-area-size 10 bootstrap-cells ;
|
||||||
: lr-save bootstrap-cell ;
|
: lr-save bootstrap-cell ;
|
||||||
|
|
||||||
"resource:core/cpu/ppc/bootstrap.factor" run-file
|
<< "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
|
||||||
|
call
|
||||||
|
|
|
||||||
|
|
@ -1,9 +1,10 @@
|
||||||
! Copyright (C) 2007 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: parser layouts system ;
|
USING: parser layouts system kernel ;
|
||||||
IN: bootstrap.ppc
|
IN: bootstrap.ppc
|
||||||
|
|
||||||
: c-area-size 14 bootstrap-cells ;
|
: c-area-size 14 bootstrap-cells ;
|
||||||
: lr-save 2 bootstrap-cells ;
|
: lr-save 2 bootstrap-cells ;
|
||||||
|
|
||||||
"resource:core/cpu/ppc/bootstrap.factor" run-file
|
<< "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >>
|
||||||
|
call
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
compiler
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -14,4 +14,5 @@ IN: bootstrap.x86
|
||||||
: fixnum>slot@ arg0 1 SAR ;
|
: fixnum>slot@ arg0 1 SAR ;
|
||||||
: rex-length 0 ;
|
: rex-length 0 ;
|
||||||
|
|
||||||
"resource:core/cpu/x86/bootstrap.factor" run-file
|
<< "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >>
|
||||||
|
call
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
compiler
|
||||||
|
|
@ -14,4 +14,5 @@ IN: bootstrap.x86
|
||||||
: fixnum>slot@ ;
|
: fixnum>slot@ ;
|
||||||
: rex-length 1 ;
|
: rex-length 1 ;
|
||||||
|
|
||||||
"resource:core/cpu/x86/bootstrap.factor" run-file
|
<< "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >>
|
||||||
|
call
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
compiler
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -70,15 +70,7 @@ M: x86-backend %prepare-alien-invoke
|
||||||
temp-reg v>operand 2 cells [+] ds-reg MOV
|
temp-reg v>operand 2 cells [+] ds-reg MOV
|
||||||
temp-reg v>operand 3 cells [+] rs-reg MOV ;
|
temp-reg v>operand 3 cells [+] rs-reg MOV ;
|
||||||
|
|
||||||
M: x86-backend %call-primitive ( word -- )
|
M: x86-backend %call ( label -- ) CALL ;
|
||||||
stack-save-reg stack-reg cell neg [+] LEA
|
|
||||||
address-operand CALL ;
|
|
||||||
|
|
||||||
M: x86-backend %jump-primitive ( word -- )
|
|
||||||
stack-save-reg stack-reg MOV
|
|
||||||
address-operand JMP ;
|
|
||||||
|
|
||||||
M: x86-backend %call-label ( label -- ) CALL ;
|
|
||||||
|
|
||||||
M: x86-backend %jump-label ( label -- ) JMP ;
|
M: x86-backend %jump-label ( label -- ) JMP ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -1,12 +1,13 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien arrays cpu.x86.assembler cpu.x86.allot
|
USING: alien alien.accessors arrays cpu.x86.assembler
|
||||||
cpu.x86.architecture cpu.architecture kernel kernel.private math
|
cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
|
||||||
math.private namespaces quotations sequences
|
kernel.private math math.private namespaces quotations sequences
|
||||||
words generic byte-arrays hashtables hashtables.private
|
words generic byte-arrays hashtables hashtables.private
|
||||||
generator generator.registers generator.fixup sequences.private
|
generator generator.registers generator.fixup sequences.private
|
||||||
sbufs sbufs.private vectors vectors.private layouts system
|
sbufs sbufs.private vectors vectors.private layouts system
|
||||||
tuples.private strings.private slots.private compiler.constants ;
|
tuples.private strings.private slots.private compiler.constants
|
||||||
|
;
|
||||||
IN: cpu.x86.intrinsics
|
IN: cpu.x86.intrinsics
|
||||||
|
|
||||||
! Type checks
|
! Type checks
|
||||||
|
|
@ -153,34 +154,6 @@ IN: cpu.x86.intrinsics
|
||||||
: small-reg-16 BX ; inline
|
: small-reg-16 BX ; inline
|
||||||
: small-reg-32 EBX ; inline
|
: small-reg-32 EBX ; inline
|
||||||
|
|
||||||
\ char-slot [
|
|
||||||
small-reg PUSH
|
|
||||||
"n" operand 2 SHR
|
|
||||||
small-reg dup XOR
|
|
||||||
"obj" operand "n" operand ADD
|
|
||||||
small-reg-16 "obj" operand string-offset [+] MOV
|
|
||||||
small-reg %tag-fixnum
|
|
||||||
"obj" operand small-reg MOV
|
|
||||||
small-reg POP
|
|
||||||
] H{
|
|
||||||
{ +input+ { { f "n" } { f "obj" } } }
|
|
||||||
{ +output+ { "obj" } }
|
|
||||||
{ +clobber+ { "obj" "n" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ set-char-slot [
|
|
||||||
small-reg PUSH
|
|
||||||
"val" operand %untag-fixnum
|
|
||||||
"slot" operand 2 SHR
|
|
||||||
"obj" operand "slot" operand ADD
|
|
||||||
small-reg "val" operand MOV
|
|
||||||
"obj" operand string-offset [+] small-reg-16 MOV
|
|
||||||
small-reg POP
|
|
||||||
] H{
|
|
||||||
{ +input+ { { f "val" } { f "slot" } { f "obj" } } }
|
|
||||||
{ +clobber+ { "val" "slot" "obj" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
! Fixnums
|
! Fixnums
|
||||||
: fixnum-op ( op hash -- pair )
|
: fixnum-op ( op hash -- pair )
|
||||||
>r [ "x" operand "y" operand ] swap add r> 2array ;
|
>r [ "x" operand "y" operand ] swap add r> 2array ;
|
||||||
|
|
@ -447,45 +420,6 @@ IN: cpu.x86.intrinsics
|
||||||
{ +output+ { "wrapper" } }
|
{ +output+ { "wrapper" } }
|
||||||
} define-intrinsic
|
} define-intrinsic
|
||||||
|
|
||||||
\ (hashtable) [
|
|
||||||
hashtable 4 cells [
|
|
||||||
1 object@ f v>operand MOV
|
|
||||||
2 object@ f v>operand MOV
|
|
||||||
3 object@ f v>operand MOV
|
|
||||||
! Store tagged ptr in reg
|
|
||||||
"hashtable" get object %store-tagged
|
|
||||||
] %allot
|
|
||||||
] H{
|
|
||||||
{ +scratch+ { { f "hashtable" } } }
|
|
||||||
{ +output+ { "hashtable" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ string>sbuf [
|
|
||||||
sbuf 3 cells [
|
|
||||||
1 object@ "length" operand MOV
|
|
||||||
2 object@ "string" operand MOV
|
|
||||||
! Store tagged ptr in reg
|
|
||||||
"sbuf" get object %store-tagged
|
|
||||||
] %allot
|
|
||||||
] H{
|
|
||||||
{ +input+ { { f "string" } { f "length" } } }
|
|
||||||
{ +scratch+ { { f "sbuf" } } }
|
|
||||||
{ +output+ { "sbuf" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
\ array>vector [
|
|
||||||
vector 3 cells [
|
|
||||||
1 object@ "length" operand MOV
|
|
||||||
2 object@ "array" operand MOV
|
|
||||||
! Store tagged ptr in reg
|
|
||||||
"vector" get object %store-tagged
|
|
||||||
] %allot
|
|
||||||
] H{
|
|
||||||
{ +input+ { { f "array" } { f "length" } } }
|
|
||||||
{ +scratch+ { { f "vector" } } }
|
|
||||||
{ +output+ { "vector" } }
|
|
||||||
} define-intrinsic
|
|
||||||
|
|
||||||
! Alien intrinsics
|
! Alien intrinsics
|
||||||
: %alien-accessor ( quot -- )
|
: %alien-accessor ( quot -- )
|
||||||
"offset" operand %untag-fixnum
|
"offset" operand %untag-fixnum
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2005, 2007 Slava Pestov.
|
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien arrays cpu.x86.assembler cpu.x86.architecture
|
USING: alien alien.accessors arrays cpu.x86.assembler
|
||||||
cpu.x86.intrinsics generic kernel kernel.private math
|
cpu.x86.architecture cpu.x86.intrinsics generic kernel
|
||||||
math.private memory namespaces sequences words generator
|
kernel.private math math.private memory namespaces sequences
|
||||||
generator.registers cpu.architecture math.floats.private layouts
|
words generator generator.registers cpu.architecture
|
||||||
quotations ;
|
math.floats.private layouts quotations ;
|
||||||
IN: cpu.x86.sse2
|
IN: cpu.x86.sse2
|
||||||
|
|
||||||
: define-float-op ( word op -- )
|
: define-float-op ( word op -- )
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,4 @@
|
||||||
USING: help.markup help.syntax kernel ;
|
USING: help.markup help.syntax kernel quotations ;
|
||||||
IN: dlists
|
IN: dlists
|
||||||
|
|
||||||
ARTICLE: "dlists" "Doubly-linked lists"
|
ARTICLE: "dlists" "Doubly-linked lists"
|
||||||
|
|
@ -13,23 +13,31 @@ $nl
|
||||||
{ $subsection dlist? }
|
{ $subsection dlist? }
|
||||||
"Constructing a dlist:"
|
"Constructing a dlist:"
|
||||||
{ $subsection <dlist> }
|
{ $subsection <dlist> }
|
||||||
"Double-ended queue protocol:"
|
"Working with the front of the list:"
|
||||||
{ $subsection dlist-empty? }
|
|
||||||
{ $subsection push-front }
|
{ $subsection push-front }
|
||||||
|
{ $subsection push-front* }
|
||||||
|
{ $subsection peek-front }
|
||||||
{ $subsection pop-front }
|
{ $subsection pop-front }
|
||||||
{ $subsection pop-front* }
|
{ $subsection pop-front* }
|
||||||
|
"Working with the back of the list:"
|
||||||
{ $subsection push-back }
|
{ $subsection push-back }
|
||||||
|
{ $subsection push-back* }
|
||||||
|
{ $subsection peek-back }
|
||||||
{ $subsection pop-back }
|
{ $subsection pop-back }
|
||||||
{ $subsection pop-back* }
|
{ $subsection pop-back* }
|
||||||
"Finding out the length:"
|
"Finding out the length:"
|
||||||
|
{ $subsection dlist-empty? }
|
||||||
{ $subsection dlist-length }
|
{ $subsection dlist-length }
|
||||||
"Iterating over elements:"
|
"Iterating over elements:"
|
||||||
{ $subsection dlist-each }
|
{ $subsection dlist-each }
|
||||||
{ $subsection dlist-find }
|
{ $subsection dlist-find }
|
||||||
{ $subsection dlist-contains? }
|
{ $subsection dlist-contains? }
|
||||||
"Deleting a node matching a predicate:"
|
"Deleting a node:"
|
||||||
{ $subsection delete-node* }
|
|
||||||
{ $subsection delete-node }
|
{ $subsection delete-node }
|
||||||
|
{ $subsection dlist-delete }
|
||||||
|
"Deleting a node matching a predicate:"
|
||||||
|
{ $subsection delete-node-if* }
|
||||||
|
{ $subsection delete-node-if }
|
||||||
"Consuming all nodes:"
|
"Consuming all nodes:"
|
||||||
{ $subsection dlist-slurp } ;
|
{ $subsection dlist-slurp } ;
|
||||||
|
|
||||||
|
|
@ -77,7 +85,7 @@ HELP: pop-back*
|
||||||
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
|
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
|
||||||
|
|
||||||
HELP: dlist-find
|
HELP: dlist-find
|
||||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
||||||
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
|
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
|
||||||
{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
|
{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
|
||||||
$nl
|
$nl
|
||||||
|
|
@ -85,20 +93,20 @@ HELP: dlist-find
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
HELP: dlist-contains?
|
HELP: dlist-contains?
|
||||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } }
|
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } }
|
||||||
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
|
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
|
||||||
{ $notes "This operation is O(n)." } ;
|
{ $notes "This operation is O(n)." } ;
|
||||||
|
|
||||||
HELP: delete-node*
|
HELP: delete-node-if*
|
||||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
|
||||||
{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
|
{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
|
||||||
{ $notes "This operation is O(n)." } ;
|
{ $notes "This operation is O(n)." } ;
|
||||||
|
|
||||||
HELP: delete-node
|
HELP: delete-node-if
|
||||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
|
{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
|
||||||
{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
|
{ $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
|
||||||
{ $notes "This operation is O(n)." } ;
|
{ $notes "This operation is O(n)." } ;
|
||||||
|
|
||||||
HELP: dlist-each
|
HELP: dlist-each
|
||||||
{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } }
|
{ $values { "quot" quotation } { "dlist" { $link dlist } } }
|
||||||
{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;
|
{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;
|
||||||
|
|
|
||||||
|
|
@ -49,14 +49,14 @@ IN: temporary
|
||||||
[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
|
[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
|
||||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
|
[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
|
||||||
|
|
||||||
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node ] unit-test
|
[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node-if ] unit-test
|
||||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
|
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
|
||||||
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
|
[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
|
||||||
[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
|
[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
|
||||||
[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
|
[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
|
||||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
|
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
|
||||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test
|
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test
|
||||||
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test
|
[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test
|
||||||
|
|
||||||
[ 0 ] [ <dlist> dlist-length ] unit-test
|
[ 0 ] [ <dlist> dlist-length ] unit-test
|
||||||
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
|
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -63,12 +63,22 @@ C: <dlist-node> dlist-node
|
||||||
>r dlist-front r> (dlist-each-node) ; inline
|
>r dlist-front r> (dlist-each-node) ; inline
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: push-front ( obj dlist -- )
|
: push-front* ( obj dlist -- dlist-node )
|
||||||
[ dlist-front f swap <dlist-node> dup set-next-prev ] keep
|
[ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep
|
||||||
[ set-dlist-front ] keep
|
[ set-dlist-front ] keep
|
||||||
[ set-back-to-front ] keep
|
[ set-back-to-front ] keep
|
||||||
inc-length ;
|
inc-length ;
|
||||||
|
|
||||||
|
: push-front ( obj dlist -- )
|
||||||
|
push-front* drop ;
|
||||||
|
|
||||||
|
: push-back* ( obj dlist -- dlist-node )
|
||||||
|
[ dlist-back f <dlist-node> ] keep
|
||||||
|
[ dlist-back set-next-when ] 2keep
|
||||||
|
[ set-dlist-back ] 2keep
|
||||||
|
[ set-front-to-back ] keep
|
||||||
|
inc-length ;
|
||||||
|
|
||||||
: push-back ( obj dlist -- )
|
: push-back ( obj dlist -- )
|
||||||
[ dlist-back f <dlist-node> ] keep
|
[ dlist-back f <dlist-node> ] keep
|
||||||
[ dlist-back set-next-when ] 2keep
|
[ dlist-back set-next-when ] 2keep
|
||||||
|
|
@ -76,9 +86,13 @@ PRIVATE>
|
||||||
[ set-front-to-back ] keep
|
[ set-front-to-back ] keep
|
||||||
inc-length ;
|
inc-length ;
|
||||||
|
|
||||||
|
: peek-front ( dlist -- obj )
|
||||||
|
dlist-front dlist-node-obj ;
|
||||||
|
|
||||||
: pop-front ( dlist -- obj )
|
: pop-front ( dlist -- obj )
|
||||||
dup dlist-front [
|
dup dlist-front [
|
||||||
dlist-node-next
|
dup dlist-node-next
|
||||||
|
f rot set-dlist-node-next
|
||||||
f over set-prev-when
|
f over set-prev-when
|
||||||
swap set-dlist-front
|
swap set-dlist-front
|
||||||
] 2keep dlist-node-obj
|
] 2keep dlist-node-obj
|
||||||
|
|
@ -86,14 +100,17 @@ PRIVATE>
|
||||||
|
|
||||||
: pop-front* ( dlist -- ) pop-front drop ;
|
: pop-front* ( dlist -- ) pop-front drop ;
|
||||||
|
|
||||||
|
: peek-back ( dlist -- obj )
|
||||||
|
dlist-back dlist-node-obj ;
|
||||||
|
|
||||||
: pop-back ( dlist -- obj )
|
: pop-back ( dlist -- obj )
|
||||||
[
|
dup dlist-back [
|
||||||
dlist-back dup dlist-node-prev f over set-next-when
|
dup dlist-node-prev
|
||||||
] keep
|
f rot set-dlist-node-prev
|
||||||
[ set-dlist-back ] keep
|
f over set-next-when
|
||||||
[ normalize-front ] keep
|
swap set-dlist-back
|
||||||
dec-length
|
] 2keep dlist-node-obj
|
||||||
dlist-node-obj ;
|
swap [ normalize-front ] keep dec-length ;
|
||||||
|
|
||||||
: pop-back* ( dlist -- ) pop-back drop ;
|
: pop-back* ( dlist -- ) pop-back drop ;
|
||||||
|
|
||||||
|
|
@ -107,25 +124,25 @@ PRIVATE>
|
||||||
dup dlist-node-prev over dlist-node-next set-prev-when
|
dup dlist-node-prev over dlist-node-next set-prev-when
|
||||||
dup dlist-node-next swap dlist-node-prev set-next-when ;
|
dup dlist-node-next swap dlist-node-prev set-next-when ;
|
||||||
|
|
||||||
: (delete-node) ( dlist dlist-node -- )
|
: delete-node ( dlist dlist-node -- )
|
||||||
{
|
{
|
||||||
{ [ over dlist-front over eq? ] [ drop pop-front* ] }
|
{ [ over dlist-front over eq? ] [ drop pop-front* ] }
|
||||||
{ [ over dlist-back over eq? ] [ drop pop-back* ] }
|
{ [ over dlist-back over eq? ] [ drop pop-back* ] }
|
||||||
{ [ t ] [ unlink-node dec-length ] }
|
{ [ t ] [ unlink-node dec-length ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: delete-node* ( quot dlist -- obj/f ? )
|
: delete-node-if* ( quot dlist -- obj/f ? )
|
||||||
tuck dlist-find-node [
|
tuck dlist-find-node [
|
||||||
[ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if*
|
[ delete-node ] keep [ dlist-node-obj t ] [ f f ] if*
|
||||||
] [
|
] [
|
||||||
2drop f f
|
2drop f f
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
: delete-node ( quot dlist -- obj/f )
|
: delete-node-if ( quot dlist -- obj/f )
|
||||||
delete-node* drop ; inline
|
delete-node-if* drop ; inline
|
||||||
|
|
||||||
: dlist-delete ( obj dlist -- obj/f )
|
: dlist-delete ( obj dlist -- obj/f )
|
||||||
>r [ eq? ] curry r> delete-node ;
|
>r [ eq? ] curry r> delete-node-if ;
|
||||||
|
|
||||||
: dlist-each ( dlist quot -- )
|
: dlist-each ( dlist quot -- )
|
||||||
[ dlist-node-obj ] swap compose dlist-each-node ; inline
|
[ dlist-node-obj ] swap compose dlist-each-node ; inline
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -2,3 +2,9 @@ IN: temporary
|
||||||
USING: float-arrays tools.test ;
|
USING: float-arrays tools.test ;
|
||||||
|
|
||||||
[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test
|
[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test
|
||||||
|
|
||||||
|
[ F{ 1 2 3 0 0 0 } ] [ 6 F{ 1 2 3 } resize-float-array ] unit-test
|
||||||
|
|
||||||
|
[ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test
|
||||||
|
|
||||||
|
[ -10 F{ } resize-float-array ] unit-test-fails
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel kernel.private alien sequences
|
USING: kernel kernel.private alien.accessors sequences
|
||||||
sequences.private math math.private ;
|
sequences.private math math.private ;
|
||||||
IN: float-arrays
|
IN: float-arrays
|
||||||
|
|
||||||
|
|
@ -29,9 +29,10 @@ M: float-array new drop 0.0 <float-array> ;
|
||||||
M: float-array equal?
|
M: float-array equal?
|
||||||
over float-array? [ sequence= ] [ 2drop f ] if ;
|
over float-array? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: float-array resize
|
||||||
|
resize-float-array ;
|
||||||
|
|
||||||
INSTANCE: float-array sequence
|
INSTANCE: float-array sequence
|
||||||
INSTANCE: float-array simple-c-ptr
|
|
||||||
INSTANCE: float-array c-ptr
|
|
||||||
|
|
||||||
: 1float-array ( x -- array ) 1 swap <float-array> ; flushable
|
: 1float-array ( x -- array ) 1 swap <float-array> ; flushable
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,34 @@
|
||||||
|
USING: arrays float-arrays help.markup help.syntax kernel
|
||||||
|
float-vectors.private combinators ;
|
||||||
|
IN: float-vectors
|
||||||
|
|
||||||
|
ARTICLE: "float-vectors" "Float vectors"
|
||||||
|
"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."
|
||||||
|
$nl
|
||||||
|
"Float vectors form a class:"
|
||||||
|
{ $subsection float-vector }
|
||||||
|
{ $subsection float-vector? }
|
||||||
|
"Creating float vectors:"
|
||||||
|
{ $subsection >float-vector }
|
||||||
|
{ $subsection <float-vector> }
|
||||||
|
"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"
|
||||||
|
{ $code "BV{ } clone" } ;
|
||||||
|
|
||||||
|
ABOUT: "float-vectors"
|
||||||
|
|
||||||
|
HELP: float-vector
|
||||||
|
{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ;
|
||||||
|
|
||||||
|
HELP: <float-vector>
|
||||||
|
{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }
|
||||||
|
{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ;
|
||||||
|
|
||||||
|
HELP: >float-vector
|
||||||
|
{ $values { "seq" "a sequence" } { "float-vector" float-vector } }
|
||||||
|
{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." }
|
||||||
|
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
|
||||||
|
|
||||||
|
HELP: float-array>vector
|
||||||
|
{ $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } }
|
||||||
|
{ $description "Creates a new float vector using the array for underlying storage with the specified initial length." }
|
||||||
|
{ $warning "This word is in the " { $vocab-link "float-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >float-vector } " instead." } ;
|
||||||
|
|
@ -0,0 +1,14 @@
|
||||||
|
IN: temporary
|
||||||
|
USING: tools.test float-vectors vectors sequences kernel ;
|
||||||
|
|
||||||
|
[ 0 ] [ 123 <float-vector> length ] unit-test
|
||||||
|
|
||||||
|
: do-it
|
||||||
|
12345 [ over push ] each ;
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
3 <float-vector> do-it
|
||||||
|
3 <vector> do-it sequence=
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [ FV{ } float-vector? ] unit-test
|
||||||
|
|
@ -0,0 +1,33 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: arrays kernel kernel.private math sequences
|
||||||
|
sequences.private growable float-arrays ;
|
||||||
|
IN: float-vectors
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: float-array>vector ( float-array length -- float-vector )
|
||||||
|
float-vector construct-boa ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: <float-vector> ( n -- float-vector )
|
||||||
|
0.0 <float-array> 0 float-array>vector ; inline
|
||||||
|
|
||||||
|
: >float-vector ( seq -- float-vector ) FV{ } clone-like ;
|
||||||
|
|
||||||
|
M: float-vector like
|
||||||
|
drop dup float-vector? [
|
||||||
|
dup float-array?
|
||||||
|
[ dup length float-array>vector ] [ >float-vector ] if
|
||||||
|
] unless ;
|
||||||
|
|
||||||
|
M: float-vector new
|
||||||
|
drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;
|
||||||
|
|
||||||
|
M: float-vector equal?
|
||||||
|
over float-vector? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: float-array new-resizable drop <float-vector> ;
|
||||||
|
|
||||||
|
INSTANCE: float-vector growable
|
||||||
|
|
@ -19,8 +19,8 @@ SYMBOL: compiled
|
||||||
: queue-compile ( word -- )
|
: queue-compile ( word -- )
|
||||||
{
|
{
|
||||||
{ [ dup compiled get key? ] [ drop ] }
|
{ [ dup compiled get key? ] [ drop ] }
|
||||||
|
{ [ dup inlined-block? ] [ drop ] }
|
||||||
{ [ dup primitive? ] [ drop ] }
|
{ [ dup primitive? ] [ drop ] }
|
||||||
{ [ dup deferred? ] [ drop ] }
|
|
||||||
{ [ t ] [ dup compile-queue get set-at ] }
|
{ [ t ] [ dup compile-queue get set-at ] }
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
|
@ -100,21 +100,10 @@ UNION: #terminal
|
||||||
! node
|
! node
|
||||||
M: node generate-node drop iterate-next ;
|
M: node generate-node drop iterate-next ;
|
||||||
|
|
||||||
: %call ( word -- )
|
|
||||||
dup primitive? [ %call-primitive ] [ %call-label ] if ;
|
|
||||||
|
|
||||||
: %jump ( word -- )
|
: %jump ( word -- )
|
||||||
{
|
dup compiling-label get eq?
|
||||||
{ [ dup compiling-label get eq? ] [
|
[ drop current-label-start get ] [ %epilogue-later ] if
|
||||||
drop current-label-start get %jump-label
|
%jump-label ;
|
||||||
] }
|
|
||||||
{ [ dup primitive? ] [
|
|
||||||
%epilogue-later %jump-primitive
|
|
||||||
] }
|
|
||||||
{ [ t ] [
|
|
||||||
%epilogue-later %jump-label
|
|
||||||
] }
|
|
||||||
} cond ;
|
|
||||||
|
|
||||||
: generate-call ( label -- next )
|
: generate-call ( label -- next )
|
||||||
dup maybe-compile
|
dup maybe-compile
|
||||||
|
|
|
||||||
|
|
@ -107,5 +107,5 @@ M: class forget* ( class -- )
|
||||||
dup uncache-class
|
dup uncache-class
|
||||||
forget-word ;
|
forget-word ;
|
||||||
|
|
||||||
M: class update-methods ( class -- )
|
M: assoc update-methods ( assoc -- )
|
||||||
class-usages implementors* [ make-generic ] each ;
|
implementors* [ make-generic ] each ;
|
||||||
|
|
|
||||||
|
|
@ -21,7 +21,7 @@ HELP: set-fill
|
||||||
{ $values { "n" "a new fill pointer" } { "seq" "a resizable sequence" } }
|
{ $values { "n" "a new fill pointer" } { "seq" "a resizable sequence" } }
|
||||||
{ $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." }
|
{ $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." }
|
||||||
{ $side-effects "seq" }
|
{ $side-effects "seq" }
|
||||||
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
|
{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
|
||||||
|
|
||||||
HELP: underlying
|
HELP: underlying
|
||||||
{ $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } }
|
{ $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } }
|
||||||
|
|
@ -30,7 +30,7 @@ HELP: underlying
|
||||||
HELP: set-underlying
|
HELP: set-underlying
|
||||||
{ $values { "underlying" "a sequence" } { "seq" "a resizable sequence" } }
|
{ $values { "underlying" "a sequence" } { "seq" "a resizable sequence" } }
|
||||||
{ $contract "Modifies the underlying storage of a resizable sequence." }
|
{ $contract "Modifies the underlying storage of a resizable sequence." }
|
||||||
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ;
|
{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ;
|
||||||
|
|
||||||
HELP: capacity
|
HELP: capacity
|
||||||
{ $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } }
|
{ $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } }
|
||||||
|
|
|
||||||
|
|
@ -35,8 +35,10 @@ $nl
|
||||||
"Utility words to create a new hashtable from a single key/value pair:"
|
"Utility words to create a new hashtable from a single key/value pair:"
|
||||||
{ $subsection associate }
|
{ $subsection associate }
|
||||||
{ $subsection ?set-at }
|
{ $subsection ?set-at }
|
||||||
"Removing duplicate elements from a sequence in linear time, using a hashtable:"
|
"The final two words pertain to sequences but use a hashtable internally. Removing duplicate elements from a sequence in linear time, using a hashtable:"
|
||||||
{ $subsection prune }
|
{ $subsection prune }
|
||||||
|
"Test if a sequence contains duplicates in linear time:"
|
||||||
|
{ $subsection all-unique? }
|
||||||
{ $subsection "hashtables.private" } ;
|
{ $subsection "hashtables.private" } ;
|
||||||
|
|
||||||
ABOUT: "hashtables"
|
ABOUT: "hashtables"
|
||||||
|
|
@ -114,10 +116,6 @@ HELP: <hashtable>
|
||||||
{ $values { "n" "a positive integer specifying hashtable capacity" } { "hash" "a new hashtable" } }
|
{ $values { "n" "a positive integer specifying hashtable capacity" } { "hash" "a new hashtable" } }
|
||||||
{ $description "Create a new hashtable capable of storing " { $snippet "n" } " key/value pairs before growing." } ;
|
{ $description "Create a new hashtable capable of storing " { $snippet "n" } " key/value pairs before growing." } ;
|
||||||
|
|
||||||
HELP: (hashtable) ( -- hash )
|
|
||||||
{ $values { "hash" "a new hashtable" } }
|
|
||||||
{ $description "Allocates a hashtable stub object without an underlying array. User code should call " { $link <hashtable> } " instead." } ;
|
|
||||||
|
|
||||||
HELP: associate
|
HELP: associate
|
||||||
{ $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } }
|
{ $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } }
|
||||||
{ $description "Create a new hashtable holding one key/value pair." } ;
|
{ $description "Create a new hashtable holding one key/value pair." } ;
|
||||||
|
|
@ -133,6 +131,15 @@ HELP: prune
|
||||||
{ $example "USE: hashtables" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
|
{ $example "USE: hashtables" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
HELP: all-unique?
|
||||||
|
{ $values { "seq" sequence } { "?" "a boolean" } }
|
||||||
|
{ $description "Tests whether a sequence contains any repeated elements." }
|
||||||
|
{ $example
|
||||||
|
"USE: combinators.lib"
|
||||||
|
"{ 0 1 1 2 3 5 } all-unique? ."
|
||||||
|
"f"
|
||||||
|
} ;
|
||||||
|
|
||||||
HELP: rehash
|
HELP: rehash
|
||||||
{ $values { "hash" hashtable } }
|
{ $values { "hash" hashtable } }
|
||||||
{ $description "Rebuild the hashtable. This word should be called if the hashcodes of the hashtable's keys have changed, or if the hashing algorithms themselves have changed, neither of which should occur during normal operation." } ;
|
{ $description "Rebuild the hashtable. This word should be called if the hashcodes of the hashtable's keys have changed, or if the hashing algorithms themselves have changed, neither of which should occur during normal operation." } ;
|
||||||
|
|
|
||||||
|
|
@ -160,3 +160,6 @@ H{ } "x" set
|
||||||
H{ { 1 "one" } { 2 "two" } }
|
H{ { 1 "one" } { 2 "two" } }
|
||||||
{ 1 2 3 } clone [ substitute ] keep
|
{ 1 2 3 } clone [ substitute ] keep
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
|
||||||
|
[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -122,7 +122,7 @@ IN: hashtables
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: <hashtable> ( n -- hash )
|
: <hashtable> ( n -- hash )
|
||||||
(hashtable) [ reset-hash ] keep ;
|
hashtable construct-empty [ reset-hash ] keep ;
|
||||||
|
|
||||||
M: hashtable at* ( key hash -- value ? )
|
M: hashtable at* ( key hash -- value ? )
|
||||||
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
|
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
|
||||||
|
|
@ -195,4 +195,7 @@ M: hashtable assoc-like
|
||||||
dup length <hashtable> over length <vector>
|
dup length <hashtable> over length <vector>
|
||||||
rot [ >r 2dup r> (prune) ] each nip ;
|
rot [ >r 2dup r> (prune) ] each nip ;
|
||||||
|
|
||||||
|
: all-unique? ( seq -- ? )
|
||||||
|
dup prune [ length ] 2apply = ;
|
||||||
|
|
||||||
INSTANCE: hashtable assoc
|
INSTANCE: hashtable assoc
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
Doug Coleman
|
||||||
|
Ryan Murphy
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Maxheap and minheap implementations of priority queues
|
||||||
|
|
@ -402,10 +402,14 @@ TUPLE: recursive-declare-error word ;
|
||||||
dup node-param #return node,
|
dup node-param #return node,
|
||||||
dataflow-graph get 1array over set-node-children ;
|
dataflow-graph get 1array over set-node-children ;
|
||||||
|
|
||||||
|
: inlined-block? "inlined-block" word-prop ;
|
||||||
|
|
||||||
|
: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
|
||||||
|
|
||||||
: inline-block ( word -- node-block data )
|
: inline-block ( word -- node-block data )
|
||||||
[
|
[
|
||||||
copy-inference nest-node
|
copy-inference nest-node
|
||||||
dup word-def swap gensym
|
dup word-def swap <inlined-block>
|
||||||
[ infer-quot-recursive ] 2keep
|
[ infer-quot-recursive ] 2keep
|
||||||
#label unnest-node
|
#label unnest-node
|
||||||
] H{ } make-assoc ;
|
] H{ } make-assoc ;
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays generic assocs hashtables inference kernel
|
USING: arrays generic assocs hashtables inference kernel
|
||||||
math namespaces sequences words parser math.intervals
|
math namespaces sequences words parser math.intervals
|
||||||
effects classes inference.dataflow inference.backend ;
|
effects classes inference.dataflow inference.backend
|
||||||
|
combinators ;
|
||||||
IN: inference.class
|
IN: inference.class
|
||||||
|
|
||||||
! Class inference
|
! Class inference
|
||||||
|
|
@ -181,8 +182,11 @@ M: pair constraint-satisfied?
|
||||||
] if* ;
|
] if* ;
|
||||||
|
|
||||||
: default-output-classes ( word -- classes )
|
: default-output-classes ( word -- classes )
|
||||||
"inferred-effect" word-prop effect-out
|
"inferred-effect" word-prop {
|
||||||
dup [ class? ] all? [ drop f ] unless ;
|
{ [ dup not ] [ drop f ] }
|
||||||
|
{ [ dup effect-out [ class? ] all? not ] [ drop f ] }
|
||||||
|
{ [ t ] [ effect-out ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: compute-output-classes ( node word -- classes intervals )
|
: compute-output-classes ( node word -- classes intervals )
|
||||||
dup node-param "output-classes" word-prop dup
|
dup node-param "output-classes" word-prop dup
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
USING: help.syntax help.markup kernel sequences words io
|
USING: help.syntax help.markup kernel sequences words io
|
||||||
effects inference.dataflow inference.backend
|
effects inference.dataflow inference.backend classes
|
||||||
math combinators inference.transforms inference.state ;
|
math combinators inference.transforms inference.state ;
|
||||||
IN: inference
|
IN: inference
|
||||||
|
|
||||||
|
|
@ -93,8 +93,8 @@ $nl
|
||||||
ABOUT: "inference"
|
ABOUT: "inference"
|
||||||
|
|
||||||
HELP: inference-error
|
HELP: inference-error
|
||||||
{ $values { "msg" "an object" } }
|
{ $values { "class" class } }
|
||||||
{ $description "Throws an " { $link inference-error } "." }
|
{ $description "Creates an instance of " { $snippet "class" } ", wraps it in an " { $link inference-error } " and throws the result." }
|
||||||
{ $error-description
|
{ $error-description
|
||||||
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
|
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
|
||||||
$nl
|
$nl
|
||||||
|
|
|
||||||
|
|
@ -421,6 +421,8 @@ DEFER: bar
|
||||||
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
|
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
|
||||||
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
|
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
|
||||||
|
|
||||||
|
\ dispose must-infer
|
||||||
|
|
||||||
! Test stream protocol
|
! Test stream protocol
|
||||||
\ set-timeout must-infer
|
\ set-timeout must-infer
|
||||||
\ stream-read must-infer
|
\ stream-read must-infer
|
||||||
|
|
@ -430,7 +432,6 @@ DEFER: bar
|
||||||
\ stream-write must-infer
|
\ stream-write must-infer
|
||||||
\ stream-write1 must-infer
|
\ stream-write1 must-infer
|
||||||
\ stream-nl must-infer
|
\ stream-nl must-infer
|
||||||
\ stream-close must-infer
|
|
||||||
\ stream-format must-infer
|
\ stream-format must-infer
|
||||||
\ stream-write-table must-infer
|
\ stream-write-table must-infer
|
||||||
\ stream-flush must-infer
|
\ stream-flush must-infer
|
||||||
|
|
|
||||||
|
|
@ -1,15 +1,16 @@
|
||||||
! Copyright (C) 2004, 2007 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien arrays bit-arrays byte-arrays classes
|
USING: alien alien.accessors arrays bit-arrays byte-arrays
|
||||||
combinators.private continuations.private effects float-arrays
|
classes combinators.private continuations.private effects
|
||||||
generic hashtables hashtables.private inference.state
|
float-arrays generic hashtables hashtables.private
|
||||||
inference.backend inference.dataflow io io.backend io.files
|
inference.state inference.backend inference.dataflow io
|
||||||
io.files.private io.streams.c kernel kernel.private math
|
io.backend io.files io.files.private io.streams.c kernel
|
||||||
math.private memory namespaces namespaces.private parser
|
kernel.private math math.private memory namespaces
|
||||||
prettyprint quotations quotations.private sbufs sbufs.private
|
namespaces.private parser prettyprint quotations
|
||||||
sequences sequences.private slots.private strings
|
quotations.private sbufs sbufs.private sequences
|
||||||
strings.private system threads.private tuples tuples.private
|
sequences.private slots.private strings strings.private system
|
||||||
vectors vectors.private words words.private assocs inspector ;
|
threads.private tuples tuples.private vectors vectors.private
|
||||||
|
words words.private assocs inspector ;
|
||||||
IN: inference.known-words
|
IN: inference.known-words
|
||||||
|
|
||||||
! Shuffle words
|
! Shuffle words
|
||||||
|
|
@ -167,9 +168,6 @@ t over set-effect-terminated?
|
||||||
|
|
||||||
\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
|
\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
|
||||||
|
|
||||||
\ string>sbuf { string integer } { sbuf } <effect> "inferred-effect" set-word-prop
|
|
||||||
\ string>sbuf make-flushable
|
|
||||||
|
|
||||||
\ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
|
\ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||||
\ bignum>fixnum make-foldable
|
\ bignum>fixnum make-foldable
|
||||||
|
|
||||||
|
|
@ -475,10 +473,6 @@ t over set-effect-terminated?
|
||||||
|
|
||||||
\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
|
\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||||
|
|
||||||
\ string>memory { string c-ptr } { } <effect> "inferred-effect" set-word-prop
|
|
||||||
|
|
||||||
\ memory>string { c-ptr integer } { string } <effect> "inferred-effect" set-word-prop
|
|
||||||
|
|
||||||
\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
|
\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
|
||||||
\ alien-address make-flushable
|
\ alien-address make-flushable
|
||||||
|
|
||||||
|
|
@ -487,20 +481,26 @@ t over set-effect-terminated?
|
||||||
|
|
||||||
\ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop
|
\ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop
|
||||||
|
|
||||||
\ char-slot { fixnum object } { fixnum } <effect> "inferred-effect" set-word-prop
|
\ string-nth { fixnum string } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||||
\ char-slot make-flushable
|
\ string-nth make-flushable
|
||||||
|
|
||||||
\ set-char-slot { fixnum fixnum object } { } <effect> "inferred-effect" set-word-prop
|
\ set-string-nth { fixnum fixnum string } { } <effect> "inferred-effect" set-word-prop
|
||||||
|
|
||||||
\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
|
\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
|
||||||
\ resize-array make-flushable
|
\ resize-array make-flushable
|
||||||
|
|
||||||
|
\ resize-byte-array { integer byte-array } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||||
|
\ resize-byte-array make-flushable
|
||||||
|
|
||||||
|
\ resize-bit-array { integer bit-array } { bit-array } <effect> "inferred-effect" set-word-prop
|
||||||
|
\ resize-bit-array make-flushable
|
||||||
|
|
||||||
|
\ resize-float-array { integer float-array } { float-array } <effect> "inferred-effect" set-word-prop
|
||||||
|
\ resize-float-array make-flushable
|
||||||
|
|
||||||
\ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
|
\ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
|
||||||
\ resize-string make-flushable
|
\ resize-string make-flushable
|
||||||
|
|
||||||
\ (hashtable) { } { hashtable } <effect> "inferred-effect" set-word-prop
|
|
||||||
\ (hashtable) make-flushable
|
|
||||||
|
|
||||||
\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
|
\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
|
||||||
\ <array> make-flushable
|
\ <array> make-flushable
|
||||||
|
|
||||||
|
|
@ -536,9 +536,6 @@ t over set-effect-terminated?
|
||||||
\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
|
\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
|
||||||
\ (clone) make-flushable
|
\ (clone) make-flushable
|
||||||
|
|
||||||
\ array>vector { array integer } { vector } <effect> "inferred-effect" set-word-prop
|
|
||||||
\ array>vector make-flushable
|
|
||||||
|
|
||||||
\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
|
\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
|
||||||
\ <string> make-flushable
|
\ <string> make-flushable
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Variables for holding stack effect inference state
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
USING: help.markup help.syntax inference.transforms
|
IN: inference.transforms
|
||||||
combinators words ;
|
USING: help.markup help.syntax combinators words kernel ;
|
||||||
|
|
||||||
HELP: define-transform
|
HELP: define-transform
|
||||||
{ $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } }
|
{ $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } }
|
||||||
|
|
@ -12,3 +12,8 @@ HELP: define-transform
|
||||||
$nl
|
$nl
|
||||||
"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
|
"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":"
|
||||||
{ $code "\\ cond [ cond>quot ] 1 define-transform" } } ;
|
{ $code "\\ cond [ cond>quot ] 1 define-transform" } } ;
|
||||||
|
|
||||||
|
HELP: duplicated-slots-error
|
||||||
|
{ $values { "names" "a sequence of setter words" } }
|
||||||
|
{ $description "Throws a " { $link duplicated-slots-error } "." }
|
||||||
|
{ $error-description "Thrown by stack effect inference if a " { $link set-slots } " form is given an array of slot setters that includes duplicates. Since writing to the same slot multiple times has no useful effect, this is a programmer error, so it is caught at compile time." } ;
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
IN: temporary
|
IN: temporary
|
||||||
USING: sequences inference.transforms tools.test math kernel
|
USING: sequences inference.transforms tools.test math kernel
|
||||||
quotations ;
|
quotations tools.test.inference inference ;
|
||||||
|
|
||||||
: compose-n-quot <repetition> >quotation ;
|
: compose-n-quot <repetition> >quotation ;
|
||||||
: compose-n compose-n-quot call ;
|
: compose-n compose-n-quot call ;
|
||||||
|
|
@ -18,3 +18,17 @@ quotations ;
|
||||||
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
|
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
|
||||||
|
|
||||||
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
|
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
|
||||||
|
|
||||||
|
\ construct-empty must-infer
|
||||||
|
|
||||||
|
TUPLE: a-tuple x y z ;
|
||||||
|
|
||||||
|
: set-slots-test ( x y z -- )
|
||||||
|
{ set-a-tuple-x set-a-tuple-y } set-slots ;
|
||||||
|
|
||||||
|
\ set-slots-test must-infer
|
||||||
|
|
||||||
|
: set-slots-test-2
|
||||||
|
{ set-a-tuple-x set-a-tuple-x } set-slots ;
|
||||||
|
|
||||||
|
[ [ set-slots-test-2 ] infer ] unit-test-fails
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,9 @@
|
||||||
! Copyright (C) 2007 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays kernel words sequences generic math namespaces
|
USING: arrays kernel words sequences generic math namespaces
|
||||||
quotations assocs combinators math.bitfields inference.backend
|
quotations assocs combinators math.bitfields inference.backend
|
||||||
inference.dataflow inference.state tuples.private ;
|
inference.dataflow inference.state tuples.private effects
|
||||||
|
inspector hashtables ;
|
||||||
IN: inference.transforms
|
IN: inference.transforms
|
||||||
|
|
||||||
: pop-literals ( n -- rstate seq )
|
: pop-literals ( n -- rstate seq )
|
||||||
|
|
@ -59,13 +60,34 @@ M: pair (bitfield-quot) ( spec -- quot )
|
||||||
|
|
||||||
\ get-slots [ [get-slots] ] 1 define-transform
|
\ get-slots [ [get-slots] ] 1 define-transform
|
||||||
|
|
||||||
\ set-slots [ <reversed> [get-slots] ] 1 define-transform
|
TUPLE: duplicated-slots-error names ;
|
||||||
|
|
||||||
: [construct] ( word quot -- newquot )
|
M: duplicated-slots-error summary
|
||||||
>r dup +inlined+ depends-on dup tuple-size r> 2curry ;
|
drop "Calling set-slots with duplicate slot setters" ;
|
||||||
|
|
||||||
\ construct-boa
|
: duplicated-slots-error ( names -- * )
|
||||||
[ [ <tuple-boa> ] [construct] ] 1 define-transform
|
\ duplicated-slots-error construct-boa throw ;
|
||||||
|
|
||||||
\ construct-empty
|
\ set-slots [
|
||||||
[ [ <tuple> ] [construct] ] 1 define-transform
|
dup all-unique?
|
||||||
|
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if
|
||||||
|
] 1 define-transform
|
||||||
|
|
||||||
|
\ construct-boa [
|
||||||
|
dup +inlined+ depends-on
|
||||||
|
dup tuple-size [ <tuple-boa> ] 2curry
|
||||||
|
] 1 define-transform
|
||||||
|
|
||||||
|
\ construct-empty [
|
||||||
|
1 ensure-values
|
||||||
|
peek-d value? [
|
||||||
|
pop-literal
|
||||||
|
dup +inlined+ depends-on
|
||||||
|
dup tuple-size [ <tuple> ] 2curry
|
||||||
|
swap infer-quot
|
||||||
|
] [
|
||||||
|
\ construct-empty 1 1 <effect> make-call-node
|
||||||
|
] if
|
||||||
|
] "infer" set-word-prop
|
||||||
|
|
||||||
|
\ construct-empty 1 1 <effect> "inferred-effect" set-word-prop
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2007 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: init kernel system ;
|
USING: init kernel system namespaces ;
|
||||||
IN: io.backend
|
IN: io.backend
|
||||||
|
|
||||||
SYMBOL: io-backend
|
SYMBOL: io-backend
|
||||||
|
|
@ -21,3 +21,6 @@ M: object normalize-pathname ;
|
||||||
|
|
||||||
[ init-io embedded? [ init-stdio ] unless ]
|
[ init-io embedded? [ init-stdio ] unless ]
|
||||||
"io.backend" add-init-hook
|
"io.backend" add-init-hook
|
||||||
|
|
||||||
|
: set-io-backend ( backend -- )
|
||||||
|
io-backend set-global init-io init-stdio ;
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,8 @@
|
||||||
USING: io.binary tools.test ;
|
USING: io.binary tools.test ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
|
||||||
[ "\0\0\u0004\u00d2" ] [ 1234 4 >be ] unit-test
|
[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test
|
||||||
[ "\u00d2\u0004\0\0" ] [ 1234 4 >le ] unit-test
|
[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test
|
||||||
|
|
||||||
[ 1234 ] [ 1234 4 >be be> ] unit-test
|
[ 1234 ] [ 1234 4 >be be> ] unit-test
|
||||||
[ 1234 ] [ 1234 4 >le le> ] unit-test
|
[ 1234 ] [ 1234 4 >le le> ] unit-test
|
||||||
|
|
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue