diff --git a/Makefile b/Makefile index 1042731065..aad7fe90eb 100755 --- a/Makefile +++ b/Makefile @@ -56,6 +56,8 @@ default: @echo "linux-arm" @echo "openbsd-x86-32" @echo "openbsd-x86-64" + @echo "netbsd-x86-32" + @echo "netbsd-x86-64" @echo "macosx-x86-32" @echo "macosx-x86-64" @echo "macosx-ppc" @@ -83,6 +85,12 @@ freebsd-x86-32: 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: ln -sf libfreetype.6.dylib \ Factor.app/Contents/Frameworks/libfreetype.dylib @@ -140,7 +148,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS) clean: rm -f vm/*.o - rm -f libfactor.a + rm -f factor*.dll libfactor*.* vm/resources.o: windres vm/factor.rs vm/resources.o diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 089091bec5..19ee52b039 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -1,6 +1,7 @@ USING: byte-arrays arrays help.syntax help.markup -alien.syntax alien.c-types compiler definitions math libc -debugger parser io io.backend system bit-arrays float-arrays ; +alien.syntax compiler definitions math libc +debugger parser io io.backend system bit-arrays float-arrays +alien.accessors ; IN: alien HELP: alien @@ -156,36 +157,6 @@ ARTICLE: "aliens" "Alien addresses" $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" } "." ; -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 } " or " { $link malloc-object } "." -$nl -"Arrays of C structures can be created by calling " { $link } " 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 } " or " { $link malloc-object } "." -$nl -"Arrays of C unions can be created by calling " { $link } " 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" "Numerical values can be read from memory addresses and converted to Factor objects using the various typed memory accessor words:" { $subsection alien-signed-1 } @@ -253,211 +224,6 @@ $nl { $subsection dlsym } { $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 } " 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 } -{ $subsection } -{ $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 } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -{ $subsection } -"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 } " 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" "The Factor embedding API is defined in " { $snippet "vm/master.h" } "." $nl diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor old mode 100644 new mode 100755 index aedad25906..d5133753c1 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,7 +1,7 @@ IN: temporary -USING: alien byte-arrays -arrays kernel kernel.private namespaces tools.test sequences -libc math system prettyprint ; +USING: alien alien.accessors byte-arrays arrays kernel +kernel.private namespaces tools.test sequences libc math system +prettyprint ; [ t ] [ -1 alien-address 0 > ] unit-test diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 1c8163e2fa..317dac803e 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math namespaces sequences system -kernel.private tuples ; +kernel.private tuples bit-arrays byte-arrays float-arrays ; IN: alien ! Some predicate classes used by the compiler for optimization @@ -9,16 +9,11 @@ IN: alien PREDICATE: alien simple-alien underlying-alien not ; -! These mixins are not intended to be extended by user code. -! They are not unions, because if they were we'd have a circular -! dependency between alien and {byte,bit,float}-arrays. -MIXIN: simple-c-ptr -INSTANCE: simple-alien simple-c-ptr -INSTANCE: f simple-c-ptr +UNION: simple-c-ptr +simple-alien POSTPONE: f byte-array bit-array float-array ; -MIXIN: c-ptr -INSTANCE: alien c-ptr -INSTANCE: f c-ptr +UNION: c-ptr +alien POSTPONE: f byte-array bit-array float-array ; DEFER: pinned-c-ptr? diff --git a/core/alien/arrays/arrays-docs.factor b/core/alien/arrays/arrays-docs.factor new file mode 100755 index 0000000000..f3f27d0739 --- /dev/null +++ b/core/alien/arrays/arrays-docs.factor @@ -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" } ; diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor old mode 100644 new mode 100755 index 55b788d5e3..f6418295f7 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -1,8 +1,10 @@ -USING: alien alien.c-types help.syntax help.markup libc -kernel.private byte-arrays math strings ; +IN: alien.c-types +USING: alien help.syntax help.markup libc kernel.private +byte-arrays math strings hashtables alien.syntax +bit-arrays float-arrays debugger ; HELP: -{ $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" } "." } ; 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." } ; HELP: c-type -{ $values { "name" string } { "type" "a hashtable" } } +{ $values { "name" string } { "type" hashtable } } { $description "Looks up a C type by name." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; 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." } { $examples "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." } ; 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." } { $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 } } { $description "Reads a null-terminated UCS-2 string from the specified address." } ; -HELP: memory>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 Factor string." } ; +HELP: memory>byte-array ( base len -- 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 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 } } -{ $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." } ; HELP: malloc-array @@ -151,3 +171,143 @@ HELP: define-out { $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." } { $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 } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +"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 } " 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 } " 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 } +{ $subsection } +{ $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" } ; diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor old mode 100644 new mode 100755 index c988446e20..3148b85782 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -2,16 +2,16 @@ IN: temporary USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc ; -[ "\u00ff" ] -[ "\u00ff" string>char-alien alien>char-string ] +[ "\u0000ff" ] +[ "\u0000ff" string>char-alien alien>char-string ] unit-test [ "hello world" ] [ "hello world" string>char-alien alien>char-string ] unit-test -[ "hello\uabcdworld" ] -[ "hello\uabcdworld" string>u16-alien alien>u16-string ] +[ "hello\u00abcdworld" ] +[ "hello\u00abcdworld" string>u16-alien alien>u16-string ] unit-test [ t ] [ f expired? ] unit-test diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index b665300bee..88df823e5b 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -3,7 +3,7 @@ USING: byte-arrays arrays generator.registers assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture -alien quotations system compiler.units ; +alien alien.accessors quotations system compiler.units ; IN: alien.c-types TUPLE: c-type @@ -138,6 +138,28 @@ M: c-type stack-size c-type-size ; : malloc-u16-string ( string -- alien ) string>u16-alien malloc-byte-array ; +: memory>byte-array ( alien len -- byte-array ) + dup [ -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 -- ) >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 [ string>u16-alien ] "ushort*" c-type set-c-type-prep + + win64? "longlong" "long" ? "ptrdiff_t" typedef + ] with-compilation-unit diff --git a/core/alien/structs/structs-docs.factor b/core/alien/structs/structs-docs.factor old mode 100644 new mode 100755 index 704a260825..fe19f29766 --- a/core/alien/structs/structs-docs.factor +++ b/core/alien/structs/structs-docs.factor @@ -1,6 +1,37 @@ -USING: alien.structs alien.c-types strings help.markup -sequences io arrays ; +IN: alien.structs +USING: alien.c-types strings help.markup help.syntax +alien.syntax sequences io arrays ; M: string slot-specs c-type struct-type-fields ; 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 } " or " { $link malloc-object } "." +$nl +"Arrays of C structures can be created by calling " { $link } " 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 } " or " { $link malloc-object } "." +$nl +"Arrays of C unions can be created by calling " { $link } " 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: } "." ; diff --git a/core/alien/syntax/syntax-docs.factor b/core/alien/syntax/syntax-docs.factor index d87b67eb59..6565ea0e2c 100755 --- a/core/alien/syntax/syntax-docs.factor +++ b/core/alien/syntax/syntax-docs.factor @@ -1,5 +1,6 @@ -USING: alien alien.c-types alien.structs alien.syntax -alien.syntax.private help.markup help.syntax ; +IN: alien.syntax +USING: alien alien.c-types alien.structs alien.syntax.private +help.markup help.syntax ; HELP: DLL" { $syntax "DLL\" path\"" } @@ -50,7 +51,13 @@ $nl HELP: TYPEDEF: { $syntax "TYPEDEF: old new" } { $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." } ; HELP: C-STRUCT: @@ -81,7 +88,7 @@ HELP: typedef { $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." } { $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ; -{ typedef POSTPONE: TYPEDEF: } related-words +{ POSTPONE: TYPEDEF-IF: POSTPONE: TYPEDEF: typedef } related-words HELP: c-struct? { $values { "type" "a string" } { "?" "a boolean" } } diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 99275d02bf..b81a91efcb 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -23,6 +23,15 @@ IN: alien.syntax 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 : ALIEN: scan string>number parsed ; parsing @@ -37,6 +46,9 @@ PRIVATE> : TYPEDEF: scan scan typedef ; parsing +: TYPEDEF-IF: + scan-word execute scan scan rot [ typedef ] [ 2drop ] if ; parsing + : C-STRUCT: scan in get parse-definition diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor old mode 100644 new mode 100755 index 1805ee05b5..2eabe9b0bc --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -64,6 +64,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" ARTICLE: "assocs-mutation" "Storing keys and values in assocs" "Utility operations built up from the " { $link "assocs-protocol" } ":" { $subsection delete-at* } +{ $subsection delete-any } { $subsection rename-at } { $subsection change-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." } { $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 { $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" } "." } diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor old mode 100644 new mode 100755 index 799a6eb367..d8cf01e1bd --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -77,6 +77,12 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : rename-at ( newkey key assoc -- ) 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-size zero? ; diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor old mode 100644 new mode 100755 index 48698ad91d..f605eba24c --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -46,3 +46,9 @@ IN: temporary [ ?{ f } ] [ 1 2 { t f t f } >bit-array ] 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 diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index 3b847a0060..ee485d399e 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! 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 ; IN: bit-arrays @@ -48,6 +48,7 @@ M: bit-array new drop ; M: bit-array equal? over bit-array? [ sequence= ] [ 2drop f ] if ; +M: bit-array resize + resize-bit-array ; + INSTANCE: bit-array sequence -INSTANCE: bit-array simple-c-ptr -INSTANCE: bit-array c-ptr diff --git a/core/bit-vectors/bit-vectors-docs.factor b/core/bit-vectors/bit-vectors-docs.factor new file mode 100755 index 0000000000..f2f5c4da2c --- /dev/null +++ b/core/bit-vectors/bit-vectors-docs.factor @@ -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 } +"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: +{ $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." } ; diff --git a/core/bit-vectors/bit-vectors-tests.factor b/core/bit-vectors/bit-vectors-tests.factor new file mode 100755 index 0000000000..5838c1eb8d --- /dev/null +++ b/core/bit-vectors/bit-vectors-tests.factor @@ -0,0 +1,14 @@ +IN: temporary +USING: tools.test bit-vectors vectors sequences kernel math ; + +[ 0 ] [ 123 length ] unit-test + +: do-it + 1234 swap [ >r even? r> push ] curry each ; + +[ t ] [ + 3 dup do-it + 3 dup do-it sequence= +] unit-test + +[ t ] [ ?V{ } bit-vector? ] unit-test diff --git a/core/bit-vectors/bit-vectors.factor b/core/bit-vectors/bit-vectors.factor new file mode 100755 index 0000000000..c418a24813 --- /dev/null +++ b/core/bit-vectors/bit-vectors.factor @@ -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 + +vector ( bit-array length -- bit-vector ) + bit-vector construct-boa ; inline + +PRIVATE> + +: ( n -- bit-vector ) + 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 [ ] keep >fixnum bit-array>vector ; + +M: bit-vector equal? + over bit-vector? [ sequence= ] [ 2drop f ] if ; + +M: bit-array new-resizable drop ; + +INSTANCE: bit-vector growable diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 7b199a5e46..e9ee569fd6 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -17,8 +17,6 @@ IN: bootstrap.image : image-magic HEX: 0f0e0d0c ; inline : image-version 4 ; inline -: char bootstrap-cell 2/ ; inline - : data-base 1024 ; inline : userenv-size 40 ; inline @@ -244,21 +242,19 @@ M: wrapper ' [ emit ] emit-object ; ! Strings -: 16be> 0 [ swap 16 shift bitor ] reduce ; -: 16le> 16be> ; - : emit-chars ( seq -- ) - char - big-endian get [ [ 16be> ] map ] [ [ 16le> ] map ] if + bootstrap-cell + big-endian get [ [ be> ] map ] [ [ le> ] map ] if emit-seq ; : 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 ) string type-number object tag-number [ dup length emit-fixnum f ' emit + f ' emit pack-string emit-chars ] emit-object ; @@ -320,24 +316,33 @@ M: quotation ' ! Vectors and sbufs M: vector ' - dup underlying ' swap length - vector type-number object tag-number [ - emit-fixnum ! length + dup length swap underlying ' + tuple type-number tuple tag-number [ + 4 emit-fixnum + vector ' emit + f ' emit emit ! array ptr + emit-fixnum ! length ] emit-object ; M: sbuf ' - dup underlying ' swap length - sbuf type-number object tag-number [ - emit-fixnum ! length + dup length swap underlying ' + tuple type-number tuple tag-number [ + 4 emit-fixnum + sbuf ' emit + f ' emit emit ! array ptr + emit-fixnum ! length ] emit-object ; ! Hashes M: hashtable ' [ 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 hash-deleted emit-fixnum emit ! array ptr @@ -427,32 +432,22 @@ M: curry ' "Writing image to " write dup write "..." print flush [ (write-image) ] with-stream ; -: prepare-profile ( arch -- ) - "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 +: prepare-image ( -- ) bootstrapping? on load-help? off - 800000 image set 20000 objects set ; + 800000 image set + 20000 objects set ; PRIVATE> : make-image ( arch -- ) - [ + architecture [ prepare-image begin-image "resource:/core/bootstrap/stage1.factor" run-file end-image image get image-name write-image - ] with-scope ; + ] with-variable ; : my-arch ( -- arch ) cpu dup "ppc" = [ os "-" rot 3append ] when ; @@ -460,7 +455,7 @@ PRIVATE> : make-images ( -- ) { "x86.32" - ! "x86.64" + "x86.64" "linux-ppc" "macosx-ppc" ! "arm" } [ make-image ] each ; diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor old mode 100644 new mode 100755 index 189233e2d4..9c0d6b9838 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -8,7 +8,7 @@ BIN: 111 tag-mask set 8 num-tags set 3 tag-bits set -23 num-types set +20 num-types set H{ { fixnum BIN: 000 } @@ -24,17 +24,14 @@ H{ tag-numbers get H{ { array 8 } { wrapper 9 } - { hashtable 10 } - { vector 11 } + { float-array 10 } + { callstack 11 } { string 12 } - { sbuf 13 } + { curry 13 } { quotation 14 } { dll 15 } { alien 16 } { word 17 } { byte-array 18 } { bit-array 19 } - { float-array 20 } - { curry 21 } - { callstack 22 } } union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 3e93a868ca..545d904c9c 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -5,35 +5,52 @@ USING: alien arrays byte-arrays generic hashtables hashtables.private io kernel math namespaces parser sequences strings vectors words quotations assocs layouts classes tuples 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 -load-help? 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/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 changed-words set [ drop ] recompile-hook set +call +call call ! Create some empty vocabs where the below primitives and ! classes will go { "alien" + "alien.accessors" "arrays" "bit-arrays" + "bit-vectors" "byte-arrays" + "byte-vectors" "classes.private" "compiler.units" "continuations.private" "float-arrays" + "float-vectors" "generator" "growable" "hashtables" @@ -86,12 +103,6 @@ H{ } clone update-map set : register-builtin ( class -- ) 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 ) 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 f f builtin-class define-class dup r> builtin-predicate - dup r> intern-slots 2dup "slots" set-word-prop - define-slots + dup r> 1 simple-slots 2dup "slots" set-word-prop + dupd define-slots register-builtin ; H{ } clone typemap set @@ -127,14 +138,12 @@ num-types get f builtins set { { "integer" "math" } "numerator" - 1 { "numerator" "math" } f } { { "integer" "math" } "denominator" - 2 { "denominator" "math" } f } @@ -148,14 +157,12 @@ num-types get f builtins set { { "real" "math" } "real-part" - 1 { "real-part" "math" } f } { { "real" "math" } "imaginary-part" - 2 { "imaginary-part" "math" } f } @@ -172,78 +179,23 @@ num-types get f builtins set { { "object" "kernel" } "wrapped" - 1 { "wrapped" "kernel" } f } } 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 { { { "array-capacity" "sequences.private" } "length" - 1 { "length" "sequences" } f - } -} define-builtin - -"sbuf" "sbufs" create "sbuf?" "sbufs" create -{ - { - { "array-capacity" "sequences.private" } - "length" - 1 - { "length" "sequences" } - { "set-fill" "growable" } - } - { - { "string" "strings" } - "underlying" - 2 - { "underlying" "growable" } - { "set-underlying" "growable" } + } { + { "object" "kernel" } + "aux" + { "string-aux" "strings.private" } + { "set-string-aux" "strings.private" } } } define-builtin @@ -252,14 +204,12 @@ num-types get f builtins set { { "object" "kernel" } "array" - 1 { "quotation-array" "quotations.private" } f } { { "object" "kernel" } "compiled?" - 2 { "quotation-compiled?" "quotations" } f } @@ -270,7 +220,6 @@ num-types get f builtins set { { "byte-array" "byte-arrays" } "path" - 1 { "(dll-path)" "alien" } f } @@ -282,13 +231,11 @@ define-builtin { { "c-ptr" "alien" } "alien" - 1 { "underlying-alien" "alien" } f } { { "object" "kernel" } "expired?" - 2 { "expired?" "alien" } f } @@ -297,45 +244,40 @@ define-builtin "word" "words" create "word?" "words" create { + f { { "object" "kernel" } "name" - 2 { "word-name" "words" } { "set-word-name" "words" } } { { "object" "kernel" } "vocabulary" - 3 { "word-vocabulary" "words" } { "set-word-vocabulary" "words" } } { { "quotation" "quotations" } "def" - 4 { "word-def" "words" } { "set-word-def" "words.private" } } { { "object" "kernel" } "props" - 5 { "word-props" "words" } { "set-word-props" "words" } } { { "object" "kernel" } "?" - 6 { "compiled?" "words" } f } { { "fixnum" "math" } "counter" - 7 { "profile-counter" "tools.profiler.private" } { "set-profile-counter" "tools.profiler.private" } } @@ -359,14 +301,12 @@ define-builtin { { "object" "kernel" } "obj" - 1 { "curry-obj" "kernel" } f } { { "object" "kernel" } "obj" - 2 { "curry-quot" "kernel" } f } @@ -404,6 +344,102 @@ builtins get num-tags get tail f union-class define-class "tombstone" "hashtables.private" lookup t 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 : make-primitive ( word vocab n -- ) >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" } { "(call)" "kernel.private" } { "uncurry" "kernel.private" } - { "string>sbuf" "sbufs.private" } { "bignum>fixnum" "math.private" } { "float>fixnum" "math.private" } { "fixnum>bignum" "math.private" } @@ -527,47 +562,44 @@ builtins get num-tags get tail f union-class define-class { "" "byte-arrays" } { "" "bit-arrays" } { "" "alien" } - { "alien-signed-cell" "alien" } - { "set-alien-signed-cell" "alien" } - { "alien-unsigned-cell" "alien" } - { "set-alien-unsigned-cell" "alien" } - { "alien-signed-8" "alien" } - { "set-alien-signed-8" "alien" } - { "alien-unsigned-8" "alien" } - { "set-alien-unsigned-8" "alien" } - { "alien-signed-4" "alien" } - { "set-alien-signed-4" "alien" } - { "alien-unsigned-4" "alien" } - { "set-alien-unsigned-4" "alien" } - { "alien-signed-2" "alien" } - { "set-alien-signed-2" "alien" } - { "alien-unsigned-2" "alien" } - { "set-alien-unsigned-2" "alien" } - { "alien-signed-1" "alien" } - { "set-alien-signed-1" "alien" } - { "alien-unsigned-1" "alien" } - { "set-alien-unsigned-1" "alien" } - { "alien-float" "alien" } - { "set-alien-float" "alien" } - { "alien-double" "alien" } - { "set-alien-double" "alien" } - { "alien-cell" "alien" } - { "set-alien-cell" "alien" } + { "alien-signed-cell" "alien.accessors" } + { "set-alien-signed-cell" "alien.accessors" } + { "alien-unsigned-cell" "alien.accessors" } + { "set-alien-unsigned-cell" "alien.accessors" } + { "alien-signed-8" "alien.accessors" } + { "set-alien-signed-8" "alien.accessors" } + { "alien-unsigned-8" "alien.accessors" } + { "set-alien-unsigned-8" "alien.accessors" } + { "alien-signed-4" "alien.accessors" } + { "set-alien-signed-4" "alien.accessors" } + { "alien-unsigned-4" "alien.accessors" } + { "set-alien-unsigned-4" "alien.accessors" } + { "alien-signed-2" "alien.accessors" } + { "set-alien-signed-2" "alien.accessors" } + { "alien-unsigned-2" "alien.accessors" } + { "set-alien-unsigned-2" "alien.accessors" } + { "alien-signed-1" "alien.accessors" } + { "set-alien-signed-1" "alien.accessors" } + { "alien-unsigned-1" "alien.accessors" } + { "set-alien-unsigned-1" "alien.accessors" } + { "alien-float" "alien.accessors" } + { "set-alien-float" "alien.accessors" } + { "alien-double" "alien.accessors" } + { "set-alien-double" "alien.accessors" } + { "alien-cell" "alien.accessors" } + { "set-alien-cell" "alien.accessors" } { "alien>char-string" "alien" } { "string>char-alien" "alien" } { "alien>u16-string" "alien" } { "string>u16-alien" "alien" } { "(throw)" "kernel.private" } - { "string>memory" "alien" } - { "memory>string" "alien" } { "alien-address" "alien" } { "slot" "slots.private" } { "set-slot" "slots.private" } - { "char-slot" "strings.private" } - { "set-char-slot" "strings.private" } + { "string-nth" "strings.private" } + { "set-string-nth" "strings.private" } { "resize-array" "arrays" } { "resize-string" "strings" } - { "(hashtable)" "hashtables.private" } { "" "arrays" } { "begin-scan" "memory" } { "next-object" "memory" } @@ -582,7 +614,6 @@ builtins get num-tags get tail f union-class define-class { "fclose" "io.streams.c" } { "" "kernel" } { "(clone)" "kernel" } - { "array>vector" "vectors.private" } { "" "strings" } { "(>tuple)" "tuples.private" } { "array>quotation" "quotations.private" } @@ -595,13 +626,16 @@ builtins get num-tags get tail f union-class define-class { "" "float-arrays" } { "curry" "kernel" } { "" "tuples.private" } - { "class-hash" "kernel.private" } + { "class-hash" "kernel.private" } { "callstack>array" "kernel" } { "innermost-frame-quot" "kernel.private" } { "innermost-frame-scan" "kernel.private" } { "set-innermost-frame-quot" "kernel.private" } { "call-clear" "kernel" } { "(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 diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index f9c738a8d0..5a5a8d1c67 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -12,7 +12,7 @@ IN: bootstrap.stage2 ! you can see what went wrong, instead of dealing with a ! fep [ - vm file-name windows? [ >lower ".exe" ?tail drop ] when + vm file-name windows? [ "." split1 drop ] when ".image" append "output-image" 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 - all-words [ compiled? not ] subset recompile-hook get call + "bootstrap.compiler" vocab [ + vocabs [ + words "compile" "compiler" lookup execute + ] each + ] when ] with-compiler-errors + :errors f error set-global f error-continuation set-global @@ -82,5 +87,5 @@ IN: bootstrap.stage2 "output-image" get resource-path save-image-and-exit ] if ] [ - error. :c "listener" vocab-main execute + print-error :c "listener" vocab-main execute ] recover diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 2ddceabe44..4df5a68e97 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -16,12 +16,15 @@ f swap set-vocab-source-loaded? ";" " ; M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; +M: byte-array resize + resize-byte-array ; + INSTANCE: byte-array sequence -INSTANCE: byte-array simple-c-ptr -INSTANCE: byte-array c-ptr diff --git a/core/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor new file mode 100755 index 0000000000..0f1054ee5e --- /dev/null +++ b/core/byte-vectors/byte-vectors-docs.factor @@ -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 } +"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: +{ $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." } ; diff --git a/core/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor new file mode 100755 index 0000000000..2d9ca1f205 --- /dev/null +++ b/core/byte-vectors/byte-vectors-tests.factor @@ -0,0 +1,14 @@ +IN: temporary +USING: tools.test byte-vectors vectors sequences kernel ; + +[ 0 ] [ 123 length ] unit-test + +: do-it + 123 [ over push ] each ; + +[ t ] [ + 3 do-it + 3 do-it sequence= +] unit-test + +[ t ] [ BV{ } byte-vector? ] unit-test diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor new file mode 100755 index 0000000000..0acf06c0c1 --- /dev/null +++ b/core/byte-vectors/byte-vectors.factor @@ -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 + +vector ( byte-array capacity -- byte-vector ) + byte-vector construct-boa ; inline + +PRIVATE> + +: ( n -- byte-vector ) + 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 [ ] keep >fixnum byte-array>vector ; + +M: byte-vector equal? + over byte-vector? [ sequence= ] [ 2drop f ] if ; + +M: byte-array new-resizable drop ; + +INSTANCE: byte-vector growable diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 5addd273c8..854e6add5a 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -207,3 +207,14 @@ DEFER: mixin-forget-test-g [ { } mixin-forget-test-g ] unit-test-fails [ 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 diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 65dc5f5ff7..a6a1db7045 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -255,7 +255,14 @@ PRIVATE> >r dup word-props r> union over set-word-props 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 -- ) #! If it was already a class, update methods after. @@ -264,8 +271,9 @@ GENERIC: update-methods ( class -- ) over class-usages [ uncache-classes dupd (define-class) - ] keep cache-classes - r> [ update-methods ] [ drop ] if ; + ] keep cache-classes r> + [ class-usages dup update-predicates update-methods ] + [ drop ] if ; GENERIC: class ( object -- class ) inline diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor old mode 100644 new mode 100755 index e95c08b507..0adbdc080d --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -20,6 +20,8 @@ PREDICATE: class union-class over members union-predicate-quot define-predicate ; +M: union-class update-predicate define-union-predicate ; + : define-union-class ( class members -- ) dupd f union-class define-class define-union-predicate ; diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 784104d57f..1e6d4f8a17 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -7,21 +7,6 @@ optimizer definitions math compiler.errors threads graphs generic ; 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 ) [ [ dup ] H{ } map>assoc dup ] keep [ 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> f pick compiler-error over compiled-unxref - compiled-xref ; + over word-vocabulary [ compiled-xref ] [ 2drop ] if ; : compile-succeeded ( word -- effect dependencies ) [ @@ -57,12 +42,9 @@ compiled-crossref global [ H{ } assoc-like ] change-at [ dupd compile-failed f save-effect ] recover ; -: delete-any ( assoc -- element ) - [ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ; - : compile-loop ( assoc -- ) dup assoc-empty? [ drop ] [ - dup delete-any (compile) + dup delete-any drop (compile) yield compile-loop ] if ; diff --git a/extra/catalyst-talk/authors.txt b/core/compiler/constants/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from extra/catalyst-talk/authors.txt rename to core/compiler/constants/authors.txt diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 66fc8d5789..277a64225a 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -10,7 +10,7 @@ IN: compiler.constants ! These constants must match vm/layouts.h : header-offset object tag-number neg ; : 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 - ; : byte-array-offset 2 bootstrap-cells object tag-number - ; : alien-offset 3 bootstrap-cells object tag-number - ; diff --git a/core/compiler/constants/summary.txt b/core/compiler/constants/summary.txt new file mode 100755 index 0000000000..bf51e9a486 --- /dev/null +++ b/core/compiler/constants/summary.txt @@ -0,0 +1 @@ +VM memory layout constants diff --git a/core/compiler/errors/authors.txt b/core/compiler/errors/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/compiler/errors/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/compiler/errors/summary.txt b/core/compiler/errors/summary.txt new file mode 100755 index 0000000000..01d106bcad --- /dev/null +++ b/core/compiler/errors/summary.txt @@ -0,0 +1 @@ +Compiler warning and error reporting diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 954e45cb66..1d0ad141c2 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -1,10 +1,10 @@ IN: temporary -USING: arrays compiler kernel kernel.private math -math.constants math.private sequences strings tools.test words -continuations sequences.private hashtables.private byte-arrays -strings.private system random layouts vectors.private -sbufs.private strings.private slots.private alien alien.c-types -alien.syntax namespaces libc combinators.private ; +USING: arrays compiler kernel kernel.private math math.constants +math.private sequences strings tools.test words continuations +sequences.private hashtables.private byte-arrays strings.private +system random layouts vectors.private sbufs.private +strings.private slots.private alien alien.accessors +alien.c-types alien.syntax namespaces libc combinators.private ; ! Make sure that intrinsic ops compile to correct code. [ ] [ 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 [ -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 - -[ "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 +! [ 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 [ ] [ [ 0 getenv ] compile-call drop ] unit-test [ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test @@ -334,10 +334,6 @@ cell 8 = [ [ \ + ] [ \ + [ ] compile-call ] unit-test -[ H{ } ] [ - 100 [ (hashtable) ] compile-call [ reset-hash ] keep -] unit-test - [ B{ 0 0 0 0 0 } ] [ [ 5 ] compile-call ] unit-test diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index ecb5525fd0..b59c0d5f33 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -287,3 +287,7 @@ TUPLE: silly-tuple a b ; [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; [ t ] [ \ node-successor-f-bug compiled? ] unit-test + +: construct-empty-bug construct-empty ; + +[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 6e652df877..01dd27f8be 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -1,6 +1,6 @@ USING: compiler definitions generic assocs inference math 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 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 [ 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 diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates.factor index 78f57efb43..08e1c98729 100755 --- a/core/compiler/test/templates.factor +++ b/core/compiler/test/templates.factor @@ -2,8 +2,8 @@ USING: arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private -combinators.private byte-arrays alien layouts words definitions -compiler.units ; +combinators.private byte-arrays alien alien.accessors layouts +words definitions compiler.units ; IN: temporary ! Oops! diff --git a/core/compiler/units/authors.txt b/core/compiler/units/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/compiler/units/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/compiler/units/summary.txt b/core/compiler/units/summary.txt new file mode 100755 index 0000000000..3e989e8901 --- /dev/null +++ b/core/compiler/units/summary.txt @@ -0,0 +1 @@ +Compilation units group word definitions for compilation diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor old mode 100644 new mode 100755 index 2918f3340b..51e461c715 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -68,6 +68,15 @@ $nl 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* { $values { "catchstack" "a vector of continuations" } } { $description "Outputs the current catchstack." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 278264c17d..6e4ce16bea 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -135,6 +135,11 @@ PRIVATE> [ [ , f ] compose [ , drop t ] recover ] curry all? ] { } make peek swap [ rethrow ] when ; inline +GENERIC: dispose ( object -- ) + +: with-disposal ( object quot -- ) + over [ dispose ] curry [ ] cleanup ; inline + TUPLE: condition restarts continuation ; : ( error restarts cc -- condition ) diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index e48ba97f33..4da22ff38a 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -51,14 +51,8 @@ HOOK: %save-dispatch-xt compiler-backend ( -- ) M: object %save-dispatch-xt %save-word-xt ; -! Call C primitive -HOOK: %call-primitive compiler-backend ( label -- ) - -! Call another label -HOOK: %call-label compiler-backend ( label -- ) - -! Far jump to C primitive -HOOK: %jump-primitive compiler-backend ( label -- ) +! Call another word +HOOK: %call compiler-backend ( word -- ) ! Local jump for branches HOOK: %jump-label compiler-backend ( label -- ) diff --git a/core/cpu/architecture/tags.txt b/core/cpu/architecture/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/core/cpu/architecture/tags.txt @@ -0,0 +1 @@ +compiler diff --git a/core/cpu/arm/allot/authors.txt b/core/cpu/arm/allot/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/arm/allot/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/arm/architecture/authors.txt b/core/cpu/arm/architecture/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/arm/architecture/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/arm/assembler/authors.txt b/core/cpu/arm/assembler/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/arm/assembler/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/arm/intrinsics/authors.txt b/core/cpu/arm/intrinsics/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/arm/intrinsics/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/arm/intrinsics/intrinsics.factor b/core/cpu/arm/intrinsics/intrinsics.factor index 81b23ea8b2..29210afaa5 100755 --- a/core/cpu/arm/intrinsics/intrinsics.factor +++ b/core/cpu/arm/intrinsics/intrinsics.factor @@ -383,41 +383,6 @@ IN: cpu.arm.intrinsics { +output+ { "out" } } } 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-accessor ( quot -- ) "offset" operand dup %untag-fixnum diff --git a/core/cpu/arm/tags.txt b/core/cpu/arm/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/core/cpu/arm/tags.txt @@ -0,0 +1 @@ +compiler diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index edbed571e1..7444c21a8c 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -97,26 +97,14 @@ M: ppc-backend %epilogue ( n -- ) 1 1 rot ADDI 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 ; -M: ppc-backend %call-primitive ( word -- ) - %prepare-primitive (%call) ; - : (%jump) 11 MTCTR BCTR ; -M: ppc-backend %jump-primitive ( word -- ) - %prepare-primitive (%jump) ; - : %load-dlsym ( symbol dll register -- ) 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 ; diff --git a/core/cpu/ppc/intrinsics/authors.txt b/core/cpu/ppc/intrinsics/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/ppc/intrinsics/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 0773dae947..91bf5ed1e3 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -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. -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 kernel.private math math.private namespaces sequences words generic quotations byte-arrays hashtables hashtables.private @@ -93,30 +93,6 @@ IN: cpu.ppc.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 ) [ "out" operand "y" operand "x" operand ] swap add H{ { +input+ { { f "x" } { f "y" } } } @@ -586,43 +562,6 @@ IN: cpu.ppc.intrinsics { +output+ { "wrapper" } } } 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-accessor ( quot -- ) "offset" operand dup %untag-fixnum diff --git a/core/cpu/ppc/linux/bootstrap.factor b/core/cpu/ppc/linux/bootstrap.factor old mode 100644 new mode 100755 index a84bff5141..3900ca7f88 --- a/core/cpu/ppc/linux/bootstrap.factor +++ b/core/cpu/ppc/linux/bootstrap.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser layouts system ; +USING: parser layouts system kernel ; IN: bootstrap.ppc : c-area-size 10 bootstrap-cells ; : lr-save bootstrap-cell ; -"resource:core/cpu/ppc/bootstrap.factor" run-file +<< "resource:core/cpu/ppc/bootstrap.factor" parse-file parsed >> +call diff --git a/core/cpu/ppc/macosx/bootstrap.factor b/core/cpu/ppc/macosx/bootstrap.factor old mode 100644 new mode 100755 index 016e445522..db5e3a343f --- a/core/cpu/ppc/macosx/bootstrap.factor +++ b/core/cpu/ppc/macosx/bootstrap.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser layouts system ; +USING: parser layouts system kernel ; IN: bootstrap.ppc : c-area-size 14 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 diff --git a/core/cpu/ppc/tags.txt b/core/cpu/ppc/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/core/cpu/ppc/tags.txt @@ -0,0 +1 @@ +compiler diff --git a/core/cpu/x86/32/authors.txt b/core/cpu/x86/32/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/x86/32/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/x86/32/bootstrap.factor b/core/cpu/x86/32/bootstrap.factor index 4ce4b1684d..16083a8628 100755 --- a/core/cpu/x86/32/bootstrap.factor +++ b/core/cpu/x86/32/bootstrap.factor @@ -14,4 +14,5 @@ IN: bootstrap.x86 : fixnum>slot@ arg0 1 SAR ; : rex-length 0 ; -"resource:core/cpu/x86/bootstrap.factor" run-file +<< "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >> +call diff --git a/core/cpu/x86/32/tags.txt b/core/cpu/x86/32/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/core/cpu/x86/32/tags.txt @@ -0,0 +1 @@ +compiler diff --git a/core/cpu/x86/64/bootstrap.factor b/core/cpu/x86/64/bootstrap.factor old mode 100644 new mode 100755 index 1227369ae8..93bf7cca17 --- a/core/cpu/x86/64/bootstrap.factor +++ b/core/cpu/x86/64/bootstrap.factor @@ -14,4 +14,5 @@ IN: bootstrap.x86 : fixnum>slot@ ; : rex-length 1 ; -"resource:core/cpu/x86/bootstrap.factor" run-file +<< "resource:core/cpu/x86/bootstrap.factor" parse-file parsed >> +call diff --git a/core/cpu/x86/64/tags.txt b/core/cpu/x86/64/tags.txt new file mode 100644 index 0000000000..86a7c8e637 --- /dev/null +++ b/core/cpu/x86/64/tags.txt @@ -0,0 +1 @@ +compiler diff --git a/core/cpu/x86/allot/authors.txt b/core/cpu/x86/allot/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/x86/allot/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 876c631b81..8c5d5c1dc0 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -70,15 +70,7 @@ M: x86-backend %prepare-alien-invoke temp-reg v>operand 2 cells [+] ds-reg MOV temp-reg v>operand 3 cells [+] rs-reg MOV ; -M: x86-backend %call-primitive ( word -- ) - 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 %call ( label -- ) CALL ; M: x86-backend %jump-label ( label -- ) JMP ; diff --git a/core/cpu/x86/architecture/authors.txt b/core/cpu/x86/architecture/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/x86/architecture/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/x86/assembler/authors.txt b/core/cpu/x86/assembler/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/x86/assembler/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/x86/intrinsics/authors.txt b/core/cpu/x86/intrinsics/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/cpu/x86/intrinsics/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 0e9d66498d..99a89eab05 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays cpu.x86.assembler cpu.x86.allot -cpu.x86.architecture cpu.architecture kernel kernel.private math -math.private namespaces quotations sequences +USING: alien alien.accessors arrays cpu.x86.assembler +cpu.x86.allot cpu.x86.architecture cpu.architecture kernel +kernel.private math math.private namespaces quotations sequences words generic byte-arrays hashtables hashtables.private generator generator.registers generator.fixup sequences.private 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 ! Type checks @@ -153,34 +154,6 @@ IN: cpu.x86.intrinsics : small-reg-16 BX ; 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 : fixnum-op ( op hash -- pair ) >r [ "x" operand "y" operand ] swap add r> 2array ; @@ -447,45 +420,6 @@ IN: cpu.x86.intrinsics { +output+ { "wrapper" } } } 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-accessor ( quot -- ) "offset" operand %untag-fixnum diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor old mode 100644 new mode 100755 index cb8c87ed8d..98e42fa7fe --- a/core/cpu/x86/sse2/sse2.factor +++ b/core/cpu/x86/sse2/sse2.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays cpu.x86.assembler cpu.x86.architecture -cpu.x86.intrinsics generic kernel kernel.private math -math.private memory namespaces sequences words generator -generator.registers cpu.architecture math.floats.private layouts -quotations ; +USING: alien alien.accessors arrays cpu.x86.assembler +cpu.x86.architecture cpu.x86.intrinsics generic kernel +kernel.private math math.private memory namespaces sequences +words generator generator.registers cpu.architecture +math.floats.private layouts quotations ; IN: cpu.x86.sse2 : define-float-op ( word op -- ) diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor old mode 100644 new mode 100755 index 5a808a9a5d..2aeaadad3e --- a/core/dlists/dlists-docs.factor +++ b/core/dlists/dlists-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel ; +USING: help.markup help.syntax kernel quotations ; IN: dlists ARTICLE: "dlists" "Doubly-linked lists" @@ -13,23 +13,31 @@ $nl { $subsection dlist? } "Constructing a dlist:" { $subsection } -"Double-ended queue protocol:" -{ $subsection dlist-empty? } +"Working with the front of the list:" { $subsection push-front } +{ $subsection push-front* } +{ $subsection peek-front } { $subsection pop-front } { $subsection pop-front* } +"Working with the back of the list:" { $subsection push-back } +{ $subsection push-back* } +{ $subsection peek-back } { $subsection pop-back } { $subsection pop-back* } "Finding out the length:" +{ $subsection dlist-empty? } { $subsection dlist-length } "Iterating over elements:" { $subsection dlist-each } { $subsection dlist-find } { $subsection dlist-contains? } -"Deleting a node matching a predicate:" -{ $subsection delete-node* } +"Deleting a node:" { $subsection delete-node } +{ $subsection dlist-delete } +"Deleting a node matching a predicate:" +{ $subsection delete-node-if* } +{ $subsection delete-node-if } "Consuming all nodes:" { $subsection dlist-slurp } ; @@ -77,7 +85,7 @@ HELP: pop-back* { $see-also push-front push-back pop-front pop-front* pop-back } ; 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." } { $notes "Returns a boolean to allow dlists to store " { $link f } "." $nl @@ -85,20 +93,20 @@ HELP: dlist-find } ; 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." } { $notes "This operation is O(n)." } ; -HELP: delete-node* -{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } +HELP: delete-node-if* +{ $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." } { $notes "This operation is O(n)." } ; -HELP: delete-node -{ $values { "quot" "a 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." } +HELP: delete-node-if +{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } } +{ $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)." } ; 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." } ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index ebae68472b..203c975bb2 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -49,14 +49,14 @@ IN: temporary [ f ] [ 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test [ t ] [ 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test -[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test -[ 0 ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test -[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node-if ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test +[ 0 ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test [ 0 ] [ dlist-length ] unit-test [ 1 ] [ 1 over push-front dlist-length ] unit-test diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index a3c869efaf..ddec312182 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -63,12 +63,22 @@ C: dlist-node >r dlist-front r> (dlist-each-node) ; inline PRIVATE> -: push-front ( obj dlist -- ) - [ dlist-front f swap dup set-next-prev ] keep +: push-front* ( obj dlist -- dlist-node ) + [ dlist-front f swap dup dup set-next-prev ] keep [ set-dlist-front ] keep [ set-back-to-front ] keep inc-length ; +: push-front ( obj dlist -- ) + push-front* drop ; + +: push-back* ( obj dlist -- dlist-node ) + [ dlist-back f ] keep + [ dlist-back set-next-when ] 2keep + [ set-dlist-back ] 2keep + [ set-front-to-back ] keep + inc-length ; + : push-back ( obj dlist -- ) [ dlist-back f ] keep [ dlist-back set-next-when ] 2keep @@ -76,9 +86,13 @@ PRIVATE> [ set-front-to-back ] keep inc-length ; +: peek-front ( dlist -- obj ) + dlist-front dlist-node-obj ; + : pop-front ( dlist -- obj ) dup dlist-front [ - dlist-node-next + dup dlist-node-next + f rot set-dlist-node-next f over set-prev-when swap set-dlist-front ] 2keep dlist-node-obj @@ -86,14 +100,17 @@ PRIVATE> : pop-front* ( dlist -- ) pop-front drop ; +: peek-back ( dlist -- obj ) + dlist-back dlist-node-obj ; + : pop-back ( dlist -- obj ) - [ - dlist-back dup dlist-node-prev f over set-next-when - ] keep - [ set-dlist-back ] keep - [ normalize-front ] keep - dec-length - dlist-node-obj ; + dup dlist-back [ + dup dlist-node-prev + f rot set-dlist-node-prev + f over set-next-when + swap set-dlist-back + ] 2keep dlist-node-obj + swap [ normalize-front ] keep dec-length ; : 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-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-back over eq? ] [ drop pop-back* ] } { [ t ] [ unlink-node dec-length ] } } cond ; -: delete-node* ( quot dlist -- obj/f ? ) +: delete-node-if* ( quot dlist -- obj/f ? ) 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 ] if ; inline -: delete-node ( quot dlist -- obj/f ) - delete-node* drop ; inline +: delete-node-if ( quot dlist -- obj/f ) + delete-node-if* drop ; inline : dlist-delete ( obj dlist -- obj/f ) - >r [ eq? ] curry r> delete-node ; + >r [ eq? ] curry r> delete-node-if ; : dlist-each ( dlist quot -- ) [ dlist-node-obj ] swap compose dlist-each-node ; inline diff --git a/core/float-arrays/authors.txt b/core/float-arrays/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/float-arrays/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/float-arrays/float-arrays-tests.factor b/core/float-arrays/float-arrays-tests.factor old mode 100644 new mode 100755 index 811c380e41..afadaac0db --- a/core/float-arrays/float-arrays-tests.factor +++ b/core/float-arrays/float-arrays-tests.factor @@ -2,3 +2,9 @@ IN: temporary USING: float-arrays tools.test ; [ F{ 1.0 1.0 1.0 } ] [ 3 1.0 ] 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 diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor index ba0b2bb61d..33302572de 100755 --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! 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 ; IN: float-arrays @@ -29,9 +29,10 @@ M: float-array new drop 0.0 ; M: float-array equal? over float-array? [ sequence= ] [ 2drop f ] if ; +M: float-array resize + resize-float-array ; + INSTANCE: float-array sequence -INSTANCE: float-array simple-c-ptr -INSTANCE: float-array c-ptr : 1float-array ( x -- array ) 1 swap ; flushable diff --git a/core/float-vectors/float-vectors-docs.factor b/core/float-vectors/float-vectors-docs.factor new file mode 100755 index 0000000000..f0901fd46f --- /dev/null +++ b/core/float-vectors/float-vectors-docs.factor @@ -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 } +"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: +{ $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." } ; diff --git a/core/float-vectors/float-vectors-tests.factor b/core/float-vectors/float-vectors-tests.factor new file mode 100755 index 0000000000..68b8195eb7 --- /dev/null +++ b/core/float-vectors/float-vectors-tests.factor @@ -0,0 +1,14 @@ +IN: temporary +USING: tools.test float-vectors vectors sequences kernel ; + +[ 0 ] [ 123 length ] unit-test + +: do-it + 12345 [ over push ] each ; + +[ t ] [ + 3 do-it + 3 do-it sequence= +] unit-test + +[ t ] [ FV{ } float-vector? ] unit-test diff --git a/core/float-vectors/float-vectors.factor b/core/float-vectors/float-vectors.factor new file mode 100755 index 0000000000..2b023985a4 --- /dev/null +++ b/core/float-vectors/float-vectors.factor @@ -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 + +vector ( float-array length -- float-vector ) + float-vector construct-boa ; inline + +PRIVATE> + +: ( n -- float-vector ) + 0.0 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 ] keep >fixnum float-array>vector ; + +M: float-vector equal? + over float-vector? [ sequence= ] [ 2drop f ] if ; + +M: float-array new-resizable drop ; + +INSTANCE: float-vector growable diff --git a/core/generator/generator.factor b/core/generator/generator.factor index df01f9e490..de80872b73 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -19,8 +19,8 @@ SYMBOL: compiled : queue-compile ( word -- ) { { [ dup compiled get key? ] [ drop ] } + { [ dup inlined-block? ] [ drop ] } { [ dup primitive? ] [ drop ] } - { [ dup deferred? ] [ drop ] } { [ t ] [ dup compile-queue get set-at ] } } cond ; @@ -100,21 +100,10 @@ UNION: #terminal ! node M: node generate-node drop iterate-next ; -: %call ( word -- ) - dup primitive? [ %call-primitive ] [ %call-label ] if ; - : %jump ( word -- ) - { - { [ dup compiling-label get eq? ] [ - drop current-label-start get %jump-label - ] } - { [ dup primitive? ] [ - %epilogue-later %jump-primitive - ] } - { [ t ] [ - %epilogue-later %jump-label - ] } - } cond ; + dup compiling-label get eq? + [ drop current-label-start get ] [ %epilogue-later ] if + %jump-label ; : generate-call ( label -- next ) dup maybe-compile diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 5ee6b9c87c..bde5fd31af 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -107,5 +107,5 @@ M: class forget* ( class -- ) dup uncache-class forget-word ; -M: class update-methods ( class -- ) - class-usages implementors* [ make-generic ] each ; +M: assoc update-methods ( assoc -- ) + implementors* [ make-generic ] each ; diff --git a/core/growable/growable-docs.factor b/core/growable/growable-docs.factor old mode 100644 new mode 100755 index 0311397a43..02f6292001 --- a/core/growable/growable-docs.factor +++ b/core/growable/growable-docs.factor @@ -21,7 +21,7 @@ HELP: set-fill { $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." } { $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 { $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } } @@ -30,7 +30,7 @@ HELP: underlying HELP: set-underlying { $values { "underlying" "a sequence" } { "seq" "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 { $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } } diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor old mode 100644 new mode 100755 index 3719c2f9e0..563a59d20f --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -35,8 +35,10 @@ $nl "Utility words to create a new hashtable from a single key/value pair:" { $subsection associate } { $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 } +"Test if a sequence contains duplicates in linear time:" +{ $subsection all-unique? } { $subsection "hashtables.private" } ; ABOUT: "hashtables" @@ -114,10 +116,6 @@ HELP: { $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." } ; -HELP: (hashtable) ( -- hash ) -{ $values { "hash" "a new hashtable" } } -{ $description "Allocates a hashtable stub object without an underlying array. User code should call " { $link } " instead." } ; - HELP: associate { $values { "value" "a value" } { "key" "a key" } { "hash" "a new " { $link hashtable } } } { $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 }" } } ; +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 { $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." } ; diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 7dc252fd3e..40d079402c 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -160,3 +160,6 @@ H{ } "x" set H{ { 1 "one" } { 2 "two" } } { 1 2 3 } clone [ substitute ] keep ] unit-test + +[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test +[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor old mode 100644 new mode 100755 index 004cc9fa90..b24928a71e --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -122,7 +122,7 @@ IN: hashtables PRIVATE> : ( n -- hash ) - (hashtable) [ reset-hash ] keep ; + hashtable construct-empty [ reset-hash ] keep ; M: hashtable at* ( key hash -- value ? ) key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ; @@ -195,4 +195,7 @@ M: hashtable assoc-like dup length over length rot [ >r 2dup r> (prune) ] each nip ; +: all-unique? ( seq -- ? ) + dup prune [ length ] 2apply = ; + INSTANCE: hashtable assoc diff --git a/core/heaps/authors.txt b/core/heaps/authors.txt new file mode 100755 index 0000000000..1229a590fa --- /dev/null +++ b/core/heaps/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Ryan Murphy diff --git a/core/heaps/summary.txt b/core/heaps/summary.txt new file mode 100755 index 0000000000..afed9806ab --- /dev/null +++ b/core/heaps/summary.txt @@ -0,0 +1 @@ +Maxheap and minheap implementations of priority queues diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index cf2d021430..121c555d29 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -402,10 +402,14 @@ TUPLE: recursive-declare-error word ; dup node-param #return node, dataflow-graph get 1array over set-node-children ; +: inlined-block? "inlined-block" word-prop ; + +: gensym dup t "inlined-block" set-word-prop ; + : inline-block ( word -- node-block data ) [ copy-inference nest-node - dup word-def swap gensym + dup word-def swap [ infer-quot-recursive ] 2keep #label unnest-node ] H{ } make-assoc ; diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 9049104cfc..f6d5a36d3d 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs hashtables inference kernel math namespaces sequences words parser math.intervals -effects classes inference.dataflow inference.backend ; +effects classes inference.dataflow inference.backend +combinators ; IN: inference.class ! Class inference @@ -181,8 +182,11 @@ M: pair constraint-satisfied? ] if* ; : default-output-classes ( word -- classes ) - "inferred-effect" word-prop effect-out - dup [ class? ] all? [ drop f ] unless ; + "inferred-effect" word-prop { + { [ dup not ] [ drop f ] } + { [ dup effect-out [ class? ] all? not ] [ drop f ] } + { [ t ] [ effect-out ] } + } cond ; : compute-output-classes ( node word -- classes intervals ) dup node-param "output-classes" word-prop dup diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 508b0a6510..5f7e926b6a 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -1,5 +1,5 @@ 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 ; IN: inference @@ -93,8 +93,8 @@ $nl ABOUT: "inference" HELP: inference-error -{ $values { "msg" "an object" } } -{ $description "Throws an " { $link inference-error } "." } +{ $values { "class" class } } +{ $description "Creates an instance of " { $snippet "class" } ", wraps it in an " { $link inference-error } " and throws the result." } { $error-description "Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred." $nl diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index f5ad256ec5..3e3858d45d 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -421,6 +421,8 @@ DEFER: bar { 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect { 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect +\ dispose must-infer + ! Test stream protocol \ set-timeout must-infer \ stream-read must-infer @@ -430,7 +432,6 @@ DEFER: bar \ stream-write must-infer \ stream-write1 must-infer \ stream-nl must-infer -\ stream-close must-infer \ stream-format must-infer \ stream-write-table must-infer \ stream-flush must-infer diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 2223dd56b6..6be3899acd 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -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. -USING: alien arrays bit-arrays byte-arrays classes -combinators.private continuations.private effects float-arrays -generic hashtables hashtables.private inference.state -inference.backend inference.dataflow io io.backend io.files -io.files.private io.streams.c kernel kernel.private math -math.private memory namespaces namespaces.private parser -prettyprint quotations quotations.private sbufs sbufs.private -sequences sequences.private slots.private strings -strings.private system threads.private tuples tuples.private -vectors vectors.private words words.private assocs inspector ; +USING: alien alien.accessors arrays bit-arrays byte-arrays +classes combinators.private continuations.private effects +float-arrays generic hashtables hashtables.private +inference.state inference.backend inference.dataflow io +io.backend io.files io.files.private io.streams.c kernel +kernel.private math math.private memory namespaces +namespaces.private parser prettyprint quotations +quotations.private sbufs sbufs.private sequences +sequences.private slots.private strings strings.private system +threads.private tuples tuples.private vectors vectors.private +words words.private assocs inspector ; IN: inference.known-words ! Shuffle words @@ -167,9 +168,6 @@ t over set-effect-terminated? \ rehash-string { string } { } "inferred-effect" set-word-prop -\ string>sbuf { string integer } { sbuf } "inferred-effect" set-word-prop -\ string>sbuf make-flushable - \ bignum>fixnum { bignum } { fixnum } "inferred-effect" set-word-prop \ bignum>fixnum make-foldable @@ -475,10 +473,6 @@ t over set-effect-terminated? \ string>u16-alien { string } { byte-array } "inferred-effect" set-word-prop -\ string>memory { string c-ptr } { } "inferred-effect" set-word-prop - -\ memory>string { c-ptr integer } { string } "inferred-effect" set-word-prop - \ alien-address { alien } { integer } "inferred-effect" set-word-prop \ alien-address make-flushable @@ -487,20 +481,26 @@ t over set-effect-terminated? \ set-slot { object object fixnum } { } "inferred-effect" set-word-prop -\ char-slot { fixnum object } { fixnum } "inferred-effect" set-word-prop -\ char-slot make-flushable +\ string-nth { fixnum string } { fixnum } "inferred-effect" set-word-prop +\ string-nth make-flushable -\ set-char-slot { fixnum fixnum object } { } "inferred-effect" set-word-prop +\ set-string-nth { fixnum fixnum string } { } "inferred-effect" set-word-prop \ resize-array { integer array } { array } "inferred-effect" set-word-prop \ resize-array make-flushable +\ resize-byte-array { integer byte-array } { byte-array } "inferred-effect" set-word-prop +\ resize-byte-array make-flushable + +\ resize-bit-array { integer bit-array } { bit-array } "inferred-effect" set-word-prop +\ resize-bit-array make-flushable + +\ resize-float-array { integer float-array } { float-array } "inferred-effect" set-word-prop +\ resize-float-array make-flushable + \ resize-string { integer string } { string } "inferred-effect" set-word-prop \ resize-string make-flushable -\ (hashtable) { } { hashtable } "inferred-effect" set-word-prop -\ (hashtable) make-flushable - \ { integer object } { array } "inferred-effect" set-word-prop \ make-flushable @@ -536,9 +536,6 @@ t over set-effect-terminated? \ (clone) { object } { object } "inferred-effect" set-word-prop \ (clone) make-flushable -\ array>vector { array integer } { vector } "inferred-effect" set-word-prop -\ array>vector make-flushable - \ { integer integer } { string } "inferred-effect" set-word-prop \ make-flushable diff --git a/core/inference/state/authors.txt b/core/inference/state/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/inference/state/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/inference/state/summary.txt b/core/inference/state/summary.txt new file mode 100755 index 0000000000..6b782f6e21 --- /dev/null +++ b/core/inference/state/summary.txt @@ -0,0 +1 @@ +Variables for holding stack effect inference state diff --git a/core/inference/transforms/transforms-docs.factor b/core/inference/transforms/transforms-docs.factor old mode 100644 new mode 100755 index b695406653..a6f0c8e0bf --- a/core/inference/transforms/transforms-docs.factor +++ b/core/inference/transforms/transforms-docs.factor @@ -1,5 +1,5 @@ -USING: help.markup help.syntax inference.transforms -combinators words ; +IN: inference.transforms +USING: help.markup help.syntax combinators words kernel ; 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" } } @@ -12,3 +12,8 @@ HELP: define-transform $nl "The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":" { $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." } ; diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor old mode 100644 new mode 100755 index 6dc5bcabcd..152da8c757 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,6 +1,6 @@ IN: temporary USING: sequences inference.transforms tools.test math kernel -quotations ; +quotations tools.test.inference inference ; : compose-n-quot >quotation ; : compose-n compose-n-quot call ; @@ -18,3 +18,17 @@ quotations ; [ 268 ] [ 1 { 8 { 3 2 } } 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 diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 62c3129f3a..fd15b7da98 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel words sequences generic math namespaces 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 : pop-literals ( n -- rstate seq ) @@ -59,13 +60,34 @@ M: pair (bitfield-quot) ( spec -- quot ) \ get-slots [ [get-slots] ] 1 define-transform -\ set-slots [ [get-slots] ] 1 define-transform +TUPLE: duplicated-slots-error names ; -: [construct] ( word quot -- newquot ) - >r dup +inlined+ depends-on dup tuple-size r> 2curry ; +M: duplicated-slots-error summary + drop "Calling set-slots with duplicate slot setters" ; -\ construct-boa -[ [ ] [construct] ] 1 define-transform +: duplicated-slots-error ( names -- * ) + \ duplicated-slots-error construct-boa throw ; -\ construct-empty -[ [ ] [construct] ] 1 define-transform +\ set-slots [ + dup all-unique? + [ [get-slots] ] [ duplicated-slots-error ] if +] 1 define-transform + +\ construct-boa [ + dup +inlined+ depends-on + dup tuple-size [ ] 2curry +] 1 define-transform + +\ construct-empty [ + 1 ensure-values + peek-d value? [ + pop-literal + dup +inlined+ depends-on + dup tuple-size [ ] 2curry + swap infer-quot + ] [ + \ construct-empty 1 1 make-call-node + ] if +] "infer" set-word-prop + +\ construct-empty 1 1 "inferred-effect" set-word-prop diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor old mode 100644 new mode 100755 index a7736ae47e..9aa1299871 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: init kernel system ; +USING: init kernel system namespaces ; IN: io.backend SYMBOL: io-backend @@ -21,3 +21,6 @@ M: object normalize-pathname ; [ init-io embedded? [ init-stdio ] unless ] "io.backend" add-init-hook + +: set-io-backend ( backend -- ) + io-backend set-global init-io init-stdio ; diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor old mode 100644 new mode 100755 index 5d80443e84..69e733b55a --- a/core/io/binary/binary-tests.factor +++ b/core/io/binary/binary-tests.factor @@ -1,8 +1,8 @@ USING: io.binary tools.test ; IN: temporary -[ "\0\0\u0004\u00d2" ] [ 1234 4 >be ] unit-test -[ "\u00d2\u0004\0\0" ] [ 1234 4 >le ] unit-test +[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test +[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test [ 1234 ] [ 1234 4 >be be> ] unit-test [ 1234 ] [ 1234 4 >le le> ] unit-test diff --git a/core/io/encodings/authors.txt b/core/io/encodings/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/io/encodings/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor old mode 100644 new mode 100755 index f363389b59..5bc679cd27 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -18,8 +18,8 @@ SYMBOL: begin over push 0 begin ; : finish-decoding ( buf ch state -- str ) - begin eq? [ decode-error ] unless drop { } like ; + begin eq? [ decode-error ] unless drop "" like ; : decode ( seq quot -- str ) - >r [ length 0 begin ] keep r> each + >r [ length 0 begin ] keep r> each finish-decoding ; inline diff --git a/core/io/encodings/summary.txt b/core/io/encodings/summary.txt new file mode 100755 index 0000000000..ae6a19b334 --- /dev/null +++ b/core/io/encodings/summary.txt @@ -0,0 +1 @@ +Common support for ASCII, UTF8 and UTF16 character encodings diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor old mode 100644 new mode 100755 index 3559a3487b..5d4bb70912 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,5 +1,5 @@ IN: temporary -USING: tools.test io.files io threads kernel ; +USING: tools.test io.files io threads kernel continuations ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test [ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test @@ -41,7 +41,7 @@ USING: tools.test io.files io threads kernel ; [ ] [ "test-blah" resource-path make-directory ] unit-test [ ] [ - "test-blah/fooz" resource-path stream-close + "test-blah/fooz" resource-path dispose ] unit-test [ t ] [ diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor old mode 100644 new mode 100755 index 5c71714c64..208e2a2ba7 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -1,12 +1,12 @@ USING: help.markup help.syntax quotations hashtables kernel -classes strings ; +classes strings continuations ; IN: io ARTICLE: "stream-protocol" "Stream protocol" "The stream protocol consists of a large number of generic words, many of which are optional." $nl -"A word required to be implemented for all streams:" -{ $subsection stream-close } +"All streams must implement the " { $link dispose } " word in addition to the stream protocol." +$nl "Three words are required for input streams:" { $subsection stream-read1 } { $subsection stream-read } @@ -29,7 +29,6 @@ ARTICLE: "stdio" "The default stream" "Various words take an implicit stream parameter from a variable to reduce stack shuffling." { $subsection stdio } "Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user." -{ $subsection close } { $subsection read1 } { $subsection read } { $subsection read-until } @@ -74,16 +73,10 @@ ARTICLE: "streams" "Streams" ABOUT: "streams" -HELP: stream-close -{ $values { "stream" "a stream" } } -{ $contract "Closes the stream. This releases any external resources associated with the stream, such as file handles and network connections. No further operations can be performed on the stream after this call." } -{ $notes "You must close streams after you are finished working with them. A convenient way to automate this is by using the " { $link with-stream } " word." } -$io-error ; - HELP: set-timeout { $values { "n" "an integer" } { "stream" "a stream" } } -{ $contract "Sets a timeout, in milliseconds, for closing the stream if there is no activity. Not all streams support timeouts." } -$io-error ; +{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." } +{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ; HELP: stream-readln { $values { "stream" "an input stream" } { "str" string } } @@ -178,10 +171,6 @@ $io-error ; HELP: stdio { $var-description "Holds a stream, used for various implicit stream operations. Rebound using " { $link with-stream } " and " { $link with-stream* } "." } ; -HELP: close -{ $contract "Closes the " { $link stdio } " stream." } -$io-error ; - HELP: readln { $values { "str/f" "a string or " { $link f } } } { $contract "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." } diff --git a/core/io/io.factor b/core/io/io.factor index 0336ffda78..e0c890c0e3 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings continuations assocs io.styles sbufs ; IN: io -GENERIC: stream-close ( stream -- ) GENERIC: set-timeout ( n stream -- ) GENERIC: stream-readln ( stream -- str ) GENERIC: stream-read1 ( stream -- ch/f ) @@ -29,13 +28,14 @@ GENERIC: stream-write-table ( table-cells style stream -- ) [ over stream-write (stream-copy) ] [ 2drop ] if* ; : stream-copy ( in out -- ) - [ 2dup (stream-copy) ] [ stream-close stream-close ] [ ] + [ 2dup (stream-copy) ] [ dispose dispose ] [ ] cleanup ; ! Default stream SYMBOL: stdio -: close ( -- ) stdio get stream-close ; +! Default error stream +SYMBOL: stderr : readln ( -- str/f ) stdio get stream-readln ; : read1 ( -- ch/f ) stdio get stream-read1 ; @@ -53,7 +53,7 @@ SYMBOL: stdio stdio swap with-variable ; inline : with-stream ( stream quot -- ) - swap [ [ close ] [ ] cleanup ] with-stream* ; inline + [ with-stream* ] curry with-disposal ; inline : tabular-output ( style quot -- ) swap >r { } make r> stdio get stream-write-table ; inline diff --git a/core/io/streams/c/c-docs.factor b/core/io/streams/c/c-docs.factor index af8136262a..de8a756f92 100644 --- a/core/io/streams/c/c-docs.factor +++ b/core/io/streams/c/c-docs.factor @@ -14,9 +14,10 @@ ARTICLE: "io.streams.c" "ANSI C streams" { $subsection fclose } { $subsection fgetc } { $subsection fread } -"Two standard file handles:" -{ $subsection stdin } -{ $subsection stdout } ; +"The three standard file handles:" +{ $subsection stdin-handle } +{ $subsection stdout-handle } +{ $subsection stderr-handle } ; ABOUT: "io.streams.c" @@ -64,10 +65,14 @@ HELP: fread ( n alien -- str/f ) { $description "Reads a sequence of characters from a C FILE* handle, and outputs " { $link f } " on end of file." } { $errors "Throws an error if the input operation failed." } ; -HELP: stdin +HELP: stdin-handle { $values { "in" "a C FILE* handle" } } { $description "Outputs the console standard input file handle." } ; -HELP: stdout +HELP: stdout-handle { $values { "out" "a C FILE* handle" } } { $description "Outputs the console standard output file handle." } ; + +HELP: stderr-handle +{ $values { "out" "a C FILE* handle" } } +{ $description "Outputs the console standard error file handle." } ; diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 61eea4ba7b..b02c3367d4 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private namespaces io strings sequences math generic threads.private classes io.backend io.streams.lines io.streams.plain io.streams.duplex -io.files ; +io.files continuations ; IN: io.streams.c TUPLE: c-writer handle ; @@ -19,7 +19,7 @@ M: c-writer stream-write M: c-writer stream-flush c-writer-handle fflush ; -M: c-writer stream-close +M: c-writer dispose c-writer-handle fclose ; TUPLE: c-reader handle ; @@ -46,7 +46,7 @@ M: c-reader stream-read-until [ swap read-until-loop ] "" make swap over empty? over not and [ 2drop f f ] when ; -M: c-reader stream-close +M: c-reader dispose c-reader-handle fclose ; : ( in out -- stream ) @@ -56,12 +56,13 @@ M: c-reader stream-close M: object init-io ; -: stdin 11 getenv ; - -: stdout 12 getenv ; +: stdin-handle 11 getenv ; +: stdout-handle 12 getenv ; +: stderr-handle 38 getenv ; M: object init-stdio - stdin stdout stdio set-global ; + stdin-handle stdout-handle stdio set-global + stderr-handle stderr set-global ; M: object io-multiplex (sleep) ; diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor old mode 100644 new mode 100755 index 6293836348..fa82c54163 --- a/core/io/streams/duplex/duplex-docs.factor +++ b/core/io/streams/duplex/duplex-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io ; +USING: help.markup help.syntax io continuations ; IN: io.streams.duplex ARTICLE: "io.streams.duplex" "Duplex streams" @@ -19,4 +19,4 @@ HELP: HELP: check-closed { $values { "stream" "a duplex stream" } } { $description "Throws a " { $link check-closed } " error if the stream has already been closed." } -{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link stream-close } "." } ; +{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ; diff --git a/core/io/streams/duplex/duplex-tests.factor b/core/io/streams/duplex/duplex-tests.factor old mode 100644 new mode 100755 index a4a6433a29..962a46413f --- a/core/io/streams/duplex/duplex-tests.factor +++ b/core/io/streams/duplex/duplex-tests.factor @@ -6,7 +6,7 @@ TUPLE: closing-stream closed? ; : closing-stream construct-empty ; -M: closing-stream stream-close +M: closing-stream dispose dup closing-stream-closed? [ "Closing twice!" throw ] [ @@ -17,24 +17,24 @@ TUPLE: unclosable-stream ; : unclosable-stream construct-empty ; -M: unclosable-stream stream-close +M: unclosable-stream dispose "Can't close me!" throw ; [ ] [ - dup stream-close stream-close + dup dispose dispose ] unit-test [ t ] [ [ - [ dup stream-close ] catch 2drop + [ dup dispose ] catch 2drop ] keep closing-stream-closed? ] unit-test [ t ] [ [ - [ dup stream-close ] catch 2drop + [ dup dispose ] catch 2drop ] keep closing-stream-closed? ] unit-test diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor old mode 100644 new mode 100755 index a46dad71a0..86660b2752 --- a/core/io/streams/duplex/duplex.factor +++ b/core/io/streams/duplex/duplex.factor @@ -65,14 +65,14 @@ M: duplex-stream make-cell-stream M: duplex-stream stream-write-table duplex-stream-out+ stream-write-table ; -M: duplex-stream stream-close +M: duplex-stream dispose #! The output stream is closed first, in case both streams #! are attached to the same file descriptor, the output #! buffer needs to be flushed before we close the fd. dup duplex-stream-closed? [ t over set-duplex-stream-closed? - [ dup duplex-stream-out stream-close ] - [ dup duplex-stream-in stream-close ] [ ] cleanup + [ dup duplex-stream-out dispose ] + [ dup duplex-stream-in dispose ] [ ] cleanup ] unless drop ; M: duplex-stream set-timeout diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor old mode 100644 new mode 100755 index 83a86a9ced..e32c90a2fc --- a/core/io/streams/nested/nested.factor +++ b/core/io/streams/nested/nested.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.nested USING: arrays generic assocs kernel namespaces strings -quotations io ; +quotations io continuations ; TUPLE: ignore-close-stream ; : ignore-close-stream construct-delegate ; -M: ignore-close-stream stream-close drop ; +M: ignore-close-stream dispose drop ; TUPLE: style-stream style ; @@ -44,4 +44,4 @@ TUPLE: block-stream ; : block-stream construct-delegate ; -M: block-stream stream-close drop ; +M: block-stream dispose drop ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor old mode 100644 new mode 100755 index 9aaece6e31..3d5a55739b --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -2,11 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.string USING: io kernel math namespaces sequences sbufs strings -generic splitting io.streams.plain io.streams.lines ; +generic splitting io.streams.plain io.streams.lines +continuations ; + +M: sbuf dispose drop ; M: sbuf stream-write1 push ; M: sbuf stream-write push-all ; -M: sbuf stream-close drop ; M: sbuf stream-flush drop ; : ( -- stream ) diff --git a/core/io/utf16/utf16-tests.factor b/core/io/utf16/utf16-tests.factor old mode 100644 new mode 100755 index 014d834016..7a4b766941 --- a/core/io/utf16/utf16-tests.factor +++ b/core/io/utf16/utf16-tests.factor @@ -1,15 +1,15 @@ USING: tools.test io.utf16 ; -[ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be ] unit-test -[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be ] unit-test -[ { BIN: 11011111 CHAR: q } decode-utf16be ] unit-test-fails -[ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be ] unit-test-fails +[ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be >array ] unit-test +[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be >array ] unit-test +[ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test-fails +[ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test-fails -[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be ] unit-test +[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be >array ] unit-test -[ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le ] unit-test -[ { 0 BIN: 11011111 } decode-utf16le ] unit-test-fails -[ { 0 BIN: 11011011 0 0 } decode-utf16le ] unit-test-fails +[ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le >array ] unit-test +[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le >array ] unit-test +[ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test-fails +[ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test-fails -[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le ] unit-test +[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le >array ] unit-test diff --git a/core/io/utf16/utf16.factor b/core/io/utf16/utf16.factor index 7ed27a626e..d6b160e156 100755 --- a/core/io/utf16/utf16.factor +++ b/core/io/utf16/utf16.factor @@ -110,4 +110,3 @@ SYMBOL: quad3 { [ utf16be? ] [ decode-utf16be ] } { [ t ] [ decode-error ] } } cond ; - diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 8f0e4efbd9..2920122ec2 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -49,7 +49,7 @@ ARTICLE: "basic-combinators" "Basic combinators" { $subsection execute } "These words are used to implement " { $emphasis "combinators" } ", which are words that take code from the stack. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:" { $code - ": keep ( x quot -- x | quot: x -- )" + ": keep ( x quot -- x )" " over >r call r> ; inline" } "Word inlining is documented in " { $link "declarations" } "." @@ -372,7 +372,7 @@ HELP: 2keep { $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ; HELP: 3keep -{ $values { "quot" "a quotation with stack effect " { $snippet "( x y -- )" } } { "x" object } { "y" object } { "z" object } } +{ $values { "quot" "a quotation with stack effect " { $snippet "( x y z -- )" } } { "x" object } { "y" object } { "z" object } } { $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ; HELP: 2apply @@ -557,7 +557,7 @@ HELP: dip HELP: while { $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } -{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." } +{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." } { $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used." $nl "Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:" diff --git a/core/libc/libc.factor b/core/libc/libc.factor index 88c5070d1f..2006850839 100644 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -2,7 +2,7 @@ ! Copyright (C) 2007 Slava Pestov ! Copyright (C) 2007 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien assocs init inspector kernel namespaces ; +USING: alien assocs continuations init inspector kernel namespaces ; IN: libc "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ; : with-malloc ( size quot -- ) - swap 1 calloc swap keep free ; inline + swap 1 calloc [ swap keep ] [ free ] [ ] cleanup ; inline diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 8f26ddf9b2..02cd727930 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -18,11 +18,10 @@ GENERIC: stream-read-quot ( stream -- quot/f ) [ parse-lines in get ] with-compilation-unit in set ; : read-quot-step ( lines -- quot/f ) - [ parse-lines-interactive ] catch { - { [ dup delegate unexpected-eof? ] [ 2drop f ] } - { [ dup not ] [ drop ] } - { [ t ] [ rethrow ] } - } cond ; + [ parse-lines-interactive ] [ + dup delegate unexpected-eof? + [ 2drop f ] [ rethrow ] if + ] recover ; : read-quot-loop ( stream accum -- quot/f ) over stream-readln dup [ diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 307a5531a1..1ec3592c79 100755 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -209,7 +209,7 @@ HELP: bitxor HELP: shift { $values { "x" integer } { "n" integer } { "y" integer } } -{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "y" } " bits if " { $snippet "y" } " is positive, or " { $snippet "-y" } " bits to the right if " { $snippet "y" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." } +{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "n" } " bits if " { $snippet "n" } " is positive, or " { $snippet "-n" } " bits to the right if " { $snippet "n" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." } { $examples { $example "BIN: 101 5 shift .b" "10100000" } { $example "BIN: 11111 -2 shift .b" "111" } } ; HELP: bitnot diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor old mode 100644 new mode 100755 index 28cecc033f..7f0404812d --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private namespaces sequences strings arrays -combinators splitting math ; +combinators splitting math assocs ; IN: math.parser DEFER: base> @@ -11,12 +11,30 @@ DEFER: base> 2dup and [ / ] [ 2drop f ] if ; : digit> ( ch -- n ) - { - { [ dup digit? ] [ CHAR: 0 - ] } - { [ dup letter? ] [ CHAR: a - 10 + ] } - { [ dup LETTER? ] [ CHAR: A - 10 + ] } - { [ t ] [ drop f ] } - } cond ; + H{ + { CHAR: 0 0 } + { CHAR: 1 1 } + { CHAR: 2 2 } + { CHAR: 3 3 } + { CHAR: 4 4 } + { CHAR: 5 5 } + { CHAR: 6 6 } + { CHAR: 7 7 } + { CHAR: 8 8 } + { CHAR: 9 9 } + { CHAR: A 10 } + { CHAR: B 11 } + { CHAR: C 12 } + { CHAR: D 13 } + { CHAR: E 14 } + { CHAR: F 15 } + { CHAR: a 10 } + { CHAR: b 11 } + { CHAR: c 12 } + { CHAR: d 13 } + { CHAR: e 14 } + { CHAR: f 15 } + } at ; : digits>integer ( radix seq -- n ) 0 rot [ swapd * + ] curry reduce ; diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index bac6895b62..3d3d3c554b 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -15,16 +15,16 @@ IN: namespaces PRIVATE> : namespace ( -- namespace ) namestack* peek ; -: namestack ( -- namestack ) namestack* clone ; inline -: set-namestack ( namestack -- ) >vector 0 setenv ; inline +: namestack ( -- namestack ) namestack* clone ; +: set-namestack ( namestack -- ) >vector 0 setenv ; : global ( -- g ) 21 getenv { hashtable } declare ; inline : init-namespaces ( -- ) global 1array set-namestack ; : get ( variable -- value ) namestack* assoc-stack ; flushable : set ( value variable -- ) namespace set-at ; : on ( variable -- ) t swap set ; inline : off ( variable -- ) f swap set ; inline -: get-global ( variable -- value ) global at ; inline -: set-global ( value variable -- ) global set-at ; inline +: get-global ( variable -- value ) global at ; +: set-global ( value variable -- ) global set-at ; : change ( variable quot -- ) >r dup get r> rot slip set ; inline diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 1122d83129..4843a9ff26 100644 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -17,17 +17,17 @@ SYMBOL: optimizer-changed GENERIC: optimize-node* ( node -- node/t changed? ) -: ?union ( hash/f hash -- hash ) +: ?union ( assoc/f assoc -- hash ) over [ union ] [ nip ] if ; -: add-node-literals ( hash node -- ) +: add-node-literals ( assoc node -- ) over assoc-empty? [ 2drop ] [ [ node-literals ?union ] keep set-node-literals ] if ; -: add-node-classes ( hash node -- ) +: add-node-classes ( assoc node -- ) over assoc-empty? [ 2drop ] [ @@ -324,6 +324,7 @@ M: #dispatch optimize-node* ] if ; : flush-eval ( #call -- node ) + dup node-param +inlined+ depends-on dup node-out-d length f inline-literals ; : partial-eval? ( #call -- ? ) @@ -337,9 +338,9 @@ M: #dispatch optimize-node* dup node-in-d [ node-literal ] with map ; : partial-eval ( #call -- node ) + dup node-param +inlined+ depends-on dup literal-in-d over node-param 1quotation - [ with-datastack ] catch - [ 3drop t ] [ inline-literals ] if ; + [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; : define-identities ( words identities -- ) [ "identities" set-word-prop ] curry each ; diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index ec3c9c15da..e048e29f48 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: optimizer.math -USING: alien arrays generic hashtables kernel assocs math -math.private kernel.private sequences words parser +USING: alien alien.accessors arrays generic hashtables kernel +assocs math math.private kernel.private sequences words parser inference.class inference.dataflow vectors strings sbufs io namespaces assocs quotations math.intervals sequences.private -combinators splitting layouts math.parser classes -generic.math optimizer.pattern-match optimizer.backend -optimizer.def-use generic.standard system ; +combinators splitting layouts math.parser classes generic.math +optimizer.pattern-match optimizer.backend optimizer.def-use +generic.standard system ; { + bignum+ float+ fixnum+fast } { { { number 0 } [ drop ] } diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index de56dc55db..30e259c033 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -44,8 +44,7 @@ ARTICLE: "vocabulary-search-errors" "Word lookup errors" "If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:" { $list { "If there are no words having this name at all, an error is thrown and parsing stops." } - { "If there is exactly one vocabulary having a word with this name, the vocabulary is automatically added to the search path. This behavior is intended for interactive use and exploratory programming only, and production code should contain full " { $link POSTPONE: USING: } " declarations." } - { "If there is more than one vocabulary which contains a word with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." } + { "If there are vocabularies which contain words with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." } } "When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 55d43ce8e0..b00e8e26b4 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -8,14 +8,14 @@ IN: temporary [ 1 CHAR: a ] [ 0 "abcd" next-char ] unit-test - [ 6 CHAR: \s ] - [ 1 "\\u0020hello" next-escape ] unit-test + [ 8 CHAR: \s ] + [ 1 "\\u000020hello" next-escape ] unit-test [ 2 CHAR: \n ] [ 1 "\\nhello" next-escape ] unit-test - [ 6 CHAR: \s ] - [ 0 "\\u0020hello" next-char ] unit-test + [ 8 CHAR: \s ] + [ 0 "\\u000020hello" next-char ] unit-test [ 1 [ 2 [ 3 ] 4 ] 5 ] [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ] @@ -46,15 +46,13 @@ IN: temporary ! Test escapes [ " " ] - [ "\"\\u0020\"" eval ] + [ "\"\\u000020\"" eval ] unit-test [ "'" ] - [ "\"\\u0027\"" eval ] + [ "\"\\u000027\"" eval ] unit-test - [ "\\u123" eval ] unit-test-fails - ! Test EOL comments in multiline strings. [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor old mode 100644 new mode 100755 index 31a3ceac03..2643ea95d9 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words @@ -54,8 +54,9 @@ t parser-notes set-global 0 over set-lexer-column dup lexer-line 1+ swap set-lexer-line ; -: skip ( i seq quot -- n ) - over >r find* drop +: skip ( i seq ? -- n ) + over >r + [ swap CHAR: \s eq? xor ] curry find* drop [ r> drop ] [ r> length ] if* ; inline : change-column ( lexer quot -- ) @@ -66,14 +67,13 @@ t parser-notes set-global GENERIC: skip-blank ( lexer -- ) M: lexer skip-blank ( lexer -- ) - [ [ blank? not ] skip ] change-column ; + [ t skip ] change-column ; GENERIC: skip-word ( lexer -- ) M: lexer skip-word ( lexer -- ) [ - 2dup nth CHAR: " = - [ drop 1+ ] [ [ blank? ] skip ] if + 2dup nth CHAR: " = [ drop 1+ ] [ f skip ] if ] change-column ; : still-parsing? ( lexer -- ? ) @@ -119,7 +119,7 @@ M: bad-escape summary drop "Bad escape code" ; : next-escape ( m str -- n ch ) 2dup nth CHAR: u = - [ >r 1+ dup 4 + tuck r> subseq hex> ] + [ >r 1+ dup 6 + tuck r> subseq hex> ] [ over 1+ -rot nth escape ] if ; : next-char ( m str -- n ch ) @@ -347,45 +347,49 @@ SYMBOL: bootstrap-syntax call ] with-scope ; inline +SYMBOL: interactive-vocabs + +{ + "arrays" + "assocs" + "combinators" + "compiler.errors" + "continuations" + "debugger" + "definitions" + "editors" + "generic" + "help" + "inspector" + "io" + "io.files" + "kernel" + "listener" + "math" + "memory" + "namespaces" + "prettyprint" + "sequences" + "slicing" + "sorting" + "strings" + "syntax" + "tools.annotations" + "tools.crossref" + "tools.memory" + "tools.profiler" + "tools.test" + "tools.time" + "vocabs" + "vocabs.loader" + "words" + "scratchpad" +} interactive-vocabs set-global + : with-interactive-vocabs ( quot -- ) [ "scratchpad" in set - { - "arrays" - "assocs" - "combinators" - "compiler.errors" - "continuations" - "debugger" - "definitions" - "editors" - "generic" - "help" - "inspector" - "io" - "io.files" - "kernel" - "listener" - "math" - "memory" - "namespaces" - "prettyprint" - "sequences" - "slicing" - "sorting" - "strings" - "syntax" - "tools.annotations" - "tools.crossref" - "tools.memory" - "tools.profiler" - "tools.test" - "tools.time" - "vocabs" - "vocabs.loader" - "words" - "scratchpad" - } set-use + interactive-vocabs get set-use call ] with-scope ; inline diff --git a/core/prettyprint/backend/backend-docs.factor b/core/prettyprint/backend/backend-docs.factor old mode 100644 new mode 100755 index 4605308a95..c7ca380fbd --- a/core/prettyprint/backend/backend-docs.factor +++ b/core/prettyprint/backend/backend-docs.factor @@ -20,7 +20,7 @@ HELP: ch>ascii-escape HELP: ch>unicode-escape { $values { "ch" "a character" } { "str" string } } -{ $description "Converts a character to a Unicode escape code (" { $snippet "\\u1234"} ")." } ; +{ $description "Converts a character to a Unicode escape code (" { $snippet "\\u123456"} ")." } ; HELP: unparse-ch { $values { "ch" "a character" } } diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 8d0140202e..a85e23100d 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays byte-arrays bit-arrays generic hashtables io -assocs kernel math namespaces sequences strings sbufs io.styles -vectors words prettyprint.config prettyprint.sections quotations -io io.files math.parser effects tuples classes float-arrays ; +USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors +generic hashtables io assocs kernel math namespaces sequences +strings sbufs io.styles vectors words prettyprint.config +prettyprint.sections quotations io io.files math.parser effects +tuples classes float-arrays float-vectors ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) @@ -57,24 +58,17 @@ M: f pprint* drop \ f pprint-word ; ! Strings : ch>ascii-escape ( ch -- str ) H{ - { CHAR: \e "\\e" } - { CHAR: \n "\\n" } - { CHAR: \r "\\r" } - { CHAR: \t "\\t" } - { CHAR: \0 "\\0" } - { CHAR: \\ "\\\\" } - { CHAR: \" "\\\"" } + { CHAR: \e CHAR: e } + { CHAR: \n CHAR: n } + { CHAR: \r CHAR: r } + { CHAR: \t CHAR: t } + { CHAR: \0 CHAR: 0 } + { CHAR: \\ CHAR: \\ } + { CHAR: \" CHAR: \" } } at ; -: ch>unicode-escape ( ch -- str ) - >hex 4 CHAR: 0 pad-left "\\u" swap append ; - : unparse-ch ( ch -- ) - dup quotable? [ - , - ] [ - dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?if % - ] if ; + dup ch>ascii-escape [ "\\" % ] [ ] ?if , ; : do-string-limit ( str -- trimmed ) string-limit get [ @@ -143,8 +137,11 @@ M: quotation pprint-delims drop \ [ \ ] ; M: curry pprint-delims drop \ [ \ ] ; M: array pprint-delims drop \ { \ } ; M: byte-array pprint-delims drop \ B{ \ } ; +M: byte-vector pprint-delims drop \ BV{ \ } ; M: bit-array pprint-delims drop \ ?{ \ } ; +M: bit-vector pprint-delims drop \ ?V{ \ } ; M: float-array pprint-delims drop \ F{ \ } ; +M: float-vector pprint-delims drop \ FV{ \ } ; M: vector pprint-delims drop \ V{ \ } ; M: hashtable pprint-delims drop \ H{ \ } ; M: tuple pprint-delims drop \ T{ \ } ; @@ -155,6 +152,10 @@ GENERIC: >pprint-sequence ( obj -- seq ) M: object >pprint-sequence ; +M: vector >pprint-sequence ; +M: bit-vector >pprint-sequence ; +M: byte-vector >pprint-sequence ; +M: float-vector >pprint-sequence ; M: hashtable >pprint-sequence >alist ; M: tuple >pprint-sequence tuple>array ; M: wrapper >pprint-sequence wrapped 1array ; diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor old mode 100644 new mode 100755 index 2b01df8faa..69400d2527 --- a/core/prettyprint/prettyprint-docs.factor +++ b/core/prettyprint/prettyprint-docs.factor @@ -1,6 +1,6 @@ USING: prettyprint.backend prettyprint.config -prettyprint.sections help.markup help.syntax io kernel words -definitions quotations strings ; +prettyprint.sections prettyprint.private help.markup help.syntax +io kernel words definitions quotations strings ; IN: prettyprint ARTICLE: "prettyprint-numbers" "Prettyprinting numbers" diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 9c5ec885ae..7f7d946347 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -21,8 +21,8 @@ IN: temporary [ "hello\\backslash" unparse ] unit-test -[ "\"\\u1234\"" ] -[ "\u1234" unparse ] +[ "\"\\u123456\"" ] +[ "\u123456" unparse ] unit-test [ "\"\\e\"" ] diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 45ff0c0572..ed52f0238c 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -86,14 +86,14 @@ combinators quotations ; : .s ( -- ) datastack stack. ; : .r ( -- ) retainstack stack. ; + \ -> { { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } } "word-style" set-word-prop -sbuf ( string length -- sbuf ) + sbuf construct-boa ; inline + +PRIVATE> + : ( n -- sbuf ) 0 0 string>sbuf ; inline M: sbuf set-nth-unsafe - underlying >r >r >fixnum r> >fixnum r> set-char-slot ; + underlying >r >r >fixnum r> >fixnum r> set-string-nth ; M: sbuf new drop [ 0 ] keep >fixnum string>sbuf ; diff --git a/core/sbufs/tags.txt b/core/sbufs/tags.txt index 42d711b32b..de2741b09f 100644 --- a/core/sbufs/tags.txt +++ b/core/sbufs/tags.txt @@ -1 +1,2 @@ +text collections diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 1509fa8c05..73ae4737ba 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -151,7 +151,7 @@ unit-test [ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test [ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test -[ 5 ] [ 1 >bignum "\u0001\u0005\u0007" nth-unsafe ] unit-test +[ 5 ] [ 1 >bignum "\u000001\u000005\u000007" nth-unsafe ] unit-test [ SBUF" before&after" ] [ "&" 6 11 SBUF" before and after" [ replace-slice ] keep @@ -235,12 +235,12 @@ unit-test [ 11 10 nth ] unit-test-fails [ -1./0. 0 delete-nth ] unit-test-fails -[ "" ] [ "" [ blank? ] trim ] unit-test -[ "" ] [ "" [ blank? ] left-trim ] unit-test -[ "" ] [ "" [ blank? ] right-trim ] unit-test -[ "" ] [ " " [ blank? ] left-trim ] unit-test -[ "" ] [ " " [ blank? ] right-trim ] unit-test -[ "asdf" ] [ " asdf " [ blank? ] trim ] unit-test -[ "asdf " ] [ " asdf " [ blank? ] left-trim ] unit-test -[ " asdf" ] [ " asdf " [ blank? ] right-trim ] unit-test +[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test +[ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test +[ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test +[ "" ] [ " " [ CHAR: \s = ] left-trim ] unit-test +[ "" ] [ " " [ CHAR: \s = ] right-trim ] unit-test +[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test +[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test +[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 4517ee4363..cd523b05c1 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math namespaces sequences strings words effects generic generic.standard -classes slots.private ; +classes slots.private combinators ; IN: slots TUPLE: slot-spec type name offset reader writer ; @@ -87,14 +87,23 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ; : simple-writer-word ( class name -- word ) (simple-slot-word) writer-word ; -: simple-slot ( class name # -- spec ) +: short-slot ( class name # -- spec ) >r object bootstrap-word over r> f f 2over simple-reader-word over set-slot-spec-reader -rot simple-writer-word over set-slot-spec-writer ; +: long-slot ( spec # -- spec ) + >r [ dup array? [ first2 create ] when ] map first4 r> + -rot ; + : simple-slots ( class slots base -- specs ) - over length [ + ] with map - [ >r >r dup r> r> simple-slot ] 2map nip ; + over length [ + ] with map [ + { + { [ over not ] [ 2drop f ] } + { [ over string? ] [ >r dupd r> short-slot ] } + { [ over array? ] [ long-slot ] } + } cond + ] 2map [ ] subset nip ; : slot-of-reader ( reader specs -- spec/f ) [ slot-spec-reader eq? ] with find nip ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 0b1b2d43bf..8bbf329491 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -68,7 +68,7 @@ uses definitions ; : reset-checksums ( -- ) source-files get [ swap ?resource-path dup exists? - [ file-lines record-checksum ] [ 2drop ] if + [ file-lines swap record-checksum ] [ 2drop ] if ] assoc-each ; M: pathname where pathname-string 1 2array ; diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor old mode 100644 new mode 100755 index d42e8cc601..d8cef5557a --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -4,7 +4,11 @@ sbufs math ; IN: strings ARTICLE: "strings" "Strings" -"A string is a fixed-size mutable sequence of characters. The literal syntax is covered in " { $link "syntax-strings" } "." +"A string is a fixed-size mutable sequence of Unicode 5.0 code points." +$nl +"Characters are not a first-class type; they are simply represented as integers between 0 and 16777216 (2^24). Only characters up to 2097152 (2^21) have a defined meaning in Unicode." +$nl +"String literal syntax is covered in " { $link "syntax-strings" } "." $nl "String words are found in the " { $vocab-link "strings" } " vocabulary." $nl @@ -16,28 +20,25 @@ $nl { $subsection } "Creating a string from a single character:" { $subsection 1string } -"Characters are not a first-class type; they are simply represented as integers between 0 and 65535. A few words operate on characters:" -{ $subsection blank? } -{ $subsection letter? } -{ $subsection LETTER? } -{ $subsection digit? } -{ $subsection printable? } -{ $subsection control? } -{ $subsection quotable? } -{ $subsection ch>lower } -{ $subsection ch>upper } ; +"Since strings are sequences, basic string manipulation can be performed using sequence operations (" { $link "sequences" } "). More advanced functionality can be found in other vocabularies, including but not limited to:" +{ $list + { { $vocab-link "ascii" } " - traditional ASCII character classes" } + { { $vocab-link "unicode" } " - Unicode 5.0-aware character classes, case conversion, word breaks, ..." } + { { $vocab-link "regexp" } " - regular expressions" } + { { $vocab-link "peg" } " - parser expression grammars" } +} ; ABOUT: "strings" HELP: string { $description "The class of fixed-length character strings. See " { $link "syntax-strings" } " for syntax and " { $link "strings" } " for general information." } ; -HELP: char-slot ( n string -- ch ) +HELP: string-nth ( n string -- ch ) { $values { "n" fixnum } { "string" string } { "ch" "the character at the " { $snippet "n" } "th index" } } { $description "Unsafe string accessor, used to define " { $link nth } " on strings." } { $warning "This word is in the " { $vocab-link "strings.private" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link nth } " instead." } ; -HELP: set-char-slot ( ch n string -- ) +HELP: set-string-nth ( ch n string -- ) { $values { "ch" "a character" } { "n" fixnum } { "string" string } } { $description "Unsafe string mutator, used to define " { $link set-nth } " on strings." } { $warning "This word is in the " { $vocab-link "strings.private" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link set-nth } " instead." } ; @@ -46,58 +47,6 @@ HELP: ( n ch -- string ) { $values { "n" "a positive integer specifying string length" } { "ch" "an initial character" } { "string" string } } { $description "Creates a new string with the given length and all characters initially set to " { $snippet "ch" } "." } ; -HELP: blank? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII whitespace character." } ; - -HELP: letter? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for a lowercase alphabet ASCII character." } ; - -HELP: LETTER? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for a uppercase alphabet ASCII character." } ; - -HELP: digit? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII decimal digit character." } ; - -HELP: Letter? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ; - -HELP: alpha? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an alphanumeric ASCII character." } ; - -HELP: printable? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for a printable ASCII character." } ; - -HELP: control? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII control character." } ; - -HELP: quotable? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ; - -HELP: ch>lower -{ $values { "ch" "a character" } { "lower" "a character" } } -{ $description "Converts a character to lowercase." } ; - -HELP: ch>upper -{ $values { "ch" "a character" } { "upper" "a character" } } -{ $description "Converts a character to uppercase." } ; - -HELP: >lower -{ $values { "str" string } { "lower" string } } -{ $description "Converts a string to lowercase." } ; - -HELP: >upper -{ $values { "str" string } { "upper" string } } -{ $description "Converts a string to uppercase." } ; - HELP: 1string { $values { "ch" "a character"} { "str" string } } { $description "Outputs a string of one character." } ; @@ -109,4 +58,4 @@ HELP: >string HELP: resize-string ( n str -- newstr ) { $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } } -{ $description "Creates a new string " { $snippet "n" } " characters long The contents of the existing string are copied into the new string; if the new string is shorter, only an initial segment is copied, and if the new string is longer the remaining space is filled with " { $snippet "\\u0000" } "." } ; +{ $description "Creates a new string " { $snippet "n" } " characters long The contents of the existing string are copied into the new string; if the new string is shorter, only an initial segment is copied, and if the new string is longer the remaining space is filled with " { $snippet "\\u000000" } "." } ; diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor old mode 100644 new mode 100755 index 88f6f3e9ca..459ec7b153 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -1,5 +1,5 @@ USING: continuations kernel math namespaces strings sbufs -tools.test sequences vectors ; +tools.test sequences vectors arrays ; IN: temporary [ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test @@ -28,23 +28,11 @@ IN: temporary [ "end" ] [ "Beginning and end" 14 tail ] unit-test -[ t ] [ CHAR: a letter? ] unit-test -[ f ] [ CHAR: A letter? ] unit-test -[ f ] [ CHAR: a LETTER? ] unit-test -[ t ] [ CHAR: A LETTER? ] unit-test -[ t ] [ CHAR: 0 digit? ] unit-test -[ f ] [ CHAR: x digit? ] unit-test - [ t ] [ "abc" "abd" <=> 0 < ] unit-test [ t ] [ "z" "abd" <=> 0 > ] unit-test [ f ] [ [ 0 10 "hello" subseq ] catch not ] unit-test -[ 4 ] [ - 0 "There are Four Upper Case characters" - [ LETTER? [ 1+ ] when ] each -] unit-test - [ "Replacing+spaces+with+plus" ] [ "Replacing spaces with plus" @@ -63,6 +51,45 @@ unit-test [ "ab" ] [ 2 "abc" resize-string ] unit-test [ "abc\0\0\0" ] [ 6 "abc" resize-string ] unit-test +[ "\u001234b" ] [ 2 "\u001234bc" resize-string ] unit-test +[ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test + ! Random tester found this [ { "kernel-error" 3 12 -7 } ] [ [ 2 -7 resize-string ] catch ] unit-test + +! Make sure 24-bit strings work +"hello world" "s" set + +[ ] [ HEX: 1234 1 "s" get set-nth ] unit-test +[ ] [ HEX: 4321 3 "s" get set-nth ] unit-test +[ ] [ HEX: 654321 5 "s" get set-nth ] unit-test + +[ + { + CHAR: h + HEX: 1234 + CHAR: l + HEX: 4321 + CHAR: o + HEX: 654321 + CHAR: w + CHAR: o + CHAR: r + CHAR: l + CHAR: d + } +] [ + "s" get >array +] unit-test + +! Make sure we clear aux vector when storing octets +[ "\u123456hi" ] [ "ih\u123456" clone dup reverse-here ] unit-test + +! Make sure aux vector is not shared +[ "\udeadbe" ] [ + "\udeadbe" clone + CHAR: \u123456 over clone set-first +] unit-test + + diff --git a/core/strings/strings.factor b/core/strings/strings.factor index 10f38f8298..bb3c94ce97 100755 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -1,14 +1,15 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private sequences kernel.private -math sequences.private slots.private ; +math sequences.private slots.private byte-arrays +alien.accessors ; IN: strings r >fixnum r> char-slot ; +M: string nth-unsafe + >r >fixnum r> string-nth ; -M: string set-nth-unsafe +M: string set-nth-unsafe dup reset-string-hashcode - >r >fixnum >r >fixnum r> r> set-char-slot ; + >r >fixnum >r >fixnum r> r> set-string-nth ; -M: string clone (clone) ; +M: string clone + (clone) dup string-aux clone over set-string-aux ; M: string resize resize-string ; -! Characters -: blank? ( ch -- ? ) " \t\n\r" member? ; inline -: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline -: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline -: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline -: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline -: control? ( ch -- ? ) "\0\e\r\n\t\u0008\u007f" member? ; inline - -: quotable? ( ch -- ? ) - dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline - -: Letter? ( ch -- ? ) - dup letter? [ drop t ] [ LETTER? ] if ; inline - -: alpha? ( ch -- ? ) - dup Letter? [ drop t ] [ digit? ] if ; inline - -: ch>lower ( ch -- lower ) - dup LETTER? [ HEX: 20 + ] when ; inline - -: ch>upper ( ch -- upper ) - dup letter? [ HEX: 20 - ] when ; inline - -: >lower ( str -- lower ) [ ch>lower ] map ; - -: >upper ( str -- upper ) [ ch>upper ] map ; - : 1string ( ch -- str ) 1 swap ; : >string ( seq -- str ) "" clone-like ; diff --git a/core/strings/tags.txt b/core/strings/tags.txt index 42d711b32b..de2741b09f 100644 --- a/core/strings/tags.txt +++ b/core/strings/tags.txt @@ -1 +1,2 @@ +text collections diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 9cf9647e41..2e5b41cd8d 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -99,9 +99,9 @@ ARTICLE: "escape" "Character escape codes" { { $snippet "\\e" } "escape (ASCII 27)" } { { $snippet "\\\"" } { $snippet "\"" } } } -"A Unicode character can be specified by its code number by writing " { $snippet "\\u" } " followed by a four-digit hexadecimal number. That is, the following two expressions are equivalent:" +"A Unicode character can be specified by its code number by writing " { $snippet "\\u" } " followed by a six-digit hexadecimal number. That is, the following two expressions are equivalent:" { $code - "CHAR: \\u0078" + "CHAR: \\u000078" "78" } "While not useful for single characters, this syntax is also permitted inside strings." ; @@ -151,6 +151,18 @@ ARTICLE: "syntax-byte-arrays" "Byte array syntax" { $subsection POSTPONE: B{ } "Byte arrays are documented in " { $link "byte-arrays" } "." ; +ARTICLE: "syntax-bit-vectors" "Bit vector syntax" +{ $subsection POSTPONE: ?V{ } +"Bit vectors are documented in " { $link "bit-vectors" } "." ; + +ARTICLE: "syntax-float-vectors" "Float vector syntax" +{ $subsection POSTPONE: FV{ } +"Float vectors are documented in " { $link "float-vectors" } "." ; + +ARTICLE: "syntax-byte-vectors" "Byte vector syntax" +{ $subsection POSTPONE: BV{ } +"Byte vectors are documented in " { $link "byte-vectors" } "." ; + ARTICLE: "syntax-pathnames" "Pathname syntax" { $subsection POSTPONE: P" } "Pathnames are documented in " { $link "file-streams" } "." ; @@ -165,11 +177,15 @@ $nl { $subsection "syntax-words" } { $subsection "syntax-quots" } { $subsection "syntax-arrays" } -{ $subsection "syntax-vectors" } { $subsection "syntax-strings" } -{ $subsection "syntax-sbufs" } -{ $subsection "syntax-byte-arrays" } { $subsection "syntax-bit-arrays" } +{ $subsection "syntax-byte-arrays" } +{ $subsection "syntax-float-arrays" } +{ $subsection "syntax-vectors" } +{ $subsection "syntax-sbufs" } +{ $subsection "syntax-bit-vectors" } +{ $subsection "syntax-byte-vectors" } +{ $subsection "syntax-float-vectors" } { $subsection "syntax-hashtables" } { $subsection "syntax-tuples" } { $subsection "syntax-pathnames" } ; @@ -273,12 +289,30 @@ HELP: B{ { $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." } { $examples { $code "B{ 1 2 3 }" } } ; +HELP: BV{ +{ $syntax "BV{ elements... }" } +{ $values { "elements" "a list of bytes" } } +{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "BV{ 1 2 3 12 }" } } ; + HELP: ?{ { $syntax "?{ elements... }" } { $values { "elements" "a list of booleans" } } { $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." } { $examples { $code "?{ t f t }" } } ; +HELP: ?V{ +{ $syntax "?V{ elements... }" } +{ $values { "elements" "a list of booleans" } } +{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "?V{ t f t }" } } ; + +HELP: FV{ +{ $syntax "FV{ elements... }" } +{ $values { "elements" "a list of real numbers" } } +{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } +{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ; + HELP: F{ { $syntax "F{ elements... }" } { $values { "elements" "a list of real numbers" } } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 7616f6e64b..006f1a225f 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays bit-arrays byte-arrays definitions generic -hashtables kernel math namespaces parser sequences strings sbufs -vectors words quotations io assocs splitting tuples -generic.standard generic.math classes io.files vocabs -float-arrays classes.union classes.mixin classes.predicate -compiler.units ; +USING: alien arrays bit-arrays bit-vectors byte-arrays +byte-vectors definitions generic hashtables kernel math +namespaces parser sequences strings sbufs vectors words +quotations io assocs splitting tuples generic.standard +generic.math classes io.files vocabs float-arrays float-vectors +classes.union classes.mixin classes.predicate compiler.units ; IN: bootstrap.syntax ! These words are defined as a top-level form, instead of with @@ -71,8 +71,11 @@ IN: bootstrap.syntax "{" [ \ } [ >array ] parse-literal ] define-syntax "V{" [ \ } [ >vector ] parse-literal ] define-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax + "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax + "?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax "F{" [ \ } [ >float-array ] parse-literal ] define-syntax + "FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax "T{" [ \ } [ >tuple ] parse-literal ] define-syntax "W{" [ \ } [ first ] parse-literal ] define-syntax diff --git a/core/syntax/tags.txt b/core/syntax/tags.txt new file mode 100755 index 0000000000..e69de29bb2 diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index d91a84ec99..d80cfa9ceb 100644 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -49,6 +49,7 @@ HELP: os "linux" "macosx" "openbsd" + "netbsd" "solaris" "windows" } diff --git a/core/system/system.factor b/core/system/system.factor index 845ba8265d..4983260a36 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -39,11 +39,11 @@ splitting assocs ; : unix? ( -- ? ) os { - "freebsd" "openbsd" "linux" "macosx" "solaris" + "freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris" } member? ; : bsd? ( -- ? ) - os { "freebsd" "openbsd" "macosx" } member? ; + os { "freebsd" "openbsd" "netbsd" "macosx" } member? ; : linux? ( -- ? ) os "linux" = ; diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor old mode 100644 new mode 100755 index 9c7b5c960a..306c7f4726 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -80,8 +80,8 @@ PRIVATE> } ; : define-tuple-slots ( class slots -- ) - 2dup "slot-names" set-word-prop dupd 4 simple-slots + 2dup [ slot-spec-name ] map "slot-names" set-word-prop 2dup delegate-slot-spec add* "slots" set-word-prop define-slots ; diff --git a/core/vectors/vectors-docs.factor b/core/vectors/vectors-docs.factor old mode 100644 new mode 100755 index 56c59fac46..b130dc4a71 --- a/core/vectors/vectors-docs.factor +++ b/core/vectors/vectors-docs.factor @@ -30,10 +30,10 @@ HELP: >vector { $values { "seq" "a sequence" } { "vector" vector } } { $description "Outputs a freshly-allocated vector with the same elements as a given sequence." } ; -HELP: array>vector ( array length -- vector ) +HELP: array>vector { $values { "array" "an array" } { "length" "a non-negative integer" } { "vector" vector } } { $description "Creates a new vector using the array for underlying storage with the specified initial length." } -{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ; +{ $warning "This word is in the " { $vocab-link "vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >vector } " instead." } ; HELP: 1vector { $values { "x" object } { "vector" vector } } diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index 8d52b8fa9c..ed97bcc0c4 100755 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -1,10 +1,15 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel kernel.private math -math.private sequences sequences.private vectors.private -growable ; +USING: arrays kernel math sequences sequences.private growable ; IN: vectors +vector ( byte-array capacity -- byte-vector ) + vector construct-boa ; inline + +PRIVATE> + : ( n -- vector ) f 0 array>vector ; inline : >vector ( seq -- vector ) V{ } clone-like ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 20dbe7594f..f2c5b2a012 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -148,8 +148,16 @@ SYMBOL: load-help? dup update-roots dup modified-sources swap modified-docs ; +: require-restart { { "Ignore this vocabulary" t } } ; + : require-all ( seq -- ) - [ [ require ] each ] with-compiler-errors ; + [ + [ + [ require ] + [ require-restart rethrow-restarts 2drop ] + recover + ] each + ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) 2dup diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index a88892b5f4..2455250dc9 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -175,3 +175,14 @@ SYMBOL: quot-uses-b [ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test [ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test + +! Regressions +[ ] [ "IN: temporary : decl-forget-test ; foldable" eval ] unit-test +[ t ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test +[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test +[ f ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test + +[ ] [ "IN: temporary : decl-forget-test ; flushable" eval ] unit-test +[ t ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test +[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test +[ f ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test diff --git a/core/words/words.factor b/core/words/words.factor index a2d9234353..5dc89212a8 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -87,6 +87,25 @@ M: wrapper (quot-uses) >r wrapped r> (quot-uses) ; M: word uses ( word -- seq ) word-def quot-uses keys ; +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* ; + +: delete-compiled-xref ( word -- ) + dup compiled-unxref + compiled-crossref get delete-at ; + +: compiled-usage ( word -- assoc ) + compiled-crossref get at ; + M: word redefined* ( word -- ) { "inferred-effect" "base-case" "no-effect" } reset-props ; @@ -127,7 +146,7 @@ SYMBOL: changed-words : reset-word ( word -- ) { "unannotated-def" - "parsing" "inline" "foldable" + "parsing" "inline" "foldable" "flushable" "predicating" "reading" "writing" "constructing" @@ -187,6 +206,7 @@ M: word (forget-word) : forget-word ( word -- ) dup delete-xref + dup delete-compiled-xref (forget-word) ; M: word forget* forget-word ; diff --git a/extra/store/authors.txt b/extra/alarms/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from extra/store/authors.txt rename to extra/alarms/authors.txt diff --git a/extra/cabal/authors.txt b/extra/arrays/lib/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from extra/cabal/authors.txt rename to extra/arrays/lib/authors.txt diff --git a/extra/ascii/ascii-docs.factor b/extra/ascii/ascii-docs.factor new file mode 100755 index 0000000000..1f7a56bed9 --- /dev/null +++ b/extra/ascii/ascii-docs.factor @@ -0,0 +1,51 @@ +USING: help.markup help.syntax ; +IN: ascii + +HELP: blank? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII whitespace character." } ; + +HELP: letter? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for a lowercase alphabet ASCII character." } ; + +HELP: LETTER? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for a uppercase alphabet ASCII character." } ; + +HELP: digit? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII decimal digit character." } ; + +HELP: Letter? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ; + +HELP: alpha? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an alphanumeric ASCII character." } ; + +HELP: printable? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for a printable ASCII character." } ; + +HELP: control? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII control character." } ; + +HELP: quotable? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ; + +ARTICLE: "ascii" "ASCII character classes" +"Traditional ASCII character classes:" +{ $subsection blank? } +{ $subsection letter? } +{ $subsection LETTER? } +{ $subsection digit? } +{ $subsection printable? } +{ $subsection control? } +{ $subsection quotable? } +"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode" } ")." ; + +ABOUT: "ascii" diff --git a/extra/ascii/ascii-tests.factor b/extra/ascii/ascii-tests.factor new file mode 100644 index 0000000000..ec76d89d7c --- /dev/null +++ b/extra/ascii/ascii-tests.factor @@ -0,0 +1,15 @@ +IN: temporary +USING: ascii tools.test sequences kernel math ; + +[ t ] [ CHAR: a letter? ] unit-test +[ f ] [ CHAR: A letter? ] unit-test +[ f ] [ CHAR: a LETTER? ] unit-test +[ t ] [ CHAR: A LETTER? ] unit-test +[ t ] [ CHAR: 0 digit? ] unit-test +[ f ] [ CHAR: x digit? ] unit-test + + +[ 4 ] [ + 0 "There are Four Upper Case characters" + [ LETTER? [ 1+ ] when ] each +] unit-test diff --git a/extra/ascii/ascii.factor b/extra/ascii/ascii.factor new file mode 100755 index 0000000000..e4a365cd1b --- /dev/null +++ b/extra/ascii/ascii.factor @@ -0,0 +1,26 @@ +! Copyright (C) 2005, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences math kernel ; +IN: ascii + +: blank? ( ch -- ? ) " \t\n\r" member? ; inline + +: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline + +: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline + +: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline + +: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline + +: control? ( ch -- ? ) + "\0\e\r\n\t\u000008\u00007f" member? ; inline + +: quotable? ( ch -- ? ) + dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline + +: Letter? ( ch -- ? ) + dup letter? [ drop t ] [ LETTER? ] if ; inline + +: alpha? ( ch -- ? ) + dup Letter? [ drop t ] [ digit? ] if ; inline diff --git a/extra/ascii/authors.txt b/extra/ascii/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/ascii/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/ascii/summary.txt b/extra/ascii/summary.txt new file mode 100755 index 0000000000..ae2ea69b8b --- /dev/null +++ b/extra/ascii/summary.txt @@ -0,0 +1 @@ +ASCII character classes diff --git a/extra/ascii/tags.txt b/extra/ascii/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/ascii/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/asn1/asn1-tests.factor b/extra/asn1/asn1-tests.factor old mode 100644 new mode 100755 index 1277090ec7..1c9bc79d76 --- a/extra/asn1/asn1-tests.factor +++ b/extra/asn1/asn1-tests.factor @@ -1,7 +1,7 @@ USING: asn1 asn1.ldap io io.streams.string tools.test ; [ 6 ] [ - "\u0002\u0001\u0006" [ asn-syntax read-ber ] with-stream + "\u000002\u000001\u000006" [ asn-syntax read-ber ] with-stream ] unit-test [ "testing" ] [ diff --git a/extra/asn1/ldap/authors.txt b/extra/asn1/ldap/authors.txt new file mode 100755 index 0000000000..7c29e7c401 --- /dev/null +++ b/extra/asn1/ldap/authors.txt @@ -0,0 +1 @@ +Elie Chaftari diff --git a/extra/assoc-heaps/authors.txt b/extra/assoc-heaps/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/assoc-heaps/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/assoc-heaps/summary.txt b/extra/assoc-heaps/summary.txt new file mode 100755 index 0000000000..07ae2e33f8 --- /dev/null +++ b/extra/assoc-heaps/summary.txt @@ -0,0 +1 @@ +Priority search queues diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor old mode 100644 new mode 100755 index 50da66e669..849f88023f --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -7,17 +7,13 @@ IN: assocs.lib : >set ( seq -- hash ) [ dup ] H{ } map>assoc ; -: ref-hash ( table key -- value ) swap at ; +: ref-at ( table key -- value ) swap at ; -! set-hash with alternative stack effects +: put-at* ( table key value -- ) swap rot set-at ; -: put-hash* ( table key value -- ) spin set-at ; +: put-at ( table key value -- table ) swap pick set-at ; -: put-hash ( table key value -- table ) swap pick set-at ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: set-hash-stack ( value key seq -- ) +: set-assoc-stack ( value key seq -- ) dupd [ key? ] with find-last nip set-at ; : at-default ( key assoc -- value/key ) diff --git a/extra/lisp/authors.txt b/extra/automata/ui/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from extra/lisp/authors.txt rename to extra/automata/ui/authors.txt diff --git a/extra/benchmark/bootstrap1/authors.txt b/extra/benchmark/bootstrap1/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/bootstrap1/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/bootstrap2/authors.txt b/extra/benchmark/bootstrap2/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/bootstrap2/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor old mode 100644 new mode 100755 index b56b36ac41..bde92a2260 --- a/extra/benchmark/bootstrap2/bootstrap2.factor +++ b/extra/benchmark/bootstrap2/bootstrap2.factor @@ -1,9 +1,14 @@ -USING: tools.deploy.private io.files system -tools.deploy.backend ; +USING: io.files io.launcher system tools.deploy.backend +namespaces sequences kernel ; IN: benchmark.bootstrap2 : bootstrap-benchmark "." resource-path cd - vm { "-output-image=foo.image" "-no-user-init" } stage2 ; + [ + vm , + "-i=" boot-image-name append , + "-output-image=foo.image" , + "-no-user-init" , + ] { } make run-process drop ; MAIN: bootstrap-benchmark diff --git a/extra/benchmark/continuations/authors.txt b/extra/benchmark/continuations/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/continuations/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/dispatch1/authors.txt b/extra/benchmark/dispatch1/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/dispatch1/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/dispatch2/authors.txt b/extra/benchmark/dispatch2/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/dispatch2/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/dispatch3/authors.txt b/extra/benchmark/dispatch3/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/dispatch3/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/dispatch4/authors.txt b/extra/benchmark/dispatch4/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/dispatch4/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/empty-loop/authors.txt b/extra/benchmark/empty-loop/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/empty-loop/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/fib1/authors.txt b/extra/benchmark/fib1/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/fib1/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/fib2/authors.txt b/extra/benchmark/fib2/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/fib2/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/fib3/authors.txt b/extra/benchmark/fib3/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/fib3/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/fib4/authors.txt b/extra/benchmark/fib4/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/fib4/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/fib5/authors.txt b/extra/benchmark/fib5/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/fib5/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/iteration/authors.txt b/extra/benchmark/iteration/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/iteration/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index f036a644ae..ad1ffc1c50 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -1,6 +1,6 @@ USING: kernel io io.files splitting strings hashtables sequences assocs math namespaces prettyprint - math.parser combinators arrays sorting ; + math.parser combinators arrays sorting unicode.case ; IN: benchmark.knucleotide diff --git a/extra/benchmark/mandel/authors.txt b/extra/benchmark/mandel/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/mandel/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/nsieve-bits/authors.txt b/extra/benchmark/nsieve-bits/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/nsieve-bits/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/nsieve/authors.txt b/extra/benchmark/nsieve/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/nsieve/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/partial-sums/authors.txt b/extra/benchmark/partial-sums/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/partial-sums/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/raytracer/authors.txt b/extra/benchmark/raytracer/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/raytracer/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/recursive/authors.txt b/extra/benchmark/recursive/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/recursive/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/reverse-complement/authors.txt b/extra/benchmark/reverse-complement/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/reverse-complement/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index 332489abed..7b09b586f4 100644 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.duplex kernel sequences sequences.private strings vectors words memoize splitting -hints ; +hints unicode.case ; IN: benchmark.reverse-complement MEMO: trans-map ( -- str ) diff --git a/extra/benchmark/ring/authors.txt b/extra/benchmark/ring/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/ring/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/sha1/authors.txt b/extra/benchmark/sha1/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/sha1/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor index 614077c673..897d83ea0e 100644 --- a/extra/benchmark/sha1/sha1.factor +++ b/extra/benchmark/sha1/sha1.factor @@ -1,7 +1,7 @@ USING: crypto.sha1 io.files kernel ; IN: benchmark.sha1 -: sha1-primes-list ( -- seq ) - "extra/math/primes/list/list.factor" resource-path file>sha1 ; +: sha1-primes-list ( -- ) + "extra/math/primes/list/list.factor" resource-path file>sha1 drop ; MAIN: sha1-primes-list diff --git a/extra/benchmark/sort/authors.txt b/extra/benchmark/sort/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/sort/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/spectral-norm/authors.txt b/extra/benchmark/spectral-norm/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/spectral-norm/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/sum-file/authors.txt b/extra/benchmark/sum-file/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/sum-file/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/typecheck1/authors.txt b/extra/benchmark/typecheck1/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/typecheck1/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/typecheck2/authors.txt b/extra/benchmark/typecheck2/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/typecheck2/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/typecheck3/authors.txt b/extra/benchmark/typecheck3/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/typecheck3/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/benchmark/typecheck4/authors.txt b/extra/benchmark/typecheck4/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/benchmark/typecheck4/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/boids/ui/authors.txt b/extra/boids/ui/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/boids/ui/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor old mode 100644 new mode 100755 index 6d04a4d623..b545f41060 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -145,20 +145,20 @@ VARS: population-label cohesion-label alignment-label separation-label ; slate> over @center grid-add H{ } clone - T{ key-down f f "1" } C[ drop randomize ] put-hash - T{ key-down f f "2" } C[ drop sub-10-boids ] put-hash - T{ key-down f f "3" } C[ drop add-10-boids ] put-hash + T{ key-down f f "1" } C[ drop randomize ] put-at + T{ key-down f f "2" } C[ drop sub-10-boids ] put-at + T{ key-down f f "3" } C[ drop add-10-boids ] put-at - T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-hash - T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-hash + T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at + T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at - T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-hash - T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-hash + T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at + T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at - T{ key-down f f "e" } C[ drop inc-separation-weight ] put-hash - T{ key-down f f "d" } C[ drop dec-separation-weight ] put-hash + T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at + T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at - T{ key-down f f "ESC" } C[ drop toggle-loop ] put-hash + T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at tuck set-gadget-delegate "Boids" open-window ; : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ; diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 238a971e67..065f7dd5c4 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -10,6 +10,3 @@ IN: bootstrap.io { [ wince? ] [ "windows.ce" ] } } cond append require ] when - -init-io -init-stdio diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor new file mode 100644 index 0000000000..a9a4c159f8 --- /dev/null +++ b/extra/builder/builder.factor @@ -0,0 +1,115 @@ + +USING: kernel io io.files io.launcher tools.deploy.backend + system namespaces sequences splitting math.parser + unix prettyprint tools.time calendar bake vars ; + +IN: builder + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: datestamp ( -- string ) + now `{ ,[ dup timestamp-year ] + ,[ dup timestamp-month ] + ,[ dup timestamp-day ] + ,[ dup timestamp-hour ] + ,[ timestamp-minute ] } + [ number>string 2 CHAR: 0 pad-left ] map "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builder-recipients + +: quote ( str -- str ) "'" swap "'" 3append ; + +: email-file ( subject file -- ) + `{ + "cat" , + "| mutt -s" ,[ quote ] + "-x" %[ builder-recipients get ] + } + " " join system drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: stamp + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: build ( -- ) + +datestamp >stamp + +"/builds/factor" cd +"git pull git://factorcode.org/git/factor.git" system +0 = +[ ] +[ + "builder: git pull" "/dev/null" email-file + "builder: git pull" throw +] +if + +"/builds/" stamp> append make-directory +"/builds/" stamp> append cd +"git clone /builds/factor" system drop + +"factor" cd + +{ "git" "show" } +[ readln ] with-stream +" " split second +"../git-id" [ print ] with-stream + +"make clean" system drop + +"make " target " > ../compile-log" 3append system +0 = +[ ] +[ + "builder: vm compile" "../compile-log" email-file + "builder: vm compile" throw +] if + +"wget http://factorcode.org/images/latest/" boot-image-name append system +0 = +[ ] +[ + "builder: image download" "/dev/null" email-file + "builder: image download" throw +] if + +[ + "./factor -i=" boot-image-name " -no-user-init > ../boot-log" + 3append + system +] +benchmark nip +"../boot-time" [ . ] with-stream +0 = +[ ] +[ + "builder: bootstrap" "../boot-log" email-file + "builder: bootstrap" throw +] if + +[ + "./factor -e='USE: tools.browser load-everything' > ../load-everything-log" + system +] benchmark nip +"../load-everything-time" [ . ] with-stream +0 = +[ ] +[ + "builder: load-everything" "../load-everything-log" email-file + "builder: load-everything" throw +] if + +; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: build \ No newline at end of file diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor old mode 100644 new mode 100755 index 3042b87ad6..550eb50e0a --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -53,7 +53,7 @@ IN: bunny model-path resource-path dup exists? [ "Downloading bunny from " write model-url dup print flush - over download + over download-to ] unless ; : draw-triangle ( ns vs triple -- ) diff --git a/extra/cairo-demo/authors.txt b/extra/cairo-demo/authors.txt new file mode 100755 index 0000000000..4a2736dd93 --- /dev/null +++ b/extra/cairo-demo/authors.txt @@ -0,0 +1 @@ +Sampo Vuori diff --git a/extra/calendar/authors.txt b/extra/calendar/authors.txt index 7c1b2f2279..1901f27a24 100644 --- a/extra/calendar/authors.txt +++ b/extra/calendar/authors.txt @@ -1 +1 @@ -Doug Coleman +Slava Pestov diff --git a/extra/calendar/backend/authors.txt b/extra/calendar/backend/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/calendar/backend/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 8c1c2fb3a6..a1fe0a55ea 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -333,16 +333,18 @@ M: integer year. ( n -- ) M: timestamp year. ( timestamp -- ) timestamp-year year. ; -: pad-00 number>string 2 CHAR: 0 pad-left write ; +: pad-00 number>string 2 CHAR: 0 pad-left ; + +: write-00 pad-00 write ; : (timestamp>string) ( timestamp -- ) dup day-of-week day-abbreviations3 nth write ", " write dup timestamp-day number>string write bl dup timestamp-month month-abbreviations nth write bl dup timestamp-year number>string write bl - dup timestamp-hour pad-00 ":" write - dup timestamp-minute pad-00 ":" write - timestamp-second >fixnum pad-00 ; + dup timestamp-hour write-00 ":" write + dup timestamp-minute write-00 ":" write + timestamp-second >fixnum write-00 ; : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] string-out ; @@ -357,11 +359,11 @@ M: timestamp year. ( timestamp -- ) : (timestamp>rfc3339) ( timestamp -- ) dup timestamp-year number>string write CHAR: - write1 - dup timestamp-month pad-00 CHAR: - write1 - dup timestamp-day pad-00 CHAR: T write1 - dup timestamp-hour pad-00 CHAR: : write1 - dup timestamp-minute pad-00 CHAR: : write1 - timestamp-second >fixnum pad-00 CHAR: Z write1 ; + dup timestamp-month write-00 CHAR: - write1 + dup timestamp-day write-00 CHAR: T write1 + dup timestamp-hour write-00 CHAR: : write1 + dup timestamp-minute write-00 CHAR: : write1 + timestamp-second >fixnum write-00 CHAR: Z write1 ; : timestamp>rfc3339 ( timestamp -- str ) >gmt [ (timestamp>rfc3339) ] string-out ; @@ -390,8 +392,8 @@ M: timestamp year. ( timestamp -- ) [ timestamp-month month-abbreviations nth write ] keep bl [ timestamp-day number>string 2 32 pad-left write ] keep bl dup now [ timestamp-year ] 2apply = [ - [ timestamp-hour pad-00 ] keep ":" write - timestamp-minute pad-00 + [ timestamp-hour write-00 ] keep ":" write + timestamp-minute write-00 ] [ timestamp-year number>string 5 32 pad-left write ] if diff --git a/extra/calendar/model/model.factor b/extra/calendar/model/model.factor new file mode 100755 index 0000000000..855b0cd815 --- /dev/null +++ b/extra/calendar/model/model.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: calendar namespaces models threads init ; +IN: calendar.model + +SYMBOL: time + +: (time-thread) ( -- ) + now time get set-model + 1000 sleep (time-thread) ; + +: time-thread ( -- ) [ (time-thread) ] in-thread ; + +f time set-global +[ time-thread ] "calendar.model" add-init-hook diff --git a/extra/calendar/summary.txt b/extra/calendar/summary.txt index e2d2488d59..4cc85fd2b9 100644 --- a/extra/calendar/summary.txt +++ b/extra/calendar/summary.txt @@ -1 +1 @@ -Date and time classes +Timestamp model updated every second diff --git a/extra/calendar/unix/authors.txt b/extra/calendar/unix/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/calendar/unix/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/calendar/windows/authors.txt b/extra/calendar/windows/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/calendar/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor old mode 100644 new mode 100755 index 6c3a7a71e7..320400822c --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -1,5 +1,5 @@ -USING: alien alien.c-types kernel math -windows windows.kernel32 namespaces ; +USING: calendar.backend namespaces alien.c-types +windows windows.kernel32 kernel math ; IN: calendar.windows TUPLE: windows-calendar ; @@ -11,37 +11,3 @@ M: windows-calendar gmt-offset ( -- float ) [ GetTimeZoneInformation win32-error=0/f ] keep [ TIME_ZONE_INFORMATION-Bias ] keep TIME_ZONE_INFORMATION-DaylightBias + 60 /f neg ; - -: >64bit ( lo hi -- n ) - 32 shift bitor ; - -: windows-1601 ( -- timestamp ) - 1601 1 1 0 0 0 0 ; - -: FILETIME>windows-time ( FILETIME -- n ) - [ FILETIME-dwLowDateTime ] keep - FILETIME-dwHighDateTime >64bit ; - -: windows-time>timestamp ( n -- timestamp ) - 10000000 /i seconds windows-1601 swap +dt ; - -: windows-time ( -- n ) - "FILETIME" [ GetSystemTimeAsFileTime ] keep - FILETIME>windows-time ; - -: timestamp>windows-time ( timestamp -- n ) - #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC) - >gmt windows-1601 timestamp- >bignum 10000000 * ; - -: windows-time>FILETIME ( n -- FILETIME ) - "FILETIME" - [ - [ >r HEX: ffffffff bitand r> set-FILETIME-dwLowDateTime ] 2keep - >r -32 shift r> set-FILETIME-dwHighDateTime - ] keep ; - -: timestamp>FILETIME ( timestamp -- FILETIME/f ) - [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ; - -: FILETIME>timestamp ( FILETIME -- timestamp/f ) - FILETIME>windows-time windows-time>timestamp ; diff --git a/extra/catalyst-talk/catalyst-talk.factor b/extra/catalyst-talk/catalyst-talk.factor deleted file mode 100644 index f76ef4db9e..0000000000 --- a/extra/catalyst-talk/catalyst-talk.factor +++ /dev/null @@ -1,121 +0,0 @@ -USING: slides help.markup math arrays hashtables namespaces -sequences kernel sequences parser ; -IN: catalyst-talk - -: catalyst-slides -{ - { $slide "What is Factor?" - "Originally scripting for a Java game" - "Language dev more fun than game dev" - "Start with ideas which were mostly dead" - "Throw in features from crazy languages" - "Develop practical libraries and tools" - } - { $slide "Factor: a stack language" - "Implicit parameter passing" - { "Each " { $emphasis "word" } " is a function call" } - { $code ": sq dup * ;" } - { $code "2 3 + sq ." } - "Minimal syntax and semantics = easy meta-programming" - { "Related languages: Forth, Joy, PostScript" } - } - { $slide "Factor: a functional language" - { { $emphasis "Quotations" } " can be passed around, constructed..." } - { $code "[ sq 3 + ]" } - { { $emphasis "Combinators" } " are words which take quotations, eg " { $link if } } - { "For FP buffs: " { $link each } ", " { $link map } ", " { $link reduce } ", " { $link accumulate } ", " { $link interleave } ", " { $link subset } } - { $code "{ 42 69 666 } [ sq 3 + ] map ." } - } - { $slide "Factor: an object-oriented language" - { "Everything is an " { $emphasis "object" } } - { "An object is an instance of a " { $emphasis "class" } } - "Methods" - "Generic words" - "For CLOS buffs: we allow custom method combination, classes are objects too, there's a MOP" - } - - STRIP-TEASE: - $slide "Primary school geometry recap" - { $code - "GENERIC: area ( shape -- meters^2 )" - "TUPLE: square dimension ;" - "M: square area square-dimension sq ;" - "TUPLE: circle radius ;" - "M: circle area circle-radius sq pi * ;" - "TUPLE: rectangle width height ;" - "M: rectangle area" - " dup rectangle-width" - " swap rectangle-height" - " * ;" - } - ; - - { $slide "Geometry example" - { $code "10 area ." } - { $code "18 area ." } - { $code "20 40 area ." } - } -! { $slide "Factor: a meta language" -! "Writing code which writes code" -! "Extensible parser: define new syntax" -! "Compiler transforms" -! "Here's an inefficient word:" -! { $code -! ": fib ( x -- y )" -! " dup 1 > [" -! " 1 - dup fib swap 1 - fib +" -! " ] when ;" -! } -! } -! { $slide "Memoization" -! { { $link POSTPONE: : } " is just another word" } -! "What if we could define a word which caches its results?" -! { "The " { $vocab-link "memoize" } " library provides such a feature" } -! { "Just change " { $link POSTPONE: : } " to " { $link POSTPONE: MEMO: } } -! { $code -! "MEMO: fib ( x -- y )" -! " dup 1 > [" -! " 1 - dup fib swap 1 - fib +" -! " ] when ;" -! } -! } - { $slide "Factor: a tool-building language" - "Tools are not monolithic, but are themselves just sets of words" - "Examples: parser, compiler, etc" - "Parser: turns strings into objects" - { $code "\"1\" contents parse" } - "Prettyprinter: turns objects into strings" - { $code "\"2\" [ . ] with-stream" } - } - { $slide "Factor: an interactive language" - { "Let's hack " { $vocab-link "tetris" } } - "Editor integration" - { $code "\\ tetrominoes edit" } - "Inspector" - { $code "\\ tetrominoes get inspect" } - } - { $slide "C library interface" - "No need to write C glue code!" - "Callbacks from C to Factor" - "Factor can be embedded in C apps" - { "Example: " { $vocab-link "ogg.vorbis" } } - { "Other bindings: OpenGL, OpenAL, X11, Win32, Cocoa, OpenSSL, memory mapped files, ..." } - } - { $slide "Native libraries" - "XML, HTTP, SMTP, Unicode, calendar, ..." - "Lazy lists, pattern matching, packed arrays, ..." - } - { $slide "Factor: a fun language" - { "Let's play " - { $vocab-link "space-invaders" } - } - { $url "http://factorcode.org" } - { $url "http://factor-language.blogspot.com" } - "irc.freenode.net #concatenative" - "Have fun!" - } -} ; - -: catalyst-talk catalyst-slides slides-window ; - -MAIN: catalyst-talk diff --git a/extra/catalyst-talk/summary.txt b/extra/catalyst-talk/summary.txt deleted file mode 100644 index f2efe74db6..0000000000 --- a/extra/catalyst-talk/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Slides for a talk at Catalyst IT NZ, July 2007 diff --git a/extra/cel-shading/authors.txt b/extra/cel-shading/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/cel-shading/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor new file mode 100644 index 0000000000..64d23275e9 --- /dev/null +++ b/extra/cel-shading/cel-shading.factor @@ -0,0 +1,89 @@ +USING: arrays bunny combinators.lib io io.files kernel + math math.functions multiline continuations debugger + opengl opengl.gl opengl-demo-support + sequences ui ui.gadgets ui.render ; +IN: cel-shading + +TUPLE: cel-shading-gadget model program ; + +: ( -- cel-shading-gadget ) + 0.0 0.0 0.375 + maybe-download read-model + { set-delegate set-cel-shading-gadget-model } cel-shading-gadget construct ; + +STRING: cel-shading-vertex-shader-source +varying vec3 position, normal; + +void +main() +{ + gl_Position = ftransform(); + + position = gl_Vertex.xyz; + normal = gl_Normal; +} + +; + +STRING: cel-shading-fragment-shader-source +varying vec3 position, normal; +uniform vec3 light_direction; +uniform vec4 color; +uniform vec4 ambient, diffuse; + +float +smooth_modulate(vec3 direction, vec3 normal) +{ + return clamp(dot(direction, normal), 0.0, 1.0); +} + +float +modulate(vec3 direction, vec3 normal) +{ + float m = smooth_modulate(direction, normal); + return smoothstep(0.0, 0.01, m) * 0.4 + smoothstep(0.49, 0.5, m) * 0.5; +} + +void +main() +{ + vec3 direction = normalize(light_direction - position); + gl_FragColor = ambient + diffuse * color * vec4(vec3(modulate(direction, normal)), 1); +} + +; + +: cel-shading-program ( -- program ) + cel-shading-vertex-shader-source cel-shading-fragment-shader-source + ; + +M: cel-shading-gadget graft* ( gadget -- ) + [ "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions + 0.0 0.0 0.0 1.0 glClearColor + GL_CULL_FACE glEnable + GL_DEPTH_TEST glEnable + cel-shading-program swap set-cel-shading-gadget-program ] [ ] [ :c ] cleanup ; + +M: cel-shading-gadget ungraft* ( gadget -- ) + cel-shading-gadget-program [ delete-gl-program ] when* ; + +: cel-shading-draw-setup ( gadget -- gadget ) + [ demo-gadget-set-matrices ] keep + [ cel-shading-gadget-program + { [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ] + [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] + [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] + [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] } call-with + ] keep ; + +M: cel-shading-gadget draw-gadget* ( gadget -- ) + dup cel-shading-gadget-program [ + cel-shading-draw-setup + 0.0 -0.12 0.0 glTranslatef + cel-shading-gadget-model first3 draw-bunny + ] with-gl-program ; + +: cel-shading-window ( -- ) + [ "Cel Shading" open-window ] with-ui ; + +MAIN: cel-shading-window diff --git a/extra/cel-shading/summary.txt b/extra/cel-shading/summary.txt new file mode 100644 index 0000000000..60da092f6d --- /dev/null +++ b/extra/cel-shading/summary.txt @@ -0,0 +1 @@ +Stanford Bunny rendered with a cel-shading GLSL program \ No newline at end of file diff --git a/extra/cel-shading/tags.txt b/extra/cel-shading/tags.txt new file mode 100644 index 0000000000..0db7e8e629 --- /dev/null +++ b/extra/cel-shading/tags.txt @@ -0,0 +1,3 @@ +demos +opengl +glsl \ No newline at end of file diff --git a/extra/cfdg/gl/authors.txt b/extra/cfdg/gl/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/cfdg/gl/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/cfdg/models/aqua-star/authors.txt b/extra/cfdg/models/aqua-star/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/cfdg/models/aqua-star/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/cfdg/models/chiaroscuro/authors.txt b/extra/cfdg/models/chiaroscuro/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/cfdg/models/chiaroscuro/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/cfdg/models/flower6/authors.txt b/extra/cfdg/models/flower6/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/cfdg/models/flower6/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/cfdg/models/game1-turn6/authors.txt b/extra/cfdg/models/game1-turn6/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/cfdg/models/game1-turn6/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/cfdg/models/lesson/authors.txt b/extra/cfdg/models/lesson/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/cfdg/models/lesson/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/cfdg/models/sierpinski/authors.txt b/extra/cfdg/models/sierpinski/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/cfdg/models/sierpinski/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/cfdg/models/snowflake/authors.txt b/extra/cfdg/models/snowflake/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/cfdg/models/snowflake/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index 33d635c8b7..e2072f441c 100755 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -79,11 +79,11 @@ MACRO: (send) ( selector super? -- quot ) super-message-senders message-senders ? get at [ slip execute ] 2curry ; -: send ( args... receiver selector -- return... ) f (send) ; inline +: send ( receiver args... selector -- return... ) f (send) ; inline \ send soft "break-after" set-word-prop -: super-send ( args... receiver selector -- return... ) t (send) ; inline +: super-send ( receiver args... selector -- return... ) t (send) ; inline \ super-send soft "break-after" set-word-prop diff --git a/extra/cocoa/plists/authors.txt b/extra/cocoa/plists/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/cocoa/plists/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/colors/hsv/authors.txt b/extra/colors/hsv/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/colors/hsv/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/combinators/cleave/authors.txt b/extra/combinators/cleave/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/combinators/cleave/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/combinators/lib/authors.txt b/extra/combinators/lib/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/combinators/lib/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/combinators/lib/lib-docs.factor b/extra/combinators/lib/lib-docs.factor old mode 100644 new mode 100755 index ac05160b31..02c3556742 --- a/extra/combinators/lib/lib-docs.factor +++ b/extra/combinators/lib/lib-docs.factor @@ -83,15 +83,6 @@ HELP: count "50" } ; -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: && { $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } } { $description "Calls each quotation in turn; outputs " { $link f } " if one of the quotations output " { $link f } ", otherwise outputs " { $link t } ". As soon as a quotation outputs " { $link f } ", evaluation stops and subsequent quotations are not called." } ; diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor old mode 100644 new mode 100755 index 0d76e6f50d..deeb105758 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -7,8 +7,6 @@ IN: temporary [ 50 ] [ 100 [1,b] [ even? ] count ] unit-test [ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test [ 328350 ] [ 100 [ sq ] sigma ] unit-test -[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test -[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test : infers? [ infer drop ] curry catch not ; diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index aae4c5d9ab..9f0f7df1ce 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -98,8 +98,6 @@ MACRO: nfirst ( n -- ) : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline -: all-unique? ( seq -- ? ) [ prune ] keep [ length ] 2apply = ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! short circuiting words ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -173,14 +171,24 @@ MACRO: parallel-call ( quots -- ) ! map-call and friends ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: (make-call-with) ( quots -- quot ) + [ [ keep ] curry ] map concat [ drop ] append ; + +MACRO: call-with ( quots -- ) + (make-call-with) ; + MACRO: map-call-with ( quots -- ) - [ [ [ keep ] curry ] map concat ] keep length [ nip narray ] curry compose ; + [ (make-call-with) ] keep length [ narray ] curry compose ; + +: (make-call-with2) ( quots -- quot ) + [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat + [ 2drop ] append ; + +MACRO: call-with2 ( quots -- ) + (make-call-with2) ; MACRO: map-call-with2 ( quots -- ) - dup >r - [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat - [ 2drop ] append - r> length [ narray ] curry append ; + dup >r (make-call-with2) r> length [ narray ] curry append ; MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ; diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index e1377f5265..7e76ff242a 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -127,7 +127,7 @@ ARTICLE: { "concurrency" "processes" } "Processes" { $code ": odd? ( n -- ? ) 2 mod 1 = ;\n1 self send 2 self send 3 self send\n\nreceive .\n => 1\n\n[ odd? ] receive-if .\n => 3\n\nreceive .\n => 2" } ; ARTICLE: { "concurrency" "self" } "Self" -"A process can get access to its own process object using " { $link self } " so it can pass it to other processes. This allows the other processes to send messages back. A simple example of using this gets the current processes 'self' and spawns a process which sends a message to it. We then receive the message from the original process:" +"A process can get access to its own process object using " { $link self } " so it can pass it to other processes. This allows the other processes to send messages back. A simple example of using this gets the current process' 'self' and spawns a process which sends a message to it. We then receive the message from the original process:" { $code "self [ \"Hello!\" swap send ] spawn 2drop receive .\n => \"Hello!\"" } ; ARTICLE: { "concurrency" "servers" } "Servers" @@ -150,7 +150,7 @@ ARTICLE: { "concurrency" "exceptions" } "Exceptions" "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; ARTICLE: { "concurrency" "futures" } "Futures" -"A future is a placeholder for the result of a computation that is being calculated in a process. When the process has completed the computation the future can be queried to find out the result. If the computation has not completed when the future is queried them the process will block until the result is completed.

A future is created using " { $link future } ".\n\nThe quotation will be run in a spawned process, and a future object is immediately returned. This future object can be resolved using " { $link ?future } ".\n\nFutures are useful for starting calculations that take a long time to run but aren't needed until later in the process. When the process needs the value it can use '?future' to get the result or block until the result is available. For example:" +"A future is a placeholder for the result of a computation that is being calculated in a process. When the process has completed the computation the future can be queried to find out the result. If the computation has not completed when the future is queried them the process will block until the result is completed. A future is created using " { $link future } ".\n\nThe quotation will be run in a spawned process, and a future object is immediately returned. This future object can be resolved using " { $link ?future } ".\n\nFutures are useful for starting calculations that take a long time to run but aren't needed until later in the process. When the process needs the value it can use '?future' to get the result or block until the result is available. For example:" { $code "[ 30 fib ] future\n...do stuff...\n?future" } ; ARTICLE: { "concurrency" "promises" } "Promises" diff --git a/extra/const/const.factor b/extra/const/const.factor index 59d65edaae..8efef7e372 100644 --- a/extra/const/const.factor +++ b/extra/const/const.factor @@ -14,3 +14,11 @@ IN: const : ENUM: ";" parse-tokens [ create-in ] map define-enum ; parsing + +: define-value ( word -- ) + { f } clone [ first ] curry define ; + +: VALUE: CREATE define-value ; parsing + +: set-value ( value word -- ) + word-def first set-first ; diff --git a/extra/contributors/summary.txt b/extra/contributors/summary.txt index ca6fc06710..f0b8e5b603 100644 --- a/extra/contributors/summary.txt +++ b/extra/contributors/summary.txt @@ -1 +1 @@ -Contributor patch count tally from darcs demo +Contributor patch counts from git diff --git a/extra/cryptlib/cryptlib.factor b/extra/cryptlib/cryptlib.factor index 65d2ffe48f..2ba81ef15a 100644 --- a/extra/cryptlib/cryptlib.factor +++ b/extra/cryptlib/cryptlib.factor @@ -6,7 +6,7 @@ ! Adapted from cryptlib.h ! Tested with cryptlib 3.3.1.0 USING: cryptlib.libcl kernel hashtables alien math -namespaces sequences assocs libc alien.c-types continuations ; +namespaces sequences assocs libc alien.c-types alien.accessors continuations ; IN: cryptlib diff --git a/extra/cryptlib/streams/streams.factor b/extra/cryptlib/streams/streams.factor old mode 100644 new mode 100755 index 77a34e84d1..04106285e0 --- a/extra/cryptlib/streams/streams.factor +++ b/extra/cryptlib/streams/streams.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007 Matthew Willis ! See http://factorcode.org/license.txt for BSD license. -USING: cryptlib cryptlib.libcl kernel alien sequences +USING: cryptlib cryptlib.libcl kernel alien sequences continuations byte-arrays namespaces io.buffers math generic io strings io.streams.lines io.streams.plain io.streams.duplex combinators -alien.c-types ; +alien.c-types continuations ; IN: cryptlib.streams @@ -84,7 +84,7 @@ M: crypt-stream stream-write1 ( ch stream -- ) : check-close ( err -- ) dup CRYPT_ERROR_PARAM1 = [ drop ] [ check-result ] if ; -M: crypt-stream stream-close ( stream -- ) +M: crypt-stream dispose ( stream -- ) crypt-stream-handle cryptDestroySession check-close ; : create-session ( format -- session ) @@ -115,7 +115,7 @@ M: crypt-stream stream-close ( stream -- ) dup stream-readln print - stream-close + dispose end ; @@ -130,7 +130,7 @@ M: crypt-stream stream-close ( stream -- ) "Thanks!" over stream-print dup stream-flush - stream-close + dispose end ; @@ -152,6 +152,6 @@ M: crypt-stream stream-close ( stream -- ) (rpl) - stream-close + dispose end - ; \ No newline at end of file + ; diff --git a/extra/crypto/barrett/authors.txt b/extra/crypto/barrett/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/crypto/barrett/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/crypto/common/authors.txt b/extra/crypto/common/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/crypto/common/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/crypto/hmac/authors.txt b/extra/crypto/hmac/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/crypto/hmac/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor old mode 100644 new mode 100755 index ccb380e1e0..64efb96f90 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -1,11 +1,11 @@ USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ; IN: temporary -[ "\u0092\u0094rz68\u00bb\u001c\u0013\u00f4\u008e\u00f8\u0015\u008b\u00fc\u009d" ] [ 16 11 "Hi There" string>md5-hmac >string ] unit-test -[ "u\u000cx>j\u00b0\u00b5\u0003\u00ea\u00a8n1\n]\u00b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test -[ "V\u00be4R\u001d\u0014L\u0088\u00db\u00b8\u00c73\u00f0\u00e8\u00b3\u00f6" ] [ 16 HEX: aa 50 HEX: dd string>md5-hmac >string ] unit-test +[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" string>md5-hmac >string ] unit-test +[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test +[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa 50 HEX: dd string>md5-hmac >string ] unit-test -[ "g[\u000b:\eM\u00dfN\u0012Hr\u00dal/c+\u00fe\u00d9W\u00e9" ] [ 16 11 "Hi There" string>sha1-hmac >string ] unit-test -[ "\u00ef\u00fc\u00dfj\u00e5\u00eb/\u00a2\u00d2t\u0016\u00d5\u00f1\u0084\u00df\u009c%\u009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test -[ "\u00d70YM\u0016~5\u00d5\u0095o\u00d8\0=\r\u00b3\u00d3\u00f4m\u00c7\u00bb" ] [ 16 HEX: aa 50 HEX: dd string>sha1-hmac >string ] unit-test +[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" string>sha1-hmac >string ] unit-test +[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test +[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd string>sha1-hmac >string ] unit-test diff --git a/extra/crypto/md5/authors.txt b/extra/crypto/md5/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/crypto/md5/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/crypto/rc4/authors.txt b/extra/crypto/rc4/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/crypto/rc4/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/crypto/rsa/authors.txt b/extra/crypto/rsa/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/crypto/rsa/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/crypto/sha1/authors.txt b/extra/crypto/sha1/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/crypto/sha1/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/crypto/sha1/sha1-tests.factor b/extra/crypto/sha1/sha1-tests.factor old mode 100644 new mode 100755 index c4f06800c8..795ee4971d --- a/extra/crypto/sha1/sha1-tests.factor +++ b/extra/crypto/sha1/sha1-tests.factor @@ -7,8 +7,8 @@ USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ; 10 swap concat string>sha1str ] unit-test [ - ";\u009b\u00fd\u00cdK\u00a3^s\u00d0*\u00e3\\\u00b5\u0013<\u00e8wA\u00b2\u0083\u00d20\u00f1\u00e6\u00cc\u00d8\u001e\u009c\u0004\u00d7PT]\u00ce,\u0001\u0012\u0080\u0096\u0099" + ";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099" ] [ - "\u0066\u0053\u00f1\u000c\u001a\u00fa\u00b5\u004c\u0061\u00c8\u0025\u0075\u00a8\u004a\u00fe\u0030\u00d8\u00aa\u001a\u003a\u0096\u0096\u00b3\u0018\u0099\u0092\u00bf\u00e1\u00cb\u007f\u00a6\u00a7" + "\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7" string>sha1-interleave ] unit-test diff --git a/extra/crypto/sha2/authors.txt b/extra/crypto/sha2/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/crypto/sha2/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/crypto/timing/authors.txt b/extra/crypto/timing/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/crypto/timing/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/crypto/xor/authors.txt b/extra/crypto/xor/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/crypto/xor/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/delegate/authors.txt b/extra/delegate/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/delegate/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/delegate/protocols/authors.txt b/extra/delegate/protocols/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/delegate/protocols/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor old mode 100644 new mode 100755 index 07f4ce119a..1121883b7c --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -15,7 +15,7 @@ PROTOCOL: assoc-protocol ! everything should work, just slower (with >alist) PROTOCOL: stream-protocol - stream-close stream-read1 stream-read stream-read-until + stream-read1 stream-read stream-read-until stream-flush stream-write1 stream-write stream-format stream-nl make-span-stream make-block-stream stream-readln make-cell-stream stream-write-table set-timeout ; diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 19fca8b24c..a9b696179e 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel math models namespaces sequences strings -splitting io.streams.lines combinators ; +splitting io.streams.lines combinators unicode.categories ; IN: documents : +col ( loc n -- newloc ) >r first2 r> + 2array ; diff --git a/extra/editors/editpadpro/editpadpro.factor b/extra/editors/editpadpro/editpadpro.factor old mode 100644 new mode 100755 index 69a9e2badd..885349e27b --- a/extra/editors/editpadpro/editpadpro.factor +++ b/extra/editors/editpadpro/editpadpro.factor @@ -10,6 +10,8 @@ IN: editors.editpadpro ] unless* ; : editpadpro ( file line -- ) - [ editpadpro-path % " /l" % # " \"" % % "\"" % ] "" make run-detached ; + [ + editpadpro-path , "/l" swap number>string append , , + ] { } make run-detached drop ; [ editpadpro ] edit-hook set-global diff --git a/extra/editors/editplus/editplus.factor b/extra/editors/editplus/editplus.factor index bff523b50d..feaa177954 100755 --- a/extra/editors/editplus/editplus.factor +++ b/extra/editors/editplus/editplus.factor @@ -9,7 +9,7 @@ IN: editors.editplus : editplus ( file line -- ) [ - editplus-path % " -cursor " % # " " % % - ] "" make run-detached ; + editplus-path , "-cursor" , number>string , , + ] { } make run-detached drop ; [ editplus ] edit-hook set-global diff --git a/extra/editors/emacs/emacs.factor b/extra/editors/emacs/emacs.factor old mode 100644 new mode 100755 index e131179755..31e0761043 --- a/extra/editors/emacs/emacs.factor +++ b/extra/editors/emacs/emacs.factor @@ -4,8 +4,11 @@ IN: editors.emacs : emacsclient ( file line -- ) [ - "emacsclient --no-wait +" % # " " % % - ] "" make run-process ; + "emacsclient" , + "--no-wait" , + "+" swap number>string append , + , + ] { } make run-process drop ; : emacs ( word -- ) where first2 emacsclient ; diff --git a/extra/editors/emeditor/emeditor.factor b/extra/editors/emeditor/emeditor.factor index 2caa42b480..bed333694c 100755 --- a/extra/editors/emeditor/emeditor.factor +++ b/extra/editors/emeditor/emeditor.factor @@ -9,8 +9,7 @@ IN: editors.emeditor : emeditor ( file line -- ) [ - emeditor-path % " /l " % # - " " % "\"" % % "\"" % - ] "" make run-detached ; + emeditor-path , "/l" , number>string , , + ] { } make run-detached drop ; [ emeditor ] edit-hook set-global diff --git a/extra/editors/gvim/backend/authors.txt b/extra/editors/gvim/backend/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/editors/gvim/backend/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/editors/gvim/unix/authors.txt b/extra/editors/gvim/unix/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/editors/gvim/unix/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/editors/gvim/windows/authors.txt b/extra/editors/gvim/windows/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/editors/gvim/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor index 5a3ea6b67a..5b51738eea 100644 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -1,4 +1,4 @@ -USING: editors.gvim io.files io.windows kernel namespaces +USING: editors.gvim.backend io.files io.windows kernel namespaces sequences windows.shell32 ; IN: editors.gvim.windows diff --git a/extra/editors/notepadpp/notepadpp.factor b/extra/editors/notepadpp/notepadpp.factor old mode 100644 new mode 100755 index 4f3fde917d..72ac6c72d7 --- a/extra/editors/notepadpp/notepadpp.factor +++ b/extra/editors/notepadpp/notepadpp.factor @@ -1,5 +1,5 @@ USING: editors io.files io.launcher kernel math.parser -namespaces windows.shell32 ; +namespaces sequences windows.shell32 ; IN: editors.notepadpp : notepadpp-path @@ -9,7 +9,8 @@ IN: editors.notepadpp : notepadpp ( file line -- ) [ - notepadpp-path % " -n" % # " " % % - ] "" make run-detached ; + notepadpp-path , + "-n" swap number>string append , , + ] { } make run-detached drop ; [ notepadpp ] edit-hook set-global diff --git a/extra/editors/scite/scite.factor b/extra/editors/scite/scite.factor old mode 100644 new mode 100755 index 529d11b722..ac9a032abc --- a/extra/editors/scite/scite.factor +++ b/extra/editors/scite/scite.factor @@ -8,24 +8,24 @@ ! variable to point to your executable, ! if not on the path. ! -USING: io.launcher kernel namespaces math math.parser -editors ; +USING: io.files io.launcher kernel namespaces math +math.parser editors sequences windows.shell32 ; IN: editors.scite -SYMBOL: scite-path - -"scite" scite-path set-global +: scite-path ( -- path ) + \ scite-path get-global [ + program-files "wscite\\SciTE.exe" path+ + ] unless* ; : scite-command ( file line -- cmd ) swap - [ scite-path get % - " \"" % - % - "\" -goto:" % - # - ] "" make ; + [ + scite-path , + , + "-goto:" swap number>string append , + ] { } make ; : scite-location ( file line -- ) - scite-command run-detached ; + scite-command run-detached drop ; [ scite-location ] edit-hook set-global diff --git a/extra/editors/ted-notepad/ted-notepad.factor b/extra/editors/ted-notepad/ted-notepad.factor old mode 100644 new mode 100755 index b56ee0a08b..5d58e182a3 --- a/extra/editors/ted-notepad/ted-notepad.factor +++ b/extra/editors/ted-notepad/ted-notepad.factor @@ -9,8 +9,7 @@ IN: editors.ted-notepad : ted-notepad ( file line -- ) [ - ted-notepad-path % " /l" % # - " " % % - ] "" make run-detached ; + ted-notepad-path , "/l" swap number>string append , , + ] { } make run-detached drop ; [ ted-notepad ] edit-hook set-global diff --git a/extra/editors/textmate/textmate.factor b/extra/editors/textmate/textmate.factor old mode 100644 new mode 100755 index 18c7dbd07e..0145ccae81 --- a/extra/editors/textmate/textmate.factor +++ b/extra/editors/textmate/textmate.factor @@ -4,6 +4,7 @@ namespaces prettyprint editors ; IN: editors.textmate : textmate-location ( file line -- ) - [ "mate -a -l " % # " " % unparse % ] "" make run-process ; + [ "mate" , "-a" , "-l" , number>string , , ] { } make + run-process drop ; [ textmate-location ] edit-hook set-global diff --git a/extra/editors/ultraedit/ultraedit.factor b/extra/editors/ultraedit/ultraedit.factor old mode 100644 new mode 100755 index 50c241daea..f9d27174b3 --- a/extra/editors/ultraedit/ultraedit.factor +++ b/extra/editors/ultraedit/ultraedit.factor @@ -10,8 +10,8 @@ IN: editors.ultraedit : ultraedit ( file line -- ) [ - ultraedit-path % " " % swap % "/" % # "/1" % - ] "" make run-detached ; + ultraedit-path , [ swap % "/" % # "/1" % ] "" make , + ] { } make run-detached drop ; [ ultraedit ] edit-hook set-global diff --git a/extra/editors/vim/vim.factor b/extra/editors/vim/vim.factor old mode 100644 new mode 100755 index 040e3fb4b4..8d60942d67 --- a/extra/editors/vim/vim.factor +++ b/extra/editors/vim/vim.factor @@ -10,13 +10,15 @@ HOOK: vim-command vim-editor TUPLE: vim ; -M: vim vim-command ( file line -- string ) - [ "\"" % vim-path get % "\" \"" % swap % "\" +" % # ] "" make ; +M: vim vim-command ( file line -- array ) + [ + vim-path get , swap , "+" swap number>string append , + ] { } make ; : vim-location ( file line -- ) vim-command vim-detach get-global - [ run-detached ] [ run-process ] if ; + [ run-detached ] [ run-process ] if drop ; "vim" vim-path set-global [ vim-location ] edit-hook set-global diff --git a/extra/editors/wordpad/wordpad.factor b/extra/editors/wordpad/wordpad.factor old mode 100644 new mode 100755 index eb882a9e38..0a86250a92 --- a/extra/editors/wordpad/wordpad.factor +++ b/extra/editors/wordpad/wordpad.factor @@ -8,8 +8,6 @@ IN: editors.wordpad ] unless* ; : wordpad ( file line -- ) - [ - wordpad-path % drop " " % "\"" % % "\"" % - ] "" make run-detached ; + drop wordpad-path swap 2array run-detached drop ; [ wordpad ] edit-hook set-global diff --git a/extra/factory/commands/authors.txt b/extra/factory/commands/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/factory/commands/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/factory/load/authors.txt b/extra/factory/load/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/factory/load/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/faq/authors.txt b/extra/faq/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/faq/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/faq/summary.txt b/extra/faq/summary.txt new file mode 100755 index 0000000000..c33f8cffeb --- /dev/null +++ b/extra/faq/summary.txt @@ -0,0 +1 @@ +The Factor FAQ diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index fdeed339d8..6beb48e05e 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg strings promises sequences math math.parser namespaces words quotations arrays hashtables io - io.streams.string assocs memoize ; + io.streams.string assocs memoize ascii ; IN: fjsc TUPLE: ast-number value ; diff --git a/extra/furnace/sessions/authors.txt b/extra/furnace/sessions/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/furnace/sessions/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/furnace/summary.txt b/extra/furnace/summary.txt new file mode 100755 index 0000000000..5696506f79 --- /dev/null +++ b/extra/furnace/summary.txt @@ -0,0 +1 @@ +Action-based web framework diff --git a/extra/furnace/validator/authors.txt b/extra/furnace/validator/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/furnace/validator/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/generic/lib/authors.txt b/extra/generic/lib/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/generic/lib/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/geom/dim/authors.txt b/extra/geom/dim/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/geom/dim/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/geom/pos/authors.txt b/extra/geom/pos/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/geom/pos/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/geom/rect/authors.txt b/extra/geom/rect/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/geom/rect/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/globs/globs.factor b/extra/globs/globs.factor index 901191b51e..7204693016 100755 --- a/extra/globs/globs.factor +++ b/extra/globs/globs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser-combinators regexp lazy-lists sequences kernel -promises strings ; +promises strings unicode.case ; IN: globs - { 600 600 } over set-slate-dim - "Golden Section" open-window -] with-ui ; + [ + [ display ] + { 600 600 } over set-slate-dim + "Golden Section" open-window + ] with-ui ; -MAIN: golden-section-window \ No newline at end of file +MAIN: golden-section-window diff --git a/extra/graphics/bitmap/authors.txt b/extra/graphics/bitmap/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/graphics/bitmap/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/graphics/viewer/authors.txt b/extra/graphics/viewer/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/graphics/viewer/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/hardware-info/backend/authors.txt b/extra/hardware-info/backend/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/hardware-info/backend/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor index d79678de0c..17794c196d 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/hardware-info/backend/backend.factor @@ -11,4 +11,3 @@ HOOK: available-page-file os ( -- n ) HOOK: total-virtual-mem os ( -- n ) HOOK: available-virtual-mem os ( -- n ) HOOK: available-virtual-extended-mem os ( -- n ) - diff --git a/extra/hardware-info/linux/authors.txt b/extra/hardware-info/linux/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/hardware-info/linux/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/hardware-info/macosx/authors.txt b/extra/hardware-info/macosx/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/hardware-info/macosx/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/hardware-info/windows/authors.txt b/extra/hardware-info/windows/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/hardware-info/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/hardware-info/windows/backend/backend.factor b/extra/hardware-info/windows/backend/backend.factor new file mode 100644 index 0000000000..516603c441 --- /dev/null +++ b/extra/hardware-info/windows/backend/backend.factor @@ -0,0 +1,6 @@ +IN: hardware-info.windows.backend + +TUPLE: wince ; +TUPLE: winnt ; +UNION: windows wince winnt ; + diff --git a/extra/hardware-info/windows/ce/authors.txt b/extra/hardware-info/windows/ce/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/hardware-info/windows/ce/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor old mode 100644 new mode 100755 index 9fb15ef823..1592bad14c --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -1,8 +1,8 @@ -USING: alien.c-types hardware-info hardware-info.windows -kernel math namespaces windows windows.kernel32 -hardware-info.backend ; +USING: alien.c-types hardware-info kernel math namespaces +windows windows.kernel32 hardware-info.backend ; IN: hardware-info.windows.ce +TUPLE: wince ; T{ wince } os set-global : memory-status ( -- MEMORYSTATUS ) @@ -10,6 +10,8 @@ T{ wince } os set-global "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength [ GlobalMemoryStatus ] keep ; +M: wince cpus ( -- n ) 1 ; + M: wince memory-load ( -- n ) memory-status MEMORYSTATUS-dwMemoryLoad ; diff --git a/extra/hardware-info/windows/nt/authors.txt b/extra/hardware-info/windows/nt/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/hardware-info/windows/nt/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor old mode 100644 new mode 100755 index f412754cdf..827b32c2f2 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,10 +1,18 @@ -USING: alien alien.c-types hardware-info hardware-info.windows +USING: alien alien.c-types hardware-info.windows.backend kernel libc math namespaces hardware-info.backend windows windows.advapi32 windows.kernel32 ; IN: hardware-info.windows.nt +TUPLE: winnt ; + T{ winnt } os set-global +: system-info ( -- SYSTEM_INFO ) + "SYSTEM_INFO" [ GetSystemInfo ] keep ; + +M: winnt cpus ( -- n ) + system-info SYSTEM_INFO-dwNumberOfProcessors ; + : memory-status ( -- MEMORYSTATUSEX ) "MEMORYSTATUSEX" "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index a49e4f254a..67d13fc50f 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,22 +1,15 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 +hardware-info.windows.backend words combinators vocabs.loader hardware-info.backend ; IN: hardware-info.windows -TUPLE: wince ; -TUPLE: winnt ; -UNION: windows wince winnt ; -USE: system - : system-info ( -- SYSTEM_INFO ) "SYSTEM_INFO" [ GetSystemInfo ] keep ; : page-size ( -- n ) system-info SYSTEM_INFO-dwPageSize ; -M: windows cpus ( -- n ) - system-info SYSTEM_INFO-dwNumberOfProcessors ; - ! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664) : processor-type ( -- n ) system-info SYSTEM_INFO-dwProcessorType ; @@ -70,8 +63,7 @@ M: windows cpus ( -- n ) : system-windows-directory ( -- str ) \ GetSystemWindowsDirectory get-directory ; -<< { +{ { [ wince? ] [ "hardware-info.windows.ce" ] } { [ winnt? ] [ "hardware-info.windows.nt" ] } - { [ t ] [ f ] } -} cond [ require ] when* >> +} cond [ require ] when* diff --git a/extra/help/cookbook/authors.txt b/extra/help/cookbook/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/help/cookbook/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index fdfc6b6604..234e7891d7 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -110,15 +110,21 @@ USE: io.buffers ARTICLE: "collections" "Collections" { $heading "Sequences" } { $subsection "sequences" } -"Sequence implementations:" +"Fixed-length sequences:" { $subsection "arrays" } -{ $subsection "vectors" } +{ $subsection "quotations" } +"Fixed-length specialized sequences:" +{ $subsection "strings" } { $subsection "bit-arrays" } { $subsection "byte-arrays" } { $subsection "float-arrays" } -{ $subsection "strings" } +"Resizable sequence:" +{ $subsection "vectors" } +"Resizable specialized sequences:" { $subsection "sbufs" } -{ $subsection "quotations" } +{ $subsection "bit-vectors" } +{ $subsection "byte-vectors" } +{ $subsection "float-vectors" } { $heading "Associative mappings" } { $subsection "assocs" } { $subsection "namespaces" } @@ -131,22 +137,25 @@ ARTICLE: "collections" "Collections" { $subsection "graphs" } { $subsection "buffers" } ; -USING: io.sockets io.launcher io.mmap ; +USING: io.sockets io.launcher io.mmap io.monitor ; ARTICLE: "io" "Input and output" { $subsection "streams" } -"Stream implementations:" +"External streams:" { $subsection "file-streams" } +{ $subsection "network-streams" } +"Wrapper streams:" { $subsection "io.streams.duplex" } { $subsection "io.streams.lines" } { $subsection "io.streams.plain" } { $subsection "io.streams.string" } -"Advanced features:" +"Stream utilities:" { $subsection "stream-binary" } { $subsection "styles" } -{ $subsection "network-streams" } +"Advanced features:" { $subsection "io.launcher" } -{ $subsection "io.mmap" } ; +{ $subsection "io.mmap" } +{ $subsection "io.monitor" } ; ARTICLE: "tools" "Developer tools" { $subsection "tools.annotations" } diff --git a/extra/help/tutorial/authors.txt b/extra/help/tutorial/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/help/tutorial/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor old mode 100644 new mode 100755 index a4d5e36b06..f6b1faf385 --- a/extra/help/tutorial/tutorial.factor +++ b/extra/help/tutorial/tutorial.factor @@ -1,6 +1,7 @@ USING: help.markup help.syntax ui.commands ui.operations ui.tools.search ui.tools.workspace editors vocabs.loader -kernel sequences prettyprint tools.test strings ; +kernel sequences prettyprint tools.test strings +unicode.categories unicode.case ; IN: help.tutorial ARTICLE: "first-program-start" "Creating a vocabulary for your first program" @@ -23,7 +24,7 @@ $nl $nl "Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:" { $code "IN: palindrome" } -"You are now ready to go onto the nex section." ; +"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ; ARTICLE: "first-program-logic" "Writing some logic in your first program" "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:" @@ -56,7 +57,7 @@ $nl { $code "\\ = see" } "It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path." -"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors." ; +"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ; ARTICLE: "first-program-test" "Testing your first program" "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:" @@ -92,7 +93,7 @@ $nl } "Now, you can run unit tests:" { $code "\"palindrome\" test" } -"It should report that all tests have passed." ; +"It should report that all tests have passed. Now you can read about " { $link "first-program-extend" } "." ; ARTICLE: "first-program-extend" "Extending your first program" "Our palindrome program works well, however we'd like to extend it to ignore spaces and non-alphabetical characters in the input." @@ -134,7 +135,7 @@ $nl { $code "[ Letter? ] subset >lower" } "This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":" { $code ": normalize ( str -- newstr ) [ Letter? ] subset >lower ;" } -"You will need to add " { $vocab-link "strings" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file." +"You will need to add " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file." $nl "We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:" { $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" } diff --git a/extra/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor index 57bbbe2481..4dcb55da32 100644 --- a/extra/hexdump/hexdump.factor +++ b/extra/hexdump/hexdump.factor @@ -1,4 +1,6 @@ -USING: arrays io io.streams.string kernel math math.parser namespaces prettyprint sequences splitting strings ; +USING: arrays combinators.lib io io.streams.string + kernel math math.parser namespaces prettyprint + sequences splitting strings ascii ; IN: hexdump hex write "h" write nl ; -: offset. ( lineno -- ) 16 * >hex 8 CHAR: 0 pad-left write "h: " write ; -: h-pad. ( digit -- ) >hex 2 CHAR: 0 pad-left write ; +: offset. ( lineno -- ) + 16 * >hex 8 CHAR: 0 pad-left write "h: " write ; + +: h-pad. ( digit -- ) + >hex 2 CHAR: 0 pad-left write ; + : line. ( str n -- ) offset. dup [ h-pad. " " write ] each - 16 over length - " " concat write + 16 over length - 3 * CHAR: \s write [ dup printable? [ drop CHAR: . ] unless write1 ] each nl ; @@ -19,9 +25,8 @@ PRIVATE> : hexdump ( seq -- str ) [ dup length header. - 16 dup length [ line. ] 2each + 16 [ line. ] each-index ] string-out ; : hexdump. ( seq -- ) hexdump write ; - diff --git a/extra/html/elements/authors.txt b/extra/html/elements/authors.txt new file mode 100755 index 0000000000..a8fb961d36 --- /dev/null +++ b/extra/html/elements/authors.txt @@ -0,0 +1,2 @@ +Chris Double +Slava Pestov diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index ff3e7b1283..101bc423b5 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io kernel namespaces prettyprint quotations -sequences strings words xml.writer compiler.units effects ; +sequences strings words xml.entities compiler.units effects ; IN: html.elements diff --git a/extra/html/html.factor b/extra/html/html.factor index f9d5bde5e6..0619937332 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic assocs help http io io.styles io.files +USING: generic assocs help http io io.styles io.files continuations io.streams.string kernel math math.parser namespaces quotations assocs sequences strings words html.elements -xml.writer sbufs ; +xml.entities sbufs continuations ; IN: html GENERIC: browser-link-href ( presented -- href ) @@ -105,7 +105,7 @@ TUPLE: html-sub-stream style stream ; TUPLE: html-span-stream ; -M: html-span-stream stream-close +M: html-span-stream dispose end-sub-stream not-a-div format-html-span ; : border-css, ( border -- ) @@ -138,7 +138,7 @@ M: html-span-stream stream-close TUPLE: html-block-stream ; -M: html-block-stream stream-close ( quot style stream -- ) +M: html-block-stream dispose ( quot style stream -- ) end-sub-stream a-div format-html-div ; : border-spacing-css, diff --git a/extra/html/parser/analyzer/authors.txt b/extra/html/parser/analyzer/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/html/parser/analyzer/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/html/parser/authors.txt b/extra/html/parser/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/html/parser/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/html/parser/printer/authors.txt b/extra/html/parser/printer/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/html/parser/printer/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/html/parser/utils/authors.txt b/extra/html/parser/utils/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/html/parser/utils/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor old mode 100644 new mode 100755 index 5c570993e6..d2fb719acd --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -7,3 +7,8 @@ USING: http.client tools.test ; [ 404 ] [ "404 File not found" parse-response ] unit-test [ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test [ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test + +[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test +[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test +[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test +[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor old mode 100644 new mode 100755 index 7c385c0bb3..dde2c7d205 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -44,14 +44,14 @@ DEFER: http-get-stream #! Should this support Location: headers that are #! relative URLs? pick 100 /i 3 = [ - stream-close "Location" swap at nip http-get-stream + dispose "Location" swap at nip http-get-stream ] when ; : http-get-stream ( url -- code headers stream ) #! Opens a stream for reading from an HTTP URL. parse-url over parse-host [ [ [ get-request read-response ] with-stream* ] keep - ] [ >r stream-close r> rethrow ] recover do-redirect ; + ] [ ] [ dispose ] cleanup do-redirect ; : http-get ( url -- code headers string ) #! Opens a stream for reading from an HTTP URL. @@ -59,9 +59,23 @@ DEFER: http-get-stream http-get-stream [ stdio get contents ] with-stream ] with-scope ; -: download ( url file -- ) +: download-name ( url -- name ) + file-name "?" split1 drop "/" ?tail drop ; + +: default-timeout 60 1000 * over set-timeout ; + +: success? ( code -- ? ) 200 = ; + +: download-to ( url file -- ) #! Downloads the contents of a URL to a file. - >r http-get 2nip r> [ write ] with-stream ; + >r http-get-stream nip default-timeout swap success? [ + r> stream-copy + ] [ + r> drop dispose "HTTP download failed" throw + ] if ; + +: download ( url -- ) + dup download-name download-to ; : post-request ( content-type content host resource -- ) #! Note: It is up to the caller to url encode the content if diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 853ac28f72..5146502644 100644 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -14,3 +14,5 @@ IN: temporary [ "hello world" ] [ "hello world%x" url-decode ] unit-test [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "%20%21%20" ] [ " ! " url-encode ] unit-test + +[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 9e5d34fa36..1bd9e18d98 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables io kernel math namespaces math.parser assocs -sequences strings splitting ; +sequences strings splitting ascii io.utf8 ; IN: http : header-line ( line -- ) @@ -20,18 +20,15 @@ IN: http dup letter? over LETTER? or over digit? or - swap "/_-?." member? or ; foldable + swap "/_-." member? or ; foldable + +: push-utf8 ( string -- ) + 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; : url-encode ( str -- str ) - [ - [ - dup url-quotable? [ - , - ] [ - CHAR: % , >hex 2 CHAR: 0 pad-left % - ] if - ] each - ] "" make ; + [ [ + dup url-quotable? [ , ] [ push-utf8 ] if + ] each ] "" make ; : url-decode-hex ( index str -- ) 2dup length 2 - >= [ @@ -58,7 +55,7 @@ IN: http ] if ; : url-decode ( str -- str ) - [ 0 swap url-decode-iter ] "" make ; + [ 0 swap url-decode-iter ] "" make decode-utf8 ; : hash>query ( hash -- str ) [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map diff --git a/extra/http/mime/authors.txt b/extra/http/mime/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/http/mime/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/http/server/authors.txt b/extra/http/server/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/http/server/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/http/server/responders/authors.txt b/extra/http/server/responders/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/http/server/responders/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 69f8b4e7fd..f5de4664a1 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -25,7 +25,7 @@ M: template-lexer skip-word { { [ 2dup nth CHAR: " = ] [ drop 1+ ] } { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] } - { [ t ] [ [ blank? ] skip ] } + { [ t ] [ f skip ] } } cond ] change-column ; diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 1d76bb0a5b..895efc59dc 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -4,7 +4,7 @@ USING: arrays combinators io io.binary io.files io.paths io.utf16 kernel math math.parser namespaces sequences -splitting strings assocs ; +splitting strings assocs unicode.categories ; IN: id3 diff --git a/extra/inverse/summary.txt b/extra/inverse/summary.txt new file mode 100755 index 0000000000..77e8f77495 --- /dev/null +++ b/extra/inverse/summary.txt @@ -0,0 +1 @@ +Invertible quotations diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor old mode 100644 new mode 100755 index b19918292e..6fcdc86423 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -1,9 +1,9 @@ IN: temporary -USING: alien io.buffers kernel kernel.private libc +USING: alien alien.c-types io.buffers kernel kernel.private libc sequences tools.test namespaces ; : buffer-set ( string buffer -- ) - 2dup buffer-ptr string>memory + 2dup buffer-ptr string>char-memory >r length r> buffer-reset ; : string>buffer ( string -- buffer ) diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor old mode 100644 new mode 100755 index 5d6eaebe6f..f26fe50d79 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2005 Mackenzie Straight. -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.buffers -USING: alien alien.syntax kernel kernel.private libc math -sequences strings hints ; +USING: alien alien.accessors alien.c-types alien.syntax kernel +kernel.private libc math sequences strings hints ; TUPLE: buffer size ptr fill pos ; @@ -39,14 +39,14 @@ TUPLE: buffer size ptr fill pos ; : (buffer>) ( n buffer -- string ) [ dup buffer-fill swap buffer-pos - min ] keep - buffer@ swap memory>string ; + buffer@ swap memory>char-string ; : buffer> ( n buffer -- string ) [ (buffer>) ] 2keep buffer-consume ; : (buffer>>) ( buffer -- string ) dup buffer-pos over buffer-ptr - over buffer-fill rot buffer-pos - memory>string ; + over buffer-fill rot buffer-pos - memory>char-string ; : buffer>> ( buffer -- string ) dup (buffer>>) 0 rot buffer-reset ; @@ -87,7 +87,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; : >buffer ( string buffer -- ) over length over check-overflow - [ buffer-end string>memory ] 2keep + [ buffer-end string>char-memory ] 2keep [ buffer-fill swap length + ] keep set-buffer-fill ; : ch>buffer ( ch buffer -- ) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 99f318eaf4..072cfcf959 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax quotations kernel ; +USING: help.markup help.syntax quotations kernel io math ; IN: io.launcher HELP: +command+ @@ -31,6 +31,36 @@ HELP: +environment-mode+ "Default value is " { $link append-environment } "." } ; +HELP: +stdin+ +{ $description "Launch descriptor key. Must equal one of the following:" + { $list + { { $link f } " - standard input is inherited" } + { { $link +closed+ } " - standard input is closed" } + { "a path name - standard input is read from the given file, which must exist" } + } +} ; + +HELP: +stdout+ +{ $description "Launch descriptor key. Must equal one of the following:" + { $list + { { $link f } " - standard output is inherited" } + { { $link +closed+ } " - standard output is closed" } + { "a path name - standard output is written to the given file, which is overwritten if it already exists" } + } +} ; + +HELP: +stderr+ +{ $description "Launch descriptor key. Must equal one of the following:" + { $list + { { $link f } " - standard error is inherited" } + { { $link +closed+ } " - standard error is closed" } + { "a path name - standard error is written to the given file, which is overwritten if it already exists" } + } +} ; + +HELP: +closed+ +{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; + HELP: prepend-environment { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence." $nl @@ -58,12 +88,12 @@ HELP: get-environment { $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ; HELP: run-process* -{ $values { "desc" "a launch descriptor" } } +{ $values { "desc" "a launch descriptor" } { "handle" "a process handle" } } { $contract "Launches a process using the launch descriptor." } { $notes "User code should call " { $link run-process } " instead." } ; HELP: >descriptor -{ $values { "obj" object } { "desc" "a launch descriptor" } } +{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } } { $description "Creates a launch descriptor from an object, which must be one of the following:" { $list { "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" } @@ -73,22 +103,46 @@ HELP: >descriptor } ; HELP: run-process -{ $values { "obj" object } } -{ $contract "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } ; +{ $values { "desc" "a launch descriptor" } { "process" process } } +{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } +{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; HELP: run-detached -{ $values { "obj" object } } +{ $values { "desc" "a launch descriptor" } { "process" process } } { $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } { $notes "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set." + $nl + "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; +HELP: process +{ $class-description "A class representing an active or finished process." +$nl +"Processes are output by " { $link run-process } " and " { $link run-detached } ", and are stored in the " { $link process-stream-process } " slot of " { $link process-stream } " instances." +$nl +"Processes can be passed to " { $link wait-for-process } "." } ; + +HELP: process-stream +{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ; + HELP: -{ $values { "obj" object } { "stream" "a bidirectional stream" } } -{ $description "Launches a process and redirects its input and output via a paper of pipes which may be read and written as a stream." } +{ $values + { "desc" "a launch descriptor" } + { "stream" "a bidirectional stream" } } +{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." } { $notes "Closing the stream will block until the process exits." } ; -{ run-process run-detached } related-words +HELP: with-process-stream +{ $values + { "desc" "a launch descriptor" } + { "quot" quotation } + { "process" process } } +{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ; + +HELP: wait-for-process +{ $values { "process" process } { "status" integer } } +{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ; ARTICLE: "io.launcher" "Launching OS processes" "The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching." @@ -105,9 +159,19 @@ $nl { $subsection +detached+ } { $subsection +environment+ } { $subsection +environment-mode+ } +"Redirecting standard input and output to files:" +{ $subsection +stdin+ } +{ $subsection +stdout+ } +{ $subsection +stderr+ } "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } -{ $subsection } ; +"Redirecting standard input and output to a pipe:" +{ $subsection } +{ $subsection with-process-stream } +"A class representing an active or finished process:" +{ $subsection process } +"Waiting for a process to end, or getting the exit code of a finished process:" +{ $subsection wait-for-process } ; ABOUT: "io.launcher" diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 806b56a092..9fb24fb51a 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -1,14 +1,39 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend system kernel namespaces strings hashtables -sequences assocs combinators vocabs.loader ; +USING: io io.backend system kernel namespaces strings hashtables +sequences assocs combinators vocabs.loader init threads +continuations ; IN: io.launcher +! Non-blocking process exit notification facility +SYMBOL: processes + +[ H{ } clone processes set-global ] "io.launcher" add-init-hook + +TUPLE: process handle status ; + +HOOK: register-process io-backend ( process -- ) + +M: object register-process drop ; + +: ( handle -- process ) + f process construct-boa + V{ } clone over processes get set-at + dup register-process ; + +M: process equal? 2drop f ; + +M: process hashcode* process-handle hashcode* ; + SYMBOL: +command+ SYMBOL: +arguments+ SYMBOL: +detached+ SYMBOL: +environment+ SYMBOL: +environment-mode+ +SYMBOL: +stdin+ +SYMBOL: +stdout+ +SYMBOL: +stderr+ +SYMBOL: +closed+ SYMBOL: prepend-environment SYMBOL: replace-environment @@ -38,21 +63,42 @@ SYMBOL: append-environment { replace-environment [ ] } } case ; -GENERIC: >descriptor ( obj -- desc ) +GENERIC: >descriptor ( desc -- desc ) M: string >descriptor +command+ associate ; M: sequence >descriptor +arguments+ associate ; -M: assoc >descriptor ; +M: assoc >descriptor >hashtable ; -HOOK: run-process* io-backend ( desc -- ) +HOOK: run-process* io-backend ( desc -- handle ) -: run-process ( obj -- ) - >descriptor run-process* ; +: wait-for-process ( process -- status ) + dup process-handle [ + dup [ processes get at push stop ] curry callcc0 + ] when process-status ; -: run-detached ( obj -- ) - >descriptor H{ { +detached+ t } } union run-process* ; +: run-process ( desc -- process ) + >descriptor + dup run-process* + +detached+ rot at [ dup wait-for-process drop ] unless ; -HOOK: process-stream* io-backend ( desc -- stream ) +: run-detached ( desc -- process ) + >descriptor H{ { +detached+ t } } union run-process ; -: ( obj -- stream ) - >descriptor process-stream* ; +HOOK: process-stream* io-backend ( desc -- stream process ) + +TUPLE: process-stream process ; + +: ( desc -- stream ) + >descriptor process-stream* + { set-delegate set-process-stream-process } + process-stream construct ; + +: with-process-stream ( desc quot -- process ) + swap + [ swap with-stream ] keep + process-stream-process ; inline + +: notify-exit ( status process -- ) + [ set-process-status ] keep + [ processes get delete-at* drop [ schedule-thread ] each ] keep + f swap set-process-handle ; diff --git a/extra/io/mmap/authors.txt b/extra/io/mmap/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/io/mmap/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/io/mmap/mmap-docs.factor b/extra/io/mmap/mmap-docs.factor old mode 100644 new mode 100755 index 22e403ed31..cb51088e58 --- a/extra/io/mmap/mmap-docs.factor +++ b/extra/io/mmap/mmap-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax alien math ; +USING: help.markup help.syntax alien math continuations ; IN: io.mmap HELP: mapped-file @@ -15,21 +15,17 @@ HELP: { $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." } { $errors "Throws an error if a memory mapping could not be established." } ; -HELP: (close-mapped-file) -{ $values { "mmap" mapped-file } } -{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link close-mapped-file } " instead." } -{ $errors "Throws an error if a memory mapping could not be established." } ; - HELP: close-mapped-file { $values { "mmap" mapped-file } } -{ $description "Releases system resources associated with the mapped file." } +{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." } { $errors "Throws an error if a memory mapping could not be established." } ; ARTICLE: "io.mmap" "Memory-mapped files" "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files." { $subsection } -{ $subsection close-mapped-file } -"A combinator which wraps the above two words:" +"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." +$nl +"A utility combinator which wraps the above:" { $subsection with-mapped-file } "Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:" { $subsection mapped-file-address } diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index 26378a06aa..59246115cf 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations io.backend kernel quotations sequences -system alien sequences.private ; +system alien alien.accessors sequences.private ; IN: io.mmap TUPLE: mapped-file length address handle closed? ; @@ -23,14 +23,12 @@ INSTANCE: mapped-file sequence HOOK: io-backend ( path length -- mmap ) -HOOK: (close-mapped-file) io-backend ( mmap -- ) +HOOK: close-mapped-file io-backend ( mmap -- ) -: close-mapped-file ( mmap -- ) +M: mapped-file dispose ( mmap -- ) check-closed t over set-mapped-file-closed? - (close-mapped-file) ; + close-mapped-file ; : with-mapped-file ( path length quot -- ) - >r r> - [ keep ] curry - [ close-mapped-file ] [ ] cleanup ; inline + >r r> with-disposal ; inline diff --git a/extra/io/mmap/summary.txt b/extra/io/mmap/summary.txt new file mode 100755 index 0000000000..07d36c45be --- /dev/null +++ b/extra/io/mmap/summary.txt @@ -0,0 +1 @@ +Memory-mapped files diff --git a/extra/io/monitor/authors.txt b/extra/io/monitor/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/monitor/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/monitor/monitor-docs.factor b/extra/io/monitor/monitor-docs.factor new file mode 100755 index 0000000000..de649f48e7 --- /dev/null +++ b/extra/io/monitor/monitor-docs.factor @@ -0,0 +1,58 @@ +IN: io.monitor +USING: help.markup help.syntax continuations ; + +HELP: +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } } +{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." +$nl +"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ; + +HELP: next-change +{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a change descriptor" } } +{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitor.descriptors" } "." } ; + +HELP: with-monitor +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } +{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ; + +HELP: +add-file+ +{ $description "Indicates that the file has been added to the directory." } ; + +HELP: +remove-file+ +{ $description "Indicates that the file has been removed from the directory." } ; + +HELP: +modify-file+ +{ $description "Indicates that the file contents have changed." } ; + +HELP: +rename-file+ +{ $description "Indicates that file has been renamed." } ; + +ARTICLE: "io.monitor.descriptors" "File system change descriptors" +"Change descriptors output by " { $link next-change } ":" +{ $subsection +add-file+ } +{ $subsection +remove-file+ } +{ $subsection +modify-file+ } +{ $subsection +rename-file+ } +{ $subsection +add-file+ } ; + +ARTICLE: "io.monitor" "File system change monitors" +"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." +$nl +"Creating a file system change monitor and listening for changes:" +{ $subsection } +{ $subsection next-change } +{ $subsection "io.monitor.descriptors" } +"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "." +$nl +"A utility combinator which opens a monitor and cleans it up after:" +{ $subsection with-monitor } +"An example which watches the Factor directory for changes:" +{ $code + "USE: io.monitor" + ": watch-loop ( monitor -- )" + " dup next-change . . nl nl flush watch-loop ;" + "" + "\"\" resource-path f [ watch-loop ] with-monitor" +} ; + +ABOUT: "io.monitor" diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitor/monitor.factor new file mode 100755 index 0000000000..4dc5081513 --- /dev/null +++ b/extra/io/monitor/monitor.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.backend kernel continuations ; +IN: io.monitor + +HOOK: io-backend ( path recursive? -- monitor ) + +HOOK: next-change io-backend ( monitor -- path changes ) + +SYMBOL: +add-file+ +SYMBOL: +remove-file+ +SYMBOL: +modify-file+ +SYMBOL: +rename-file+ + +: with-monitor ( path recursive? quot -- ) + >r r> with-disposal ; inline diff --git a/extra/io/monitor/summary.txt b/extra/io/monitor/summary.txt new file mode 100755 index 0000000000..96d49e5ec8 --- /dev/null +++ b/extra/io/monitor/summary.txt @@ -0,0 +1 @@ +File alteration monitoring diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor old mode 100644 new mode 100755 index 049c3bf497..af73a47030 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/nonblocking/nonblocking-docs.factor @@ -1,5 +1,5 @@ USING: io io.buffers io.backend help.markup help.syntax kernel -strings sbufs ; +strings sbufs words continuations ; IN: io.nonblocking ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" @@ -23,7 +23,7 @@ $nl "Per-port native I/O protocol:" { $subsection init-handle } { $subsection (wait-to-read) } -"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link stream-close } " generic words." +"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words." $nl "Dummy ports which should be used to implement networking:" { $subsection server-port } @@ -40,7 +40,7 @@ $nl { { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" } { { $link port-timeout } " - a timeout, specifying the maximum length of time, in milliseconds, for which input operations can block before throwing an error. A value of 0 denotes no timeout is desired." } { { $link port-cutoff } " - the time when the current timeout expires; if no input data arrives before this time, an error is thrown" } - { { $link port-type } " - a symbol identifying the port's intended purpose. Can be " { $link input } ", " { $link output } ", " { $link closed } ", or any other symbol" } + { { $link port-type } " - a symbol identifying the port's intended purpose" } { { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" } } } ; @@ -55,7 +55,7 @@ HELP: init-handle { $contract "Prepares a native handle for use by the port; called by " { $link } "." } ; HELP: -{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "port" "a new " { $link port } } } +{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } } { $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." } $low-level-note ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 9ff21aa011..5dbd3d1490 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -1,63 +1,97 @@ -! Copyright (C) 2005, 2007 Slava Pestov, Doug Coleman +! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking -USING: math kernel io sequences io.buffers generic sbufs -system io.streams.lines io.streams.plain io.streams.duplex -continuations debugger classes byte-arrays namespaces -splitting ; +USING: math kernel io sequences io.buffers generic sbufs system +io.streams.lines io.streams.plain io.streams.duplex io.backend +continuations debugger classes byte-arrays namespaces splitting +dlists assocs ; SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global ! Common delegate of native stream readers and writers -TUPLE: port handle error timeout cutoff type eof? ; +TUPLE: port +handle +error +timeout-entry timeout cutoff +type eof? ; -SYMBOL: input -SYMBOL: output SYMBOL: closed -PREDICATE: port input-port port-type input eq? ; -PREDICATE: port output-port port-type output eq? ; +PREDICATE: port input-port port-type input-port eq? ; +PREDICATE: port output-port port-type output-port eq? ; GENERIC: init-handle ( handle -- ) GENERIC: close-handle ( handle -- ) -: ( handle buffer -- port ) - over init-handle +: ( handle buffer type -- port ) + pick init-handle 0 0 { set-port-handle set-delegate + set-port-type set-port-timeout set-port-cutoff } port construct ; -: ( handle -- port ) - default-buffer-size get ; +: ( handle type -- port ) + default-buffer-size get swap ; : ( handle -- stream ) - input over set-port-type ; + input-port ; : ( handle -- stream ) - output over set-port-type ; + output-port ; : handle>duplex-stream ( in-handle out-handle -- stream ) - [ >r r> ] - [ ] [ stream-close ] + [ >r r> ] [ ] [ dispose ] cleanup ; -: touch-port ( port -- ) - dup port-timeout dup zero? - [ 2drop ] [ millis + swap set-port-cutoff ] if ; - : timeout? ( port -- ? ) port-cutoff dup zero? not swap millis < and ; : pending-error ( port -- ) dup port-error f rot set-port-error [ throw ] when* ; -M: port set-timeout - [ set-port-timeout ] keep touch-port ; +SYMBOL: timeout-queue + +timeout-queue global [ [ ] unless* ] change-at + +: unqueue-timeout ( port -- ) + port-timeout-entry [ + timeout-queue get-global swap delete-node + ] when* ; + +: queue-timeout ( port -- ) + dup timeout-queue get-global push-front* + swap set-port-timeout-entry ; + +HOOK: cancel-io io-backend ( port -- ) + +M: object cancel-io drop ; + +: expire-timeouts ( -- ) + timeout-queue get-global dup dlist-empty? [ drop ] [ + dup peek-back timeout? + [ pop-back cancel-io expire-timeouts ] [ drop ] if + ] if ; + +: begin-timeout ( port -- ) + dup port-timeout dup zero? [ + 2drop + ] [ + millis + over set-port-cutoff + dup unqueue-timeout queue-timeout + ] if ; + +: end-timeout ( port -- ) + unqueue-timeout ; + +: with-port-timeout ( port quot -- ) + over begin-timeout keep end-timeout ; inline + +M: port set-timeout set-port-timeout ; GENERIC: (wait-to-read) ( port -- ) @@ -159,19 +193,23 @@ GENERIC: port-flush ( port -- ) M: output-port stream-flush ( port -- ) dup port-flush pending-error ; -M: port stream-close - dup port-type closed eq? [ - dup port-type >r closed over set-port-type r> - output eq? [ dup port-flush ] when - dup port-handle close-handle - dup delegate [ buffer-free ] when* - f over set-delegate - ] unless drop ; +: close-port ( port type -- ) + output-port eq? [ dup port-flush ] when + dup cancel-io + dup port-handle close-handle + dup delegate [ buffer-free ] when* + f swap set-delegate ; + +M: port dispose + dup port-type closed eq? + [ drop ] + [ dup port-type >r closed over set-port-type r> close-port ] + if ; TUPLE: server-port addr client ; -: ( port addr -- server ) - server-port pick set-port-type +: ( handle addr -- server ) + >r f server-port r> { set-delegate set-server-port-addr } server-port construct ; @@ -180,8 +218,8 @@ TUPLE: server-port addr client ; TUPLE: datagram-port addr packet packet-addr ; -: ( port addr -- datagram ) - datagram-port pick set-port-type +: ( handle addr -- datagram ) + >r f datagram-port r> { set-delegate set-datagram-port-addr } datagram-port construct ; diff --git a/extra/io/paths/authors.txt b/extra/io/paths/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/io/paths/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/io/server/authors.txt b/extra/io/server/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/server/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 0141289c38..408fd29714 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -29,8 +29,7 @@ SYMBOL: log-stream : with-log-file ( file quot -- ) >r r> - [ [ with-log-stream ] 2keep ] - [ drop stream-close ] [ ] cleanup ; inline + [ with-log-stream ] curry with-disposal ; inline : with-log-stdio ( quot -- ) stdio get swap with-log-stream ; @@ -48,11 +47,11 @@ SYMBOL: log-stream dup log-client [ swap with-stream ] 2curry concurrency:spawn drop ; inline -: accept-loop ( server quot -- server quot ) +: accept-loop ( server quot -- ) [ swap accept with-client ] 2keep accept-loop ; inline : server-loop ( server quot -- ) - [ accept-loop ] [ drop stream-close ] [ ] cleanup ; inline + [ accept-loop ] curry with-disposal ; inline : spawn-server ( addrspec quot -- ) "Waiting for connections on " pick unparse append @@ -87,8 +86,7 @@ SYMBOL: log-stream : spawn-datagrams ( quot addrspec -- ) "Waiting for datagrams on " over unparse append log-message - [ datagram-loop ] [ stream-close ] [ ] cleanup ; - inline + [ datagram-loop ] with-disposal ; inline : with-datagrams ( seq service quot -- ) [ diff --git a/extra/io/sniffer/authors.txt b/extra/io/sniffer/authors.txt new file mode 100755 index 0000000000..7a1ef51c6f --- /dev/null +++ b/extra/io/sniffer/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Elie Chaftari diff --git a/extra/io/sniffer/backend/authors.txt b/extra/io/sniffer/backend/authors.txt new file mode 100755 index 0000000000..7a1ef51c6f --- /dev/null +++ b/extra/io/sniffer/backend/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Elie Chaftari diff --git a/extra/io/sniffer/bsd/authors.txt b/extra/io/sniffer/bsd/authors.txt new file mode 100755 index 0000000000..7a1ef51c6f --- /dev/null +++ b/extra/io/sniffer/bsd/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Elie Chaftari diff --git a/extra/io/sniffer/bsd/bsd.factor b/extra/io/sniffer/bsd/bsd.factor index 5c32bd78d2..66336425a1 100644 --- a/extra/io/sniffer/bsd/bsd.factor +++ b/extra/io/sniffer/bsd/bsd.factor @@ -7,7 +7,7 @@ sequences io.sniffer.backend ; QUALIFIED: unix IN: io.sniffer.bsd -M: unix-io destruct-handle ( obj -- ) close drop ; +M: unix-io destruct-handle ( obj -- ) unix:close drop ; C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ; C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ; @@ -83,7 +83,7 @@ M: unix-io ( obj -- sniffer ) ] keep dupd sniffer-spec-ifname ioctl-sniffer-fd dup make-ioctl-buffer - input over set-port-type + input-port \ sniffer construct-delegate ] with-destructors ; diff --git a/extra/io/sniffer/filter/authors.txt b/extra/io/sniffer/filter/authors.txt new file mode 100755 index 0000000000..7a1ef51c6f --- /dev/null +++ b/extra/io/sniffer/filter/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Elie Chaftari diff --git a/extra/io/sniffer/filter/backend/authors.txt b/extra/io/sniffer/filter/backend/authors.txt new file mode 100755 index 0000000000..7a1ef51c6f --- /dev/null +++ b/extra/io/sniffer/filter/backend/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Elie Chaftari diff --git a/extra/io/sniffer/filter/bsd/authors.txt b/extra/io/sniffer/filter/bsd/authors.txt new file mode 100755 index 0000000000..7a1ef51c6f --- /dev/null +++ b/extra/io/sniffer/filter/bsd/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Elie Chaftari diff --git a/extra/io/sockets/headers/authors.txt b/extra/io/sockets/headers/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/io/sockets/headers/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/io/sockets/headers/bsd/authors.txt b/extra/io/sockets/headers/bsd/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/io/sockets/headers/bsd/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/io/sockets/headers/bsd/bsd.factor b/extra/io/sockets/headers/bsd/bsd.factor old mode 100644 new mode 100755 index c67cc95b7d..06634c28c8 --- a/extra/io/sockets/headers/bsd/bsd.factor +++ b/extra/io/sockets/headers/bsd/bsd.factor @@ -13,7 +13,7 @@ C-STRUCT: bpfh : bpfh. ( bpfh -- ) [ bpfh-timestamp "Timestamp: " write - "timeval" heap-size memory>string >byte-array . + "timeval" heap-size memory>byte-array . ] keep [ bpfh-caplen "caplen: " write . ] keep [ bpfh-datalen "datalen: " write . ] keep diff --git a/extra/io/sockets/headers/headers.factor b/extra/io/sockets/headers/headers.factor old mode 100644 new mode 100755 index 3a46f295d5..2547fee5ae --- a/extra/io/sockets/headers/headers.factor +++ b/extra/io/sockets/headers/headers.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax byte-arrays io -io.sockets.impl kernel structs math prettyprint ; +io.sockets.impl kernel structs math math.parser +prettyprint sequences ; IN: io.sockets.headers C-STRUCT: etherneth @@ -9,6 +10,10 @@ C-STRUCT: etherneth { { "char" 6 } "smac" } { "ushort" "type" } ; +: >mac-address ( byte-array -- string ) + 6 memory>byte-array + [ >hex 2 48 pad-left ] { } map-as ":" join ; + : etherneth. ( etherneth -- ) [ etherneth-dmac "Dest MAC: " write >mac-address . ] keep [ etherneth-smac "Source MAC: " write >mac-address . ] keep diff --git a/extra/io/sockets/impl/authors.txt b/extra/io/sockets/impl/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/sockets/impl/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index e490b9312b..d7ac18ee20 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -32,7 +32,7 @@ GENERIC: inet-pton ( str addrspec -- data ) M: inet4 inet-ntop ( data addrspec -- str ) - drop 4 memory>string [ number>string ] { } map-as "." join ; + drop 4 memory>byte-array [ number>string ] { } map-as "." join ; M: inet4 inet-pton ( str addrspec -- data ) drop "." split [ string>number ] B{ } map-as ; @@ -51,13 +51,16 @@ M: inet4 make-sockaddr ( inet -- sockaddr ) "0.0.0.0" or rot inet-pton *uint over set-sockaddr-in-addr ; +SYMBOL: port-override + +: (port) port-override get [ ] [ ] ?if ; + M: inet4 parse-sockaddr >r dup sockaddr-in-addr r> inet-ntop - swap sockaddr-in-port ntohs ; - + swap sockaddr-in-port ntohs (port) ; M: inet6 inet-ntop ( data addrspec -- str ) - drop 16 memory>string 2 [ be> >hex ] map ":" join ; + drop 16 memory>byte-array 2 [ be> >hex ] map ":" join ; M: inet6 inet-pton ( str addrspec -- data ) drop "::" split1 @@ -80,7 +83,7 @@ M: inet6 make-sockaddr ( inet -- sockaddr ) M: inet6 parse-sockaddr >r dup sockaddr-in6-addr r> inet-ntop - swap sockaddr-in6-port ntohs ; + swap sockaddr-in6-port ntohs (port) ; : addrspec-of-family ( af -- addrspec ) { @@ -102,22 +105,30 @@ M: f parse-sockaddr nip ; [ dup addrinfo-next swap addrinfo>addrspec ] [ ] unfold nip [ ] subset ; +: prepare-resolve-host ( host serv passive? -- host' serv' flags ) + #! If the port is a number, we resolve for 'http' then + #! change it later. This is a workaround for a FreeBSD + #! getaddrinfo() limitation -- on Windows, Linux and Mac, + #! we can convert a number to a string and pass that as the + #! service name, but on FreeBSD this gives us an unknown + #! service error. + >r + dup integer? [ port-override set "http" ] when + r> AI_PASSIVE 0 ? ; + M: object resolve-host ( host serv passive? -- seq ) - >r dup integer? [ number>string ] when - "addrinfo" - r> [ AI_PASSIVE over set-addrinfo-flags ] when - PF_UNSPEC over set-addrinfo-family - IPPROTO_TCP over set-addrinfo-protocol - f [ getaddrinfo addrinfo-error ] keep *void* - [ parse-addrinfo-list ] keep - freeaddrinfo ; + [ + prepare-resolve-host + "addrinfo" + [ set-addrinfo-flags ] keep + PF_UNSPEC over set-addrinfo-family + IPPROTO_TCP over set-addrinfo-protocol + f [ getaddrinfo addrinfo-error ] keep *void* + [ parse-addrinfo-list ] keep + freeaddrinfo + ] with-scope ; M: object host-name ( -- name ) 256 dup dup length gethostname zero? [ "gethostname failed" throw ] unless alien>char-string ; - -: >mac-address ( byte-array -- string ) - 6 memory>string >byte-array - [ >hex 2 48 pad-left ] { } map-as ":" join ; - diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor old mode 100644 new mode 100755 index a5c623b6b7..9136c3ca22 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io io.backend threads -strings byte-arrays ; +strings byte-arrays continuations ; IN: io.sockets ARTICLE: "network-addressing" "Address specifiers" @@ -19,7 +19,7 @@ ARTICLE: "network-connection" "Connection-oriented networking" { $subsection accept } "The stream returned by " { $link accept } " holds the address specifier of the remote client:" { $subsection client-stream-addr } -"Server sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol." +"Server sockets are closed by calling " { $link dispose } "." $nl "Address specifiers have the following interpretation with connection-oriented networking words:" { $list @@ -36,7 +36,7 @@ ARTICLE: "network-packet" "Packet-oriented networking" "Packets can be sent and received with a pair of words:" { $subsection send } { $subsection receive } -"Packet-oriented sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol." +"Packet-oriented sockets are closed by calling " { $link dispose } "." $nl "Address specifiers have the following interpretation with connection-oriented networking words:" { $list @@ -104,7 +104,7 @@ HELP: { $description "Begins listening for network connections to a local address. Server objects responds to two words:" { $list - { { $link stream-close } " - stops listening on the port and frees all associated resources" } + { { $link dispose } " - stops listening on the port and frees all associated resources" } { { $link accept } " - blocks until there is a connection" } } } @@ -128,7 +128,7 @@ HELP: { $values { "addrspec" "an address specifier" } { "datagram" "a handle" } } { $description "Creates a datagram socket bound to a local address. Datagram socket objects responds to three words:" { $list - { { $link stream-close } " - stops listening on the port and frees all associated resources" } + { { $link dispose } " - stops listening on the port and frees all associated resources" } { { $link receive } " - waits for a packet" } { { $link send } " - sends a packet" } } diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor old mode 100644 new mode 100755 diff --git a/extra/io/streams/null/authors.txt b/extra/io/streams/null/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/streams/null/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor old mode 100644 new mode 100755 index 12a36091ce..f76b0cbce3 --- a/extra/io/streams/null/null.factor +++ b/extra/io/streams/null/null.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.null -USING: kernel io ; +USING: kernel io continuations ; TUPLE: null-stream ; -M: null-stream stream-close drop ; +M: null-stream dispose drop ; M: null-stream set-timeout 2drop ; M: null-stream stream-readln drop f ; M: null-stream stream-read1 drop f ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 3522a2218b..141b115ebe 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -1,22 +1,70 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien bit-arrays generic assocs io kernel -kernel.private math io.nonblocking sequences strings structs -sbufs threads unix vectors io.buffers io.backend -io.streams.duplex math.parser continuations system libc ; +USING: alien generic assocs kernel kernel.private math +io.nonblocking sequences strings structs sbufs threads unix +vectors io.buffers io.backend io.streams.duplex math.parser +continuations system libc qualified namespaces ; +QUALIFIED: io IN: io.unix.backend -TUPLE: unix-io ; +MIXIN: unix-io -! We want namespaces::bind to shadow the bind system call from -! unix -USING: namespaces ; +! I/O tasks +TUPLE: io-task port callbacks ; -! Global variables -SYMBOL: read-fdset -SYMBOL: read-tasks -SYMBOL: write-fdset -SYMBOL: write-tasks +: io-task-fd io-task-port port-handle ; + +: ( port continuation class -- task ) + >r 1vector io-task construct-boa r> construct-delegate ; + inline + +TUPLE: input-task ; + +: ( port continuation class -- task ) + >r input-task r> construct-delegate ; inline + +TUPLE: output-task ; + +: ( port continuation class -- task ) + >r output-task r> construct-delegate ; inline + +GENERIC: do-io-task ( task -- ? ) +GENERIC: io-task-container ( mx task -- hashtable ) + +! I/O multiplexers +TUPLE: mx fd reads writes ; + +M: input-task io-task-container drop mx-reads ; + +M: output-task io-task-container drop mx-writes ; + +: ( -- mx ) f H{ } clone H{ } clone mx construct-boa ; + +: construct-mx ( class -- obj ) swap construct-delegate ; + +GENERIC: register-io-task ( task mx -- ) +GENERIC: unregister-io-task ( task mx -- ) +GENERIC: wait-for-events ( ms mx -- ) + +: fd/container ( task mx -- task fd container ) + over io-task-container >r dup io-task-fd r> ; inline + +: check-io-task ( task mx -- ) + fd/container key? nip [ + "Cannot perform multiple reads from the same port" throw + ] when ; + +M: mx register-io-task ( task mx -- ) + 2dup check-io-task fd/container set-at ; + +: add-io-task ( task -- ) + mx get-global register-io-task stop ; + +: with-port-continuation ( port quot -- port ) + [ callcc0 ] curry with-port-timeout ; inline + +M: mx unregister-io-task ( task mx -- ) + fd/container delete-at drop ; ! Some general stuff : file-mode OCT: 0666 ; @@ -49,72 +97,15 @@ M: integer close-handle ( fd -- ) err_no dup ignorable-error? [ 2drop f ] [ strerror swap report-error t ] if ; -! Associates a port with a list of continuations waiting on the -! port to finish I/O -TUPLE: io-task port callbacks ; +: pop-callbacks ( mx task -- ) + dup rot unregister-io-task + io-task-callbacks [ schedule-thread ] each ; -: ( port class -- task ) - >r V{ } clone io-task construct-boa - { set-delegate } r> construct ; inline +: handle-io-task ( mx task -- ) + dup do-io-task [ pop-callbacks ] [ 2drop ] if ; -! Multiplexer -GENERIC: do-io-task ( task -- ? ) -GENERIC: task-container ( task -- vector ) - -: io-task-fd io-task-port port-handle ; - -: add-io-task ( callback task -- ) - [ io-task-callbacks push ] keep - dup io-task-fd over task-container 2dup at [ - "Cannot perform multiple reads from the same port" throw - ] when set-at ; - -: remove-io-task ( task -- ) - dup io-task-fd swap task-container delete-at ; - -: pop-callbacks ( task -- ) - dup io-task-callbacks swap remove-io-task - [ schedule-thread ] each ; - -: handle-fd ( task -- ) - dup io-task-port touch-port - dup do-io-task [ pop-callbacks ] [ drop ] if ; - -: handle-fdset ( fdset tasks -- ) - swap [ - swap dup io-task-port timeout? [ - dup io-task-port "Timeout" swap report-error - nip pop-callbacks - ] [ - tuck io-task-fd swap nth - [ handle-fd ] [ drop ] if - ] if drop - ] curry assoc-each ; - -: init-fdset ( fdset tasks -- ) - swap dup clear-bits - [ >r drop t swap r> set-nth ] curry assoc-each ; - -: read-fdset/tasks - read-fdset get-global read-tasks get-global ; - -: write-fdset/tasks - write-fdset get-global write-tasks get-global ; - -: init-fdsets ( -- read write except ) - read-fdset/tasks dupd init-fdset - write-fdset/tasks dupd init-fdset - f ; - -: (io-multiplex) ( ms -- ) - >r FD_SETSIZE init-fdsets r> make-timeval select 0 < [ - err_no ignorable-error? [ (io-error) ] unless - ] when ; - -M: unix-io io-multiplex ( ms -- ) - (io-multiplex) - read-fdset/tasks handle-fdset - write-fdset/tasks handle-fdset ; +: handle-timeout ( mx task -- ) + "Timeout" over io-task-port report-error pop-callbacks ; ! Readers : reader-eof ( reader -- ) @@ -137,16 +128,15 @@ M: unix-io io-multiplex ( ms -- ) TUPLE: read-task ; -: ( port -- task ) read-task ; +: ( port continuation -- task ) + read-task ; M: read-task do-io-task io-task-port dup refill [ [ reader-eof ] [ drop ] if ] keep ; -M: read-task task-container drop read-tasks get-global ; - M: input-port (wait-to-read) - [ swap add-io-task stop ] callcc0 + [ add-io-task ] with-port-continuation pending-error ; ! Writers @@ -156,35 +146,45 @@ M: input-port (wait-to-read) TUPLE: write-task ; -: ( port -- task ) write-task ; +: ( port continuation -- task ) + write-task ; M: write-task do-io-task io-task-port dup buffer-empty? over port-error or [ 0 swap buffer-reset t ] [ write-step ] if ; -M: write-task task-container drop write-tasks get-global ; - -: add-write-io-task ( callback task -- ) - dup io-task-fd write-tasks get-global at - [ io-task-callbacks push ] [ add-io-task ] ?if ; +: add-write-io-task ( port continuation -- ) + over port-handle mx get-global mx-writes at* + [ io-task-callbacks push stop ] + [ drop add-io-task ] if ; : (wait-to-write) ( port -- ) - [ swap add-write-io-task stop ] callcc0 drop ; + [ add-write-io-task ] with-port-continuation drop ; M: port port-flush ( port -- ) dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; -USE: io - -M: unix-io init-io ( -- ) - #! Should only be called on startup. Calling this at any - #! other time can have unintended consequences. - global [ - H{ } clone read-tasks set - FD_SETSIZE 8 * read-fdset set - H{ } clone write-tasks set - FD_SETSIZE 8 * write-fdset set - ] bind ; +M: unix-io io-multiplex ( ms -- ) + mx get-global wait-for-events ; M: unix-io init-stdio ( -- ) - 0 1 handle>duplex-stream stdio set-global ; + 0 1 handle>duplex-stream io:stdio set-global + 2 io:stderr set-global ; + +! mx io-task for embedding an fd-based mx inside another mx +TUPLE: mx-port mx ; + +: ( mx -- port ) + dup mx-fd f mx-port + { set-mx-port-mx set-delegate } mx-port construct ; + +TUPLE: mx-task ; + +: ( port -- task ) + f io-task construct-boa mx-task construct-delegate ; + +M: mx-task do-io-task + io-task-port mx-port-mx 0 swap wait-for-events f ; + +: multiplexer-error ( n -- ) + 0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ; diff --git a/extra/io/unix/bsd/authors.txt b/extra/io/unix/bsd/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/unix/bsd/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor new file mode 100755 index 0000000000..a4315ce5d0 --- /dev/null +++ b/extra/io/unix/bsd/bsd.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: io.unix.bsd +USING: io.backend io.unix.backend io.unix.kqueue io.unix.select +io.launcher io.unix.launcher namespaces kernel assocs threads +continuations ; + +! On *BSD and Mac OS X, we use select() for the top-level +! multiplexer, and we hang a kqueue off of it but file change +! notification and process exit notification. + +! kqueue is buggy with files and ptys so we can't use it as the +! main multiplexer. + +TUPLE: bsd-io ; + +INSTANCE: bsd-io unix-io + +M: bsd-io init-io ( -- ) + mx set-global + kqueue-mx set-global + kqueue-mx get-global dup io-task-fd + 2dup mx get-global mx-reads set-at + mx get-global mx-writes set-at ; + +M: bsd-io register-process ( process -- ) + process-handle kqueue-mx get-global add-pid-task ; + +T{ bsd-io } set-io-backend diff --git a/extra/io/unix/epoll/authors.txt b/extra/io/unix/epoll/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/unix/epoll/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor new file mode 100644 index 0000000000..1459549f9e --- /dev/null +++ b/extra/io/unix/epoll/epoll.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types kernel io.nonblocking io.unix.backend +bit-arrays sequences assocs unix unix.linux.epoll math +namespaces structs ; +IN: io.unix.epoll + +TUPLE: epoll-mx events ; + +: max-events ( -- n ) + #! We read up to 256 events at a time. This is an arbitrary + #! constant... + 256 ; inline + +: ( -- mx ) + epoll-mx construct-mx + max-events epoll_create dup io-error over set-mx-fd + max-events "epoll-event" over set-epoll-mx-events ; + +GENERIC: io-task-events ( task -- n ) + +M: input-task io-task-events drop EPOLLIN ; + +M: output-task io-task-events drop EPOLLOUT ; + +: make-event ( task -- event ) + "epoll-event" + over io-task-events over set-epoll-event-events + swap io-task-fd over set-epoll-event-fd ; + +: do-epoll-ctl ( task mx what -- ) + >r mx-fd r> rot dup io-task-fd swap make-event + epoll_ctl io-error ; + +M: epoll-mx register-io-task ( task mx -- ) + 2dup EPOLL_CTL_ADD do-epoll-ctl + delegate register-io-task ; + +M: epoll-mx unregister-io-task ( task mx -- ) + 2dup delegate unregister-io-task + EPOLL_CTL_DEL do-epoll-ctl ; + +: wait-event ( mx timeout -- n ) + >r { mx-fd epoll-mx-events } get-slots max-events + r> epoll_wait dup multiplexer-error ; + +: epoll-read-task ( mx fd -- ) + over mx-reads at* [ handle-io-task ] [ 2drop ] if ; + +: epoll-write-task ( mx fd -- ) + over mx-writes at* [ handle-io-task ] [ 2drop ] if ; + +: handle-event ( mx kevent -- ) + epoll-event-fd 2dup epoll-read-task epoll-write-task ; + +: handle-events ( mx n -- ) + [ + over epoll-mx-events epoll-event-nth handle-event + ] with each ; + +M: epoll-mx wait-for-events ( ms mx -- ) + dup rot wait-event handle-events ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index f9d642d661..b56e62d3c4 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -4,13 +4,15 @@ USING: io.backend io.nonblocking io.unix.backend io.files io unix kernel math continuations ; IN: io.unix.files +: read-flags O_RDONLY ; inline + : open-read ( path -- fd ) O_RDONLY file-mode open dup io-error ; M: unix-io ( path -- stream ) open-read ; -: write-flags O_WRONLY O_CREAT O_TRUNC bitor bitor ; +: write-flags O_WRONLY O_CREAT O_TRUNC bitor bitor ; inline : open-write ( path -- fd ) write-flags file-mode open dup io-error ; @@ -18,7 +20,7 @@ M: unix-io ( path -- stream ) M: unix-io ( path -- stream ) open-write ; -: append-flags O_WRONLY O_APPEND O_CREAT bitor bitor ; +: append-flags O_WRONLY O_APPEND O_CREAT bitor bitor ; inline : open-append ( path -- fd ) append-flags file-mode open dup io-error diff --git a/extra/io/unix/kqueue/authors.txt b/extra/io/unix/kqueue/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/unix/kqueue/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor new file mode 100755 index 0000000000..19005df404 --- /dev/null +++ b/extra/io/unix/kqueue/kqueue.factor @@ -0,0 +1,78 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types kernel io.nonblocking io.unix.backend +sequences assocs unix unix.kqueue unix.process math namespaces +combinators threads vectors io.launcher io.unix.launcher ; +IN: io.unix.kqueue + +TUPLE: kqueue-mx events ; + +: max-events ( -- n ) + #! We read up to 256 events at a time. This is an arbitrary + #! constant... + 256 ; inline + +: ( -- mx ) + kqueue-mx construct-mx + kqueue dup io-error over set-mx-fd + max-events "kevent" over set-kqueue-mx-events ; + +GENERIC: io-task-filter ( task -- n ) + +M: input-task io-task-filter drop EVFILT_READ ; + +M: output-task io-task-filter drop EVFILT_WRITE ; + +: make-kevent ( task flags -- event ) + "kevent" + tuck set-kevent-flags + over io-task-fd over set-kevent-ident + swap io-task-filter over set-kevent-filter ; + +: register-kevent ( kevent mx -- ) + mx-fd swap 1 f 0 f kevent io-error ; + +M: kqueue-mx register-io-task ( task mx -- ) + over EV_ADD make-kevent over register-kevent + delegate register-io-task ; + +M: kqueue-mx unregister-io-task ( task mx -- ) + 2dup delegate unregister-io-task + swap EV_DELETE make-kevent swap register-kevent ; + +: wait-kevent ( mx timespec -- n ) + >r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent + dup multiplexer-error ; + +: kevent-read-task ( mx fd -- ) + over mx-reads at handle-io-task ; + +: kevent-write-task ( mx fd -- ) + over mx-reads at handle-io-task ; + +: kevent-proc-task ( pid -- ) + dup wait-for-pid swap find-process + dup [ notify-exit ] [ 2drop ] if ; + +: handle-kevent ( mx kevent -- ) + dup kevent-ident swap kevent-filter { + { [ dup EVFILT_READ = ] [ drop kevent-read-task ] } + { [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] } + { [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] } + } cond ; + +: handle-kevents ( mx n -- ) + [ over kqueue-mx-events kevent-nth handle-kevent ] with each ; + +M: kqueue-mx wait-for-events ( ms mx -- ) + swap make-timespec dupd wait-kevent handle-kevents ; + +: make-proc-kevent ( pid -- kevent ) + "kevent" + tuck set-kevent-ident + EV_ADD over set-kevent-flags + EVFILT_PROC over set-kevent-filter + NOTE_EXIT over set-kevent-fflags ; + +: add-pid-task ( pid mx -- ) + swap make-proc-kevent swap register-kevent ; diff --git a/extra/io/unix/launcher/authors.txt b/extra/io/unix/launcher/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/unix/launcher/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 74bced16c4..0135b55a7e 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.launcher io.unix.backend io.nonblocking -sequences kernel namespaces math system alien.c-types -debugger continuations arrays assocs combinators unix.process -parser-combinators memoize promises strings ; +USING: io io.backend io.launcher io.unix.backend io.unix.files +io.nonblocking sequences kernel namespaces math system + alien.c-types debugger continuations arrays assocs +combinators unix.process parser-combinators memoize +promises strings threads ; IN: io.unix.launcher ! Search unix first @@ -42,31 +43,35 @@ MEMO: 'arguments' ( -- parser ) : assoc>env ( assoc -- env ) [ "=" swap 3append ] { } assoc>map ; -: (spawn-process) ( -- ) +: (redirect) ( path mode fd -- ) + >r file-mode open dup io-error dup + r> dup2 io-error close ; + +: redirect ( obj mode fd -- ) + { + { [ pick not ] [ 3drop ] } + { [ pick +closed+ eq? ] [ close 2drop ] } + { [ pick string? ] [ (redirect) ] } + } cond ; + +: setup-redirection ( -- ) + +stdin+ get read-flags 0 redirect + +stdout+ get write-flags 1 redirect + +stderr+ get write-flags 2 redirect ; + +: spawn-process ( -- ) [ - pass-environment? [ - get-arguments get-environment assoc>env exec-args-with-env - ] [ - get-arguments exec-args-with-path - ] if io-error + setup-redirection + get-arguments + pass-environment? + [ get-environment assoc>env exec-args-with-env ] + [ exec-args-with-path ] if + io-error ] [ error. :c flush ] recover 1 exit ; -: wait-for-process ( pid -- ) - 0 0 waitpid drop ; - -: spawn-process ( -- pid ) - [ (spawn-process) ] [ ] with-fork ; - -: spawn-detached ( -- ) - [ spawn-process 0 exit ] [ ] with-fork wait-for-process ; - -M: unix-io run-process* ( desc -- ) +M: unix-io run-process* ( desc -- pid ) [ - +detached+ get [ - spawn-detached - ] [ - spawn-process wait-for-process - ] if + [ spawn-process ] [ ] with-fork ] with-descriptor ; : open-pipe ( -- pair ) @@ -80,20 +85,36 @@ M: unix-io run-process* ( desc -- ) : spawn-process-stream ( -- in out pid ) open-pipe open-pipe [ setup-stdio-pipe - (spawn-process) + spawn-process ] [ -rot 2dup second close first close - ] with-fork first swap second rot ; - -TUPLE: pipe-stream pid ; - -: ( in out pid -- stream ) - pipe-stream construct-boa - -rot handle>duplex-stream over set-delegate ; - -M: pipe-stream stream-close - dup delegate stream-close - pipe-stream-pid wait-for-process ; + ] with-fork first swap second rot ; M: unix-io process-stream* - [ spawn-process-stream ] with-descriptor ; + [ + spawn-process-stream >r handle>duplex-stream r> + ] with-descriptor ; + +: find-process ( handle -- process ) + processes get swap [ nip swap process-handle = ] curry + assoc-find 2drop ; + +! Inefficient process wait polling, used on Linux and Solaris. +! On BSD and Mac OS X, we use kqueue() which scales better. +: wait-for-processes ( -- ? ) + -1 0 tuck WNOHANG waitpid + dup 0 <= [ + 2drop t + ] [ + find-process dup [ + >r *uint r> notify-exit f + ] [ + 2drop f + ] if + ] if ; + +: wait-loop ( -- ) + wait-for-processes [ 250 sleep ] when wait-loop ; + +: start-wait-thread ( -- ) + [ wait-loop ] in-thread ; diff --git a/extra/io/unix/linux/authors.txt b/extra/io/unix/linux/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/unix/linux/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor new file mode 100755 index 0000000000..6d55decb5a --- /dev/null +++ b/extra/io/unix/linux/linux.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: io.unix.linux +USING: io.backend io.unix.backend io.unix.launcher io.unix.select +namespaces kernel assocs unix.process init ; + +TUPLE: linux-io ; + +INSTANCE: linux-io unix-io + +M: linux-io init-io ( -- ) + mx set-global ; + +T{ linux-io } set-io-backend + +[ start-wait-thread ] "io.unix.linux" add-init-hook \ No newline at end of file diff --git a/extra/io/unix/mmap/authors.txt b/extra/io/unix/mmap/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/unix/mmap/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor old mode 100644 new mode 100755 index 5a72a5426a..71c55f2303 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -15,7 +15,7 @@ M: unix-io ( path length -- obj ) dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor r> mmap-open f mapped-file construct-boa ; -M: unix-io (close-mapped-file) ( mmap -- ) +M: unix-io close-mapped-file ( mmap -- ) [ mapped-file-address ] keep [ mapped-file-length munmap ] keep mapped-file-handle close diff --git a/extra/io/unix/select/authors.txt b/extra/io/unix/select/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/unix/select/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor new file mode 100644 index 0000000000..c28686d2f2 --- /dev/null +++ b/extra/io/unix/select/select.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types kernel io.nonblocking io.unix.backend +bit-arrays sequences assocs unix math namespaces structs ; +IN: io.unix.select + +TUPLE: select-mx read-fdset write-fdset ; + +! Factor's bit-arrays are an array of bytes, OS X expects +! FD_SET to be an array of cells, so we have to account for +! byte order differences on big endian platforms +: little-endian? 1 *char 1 = ; foldable + +: munge ( i -- i' ) + little-endian? [ BIN: 11000 bitxor ] unless ; inline + +: ( -- mx ) + select-mx construct-mx + FD_SETSIZE 8 * over set-select-mx-read-fdset + FD_SETSIZE 8 * over set-select-mx-write-fdset ; + +: handle-fd ( fd task fdset mx -- ) + roll munge rot nth [ swap handle-io-task ] [ 2drop ] if ; + +: handle-fdset ( tasks fdset mx -- ) + [ handle-fd ] 2curry assoc-each ; + +: init-fdset ( tasks fdset -- ) + dup clear-bits + [ >r drop t swap munge r> set-nth ] curry assoc-each ; + +: read-fdset/tasks + { mx-reads select-mx-read-fdset } get-slots ; + +: write-fdset/tasks + { mx-writes select-mx-write-fdset } get-slots ; + +: init-fdsets ( mx -- read write except ) + [ read-fdset/tasks tuck init-fdset ] keep + write-fdset/tasks tuck init-fdset + f ; + +M: select-mx wait-for-events ( ms mx -- ) + swap >r FD_SETSIZE over init-fdsets r> make-timeval + select multiplexer-error + dup read-fdset/tasks pick handle-fdset + dup write-fdset/tasks rot handle-fdset ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor old mode 100644 new mode 100755 index 0787a1afde..59a9a8ac2e --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2007 Slava Pestov, Ivan Tikhonov. +! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! See http://factorcode.org/license.txt for BSD license. ! We need to fiddle with the exact search order here, since @@ -15,8 +15,7 @@ libc combinators ; #! don't set up error handlers until after #! returns (and if they did before, they wouldn't have #! anything to close!) - dup port-error dup - [ swap stream-close throw ] [ 2drop ] if ; + dup port-error dup [ swap dispose throw ] [ 2drop ] if ; : socket-fd ( domain type -- socket ) 0 socket dup io-error dup init-handle ; @@ -33,16 +32,15 @@ M: unix-io addrinfo-error ( n -- ) TUPLE: connect-task ; -: ( port -- task ) connect-task ; +: ( port continuation -- task ) + connect-task ; M: connect-task do-io-task io-task-port dup port-handle f 0 write 0 < [ defer-error ] [ drop t ] if ; -M: connect-task task-container drop write-tasks get-global ; - : wait-to-connect ( port -- ) - [ swap add-io-task stop ] callcc0 drop ; + [ add-io-task ] with-port-continuation drop ; M: unix-io (client) ( addrspec -- stream ) dup make-sockaddr/size >r >r @@ -66,9 +64,8 @@ USE: unix TUPLE: accept-task ; -: ( port -- task ) accept-task ; - -M: accept-task task-container drop read-tasks get ; +: ( port continuation -- task ) + accept-task ; : accept-sockaddr ( port -- fd sockaddr ) dup port-handle swap server-port-addr sockaddr-type @@ -85,7 +82,7 @@ M: accept-task do-io-task over 0 >= [ do-accept t ] [ 2drop defer-error ] if ; : wait-to-accept ( server -- ) - [ swap add-io-task stop ] callcc0 drop ; + [ add-io-task ] with-port-continuation drop ; USE: io.sockets @@ -99,7 +96,6 @@ M: unix-io ( addrspec -- stream ) [ SOCK_STREAM server-fd dup 10 listen zero? [ dup close (io-error) ] unless - f ] keep ; M: unix-io accept ( server -- client ) @@ -111,7 +107,7 @@ M: unix-io accept ( server -- client ) ! Datagram sockets - UDP and Unix domain M: unix-io - [ SOCK_DGRAM server-fd f ] keep ; + [ SOCK_DGRAM server-fd ] keep ; SYMBOL: receive-buffer @@ -136,7 +132,8 @@ packet-size receive-buffer set-global TUPLE: receive-task ; -: ( stream -- task ) receive-task ; +: ( stream continuation -- task ) + receive-task ; M: receive-task do-io-task io-task-port @@ -149,10 +146,8 @@ M: receive-task do-io-task 2drop defer-error ] if ; -M: receive-task task-container drop read-tasks get ; - : wait-receive ( stream -- ) - [ swap add-io-task stop ] callcc0 drop ; + [ add-io-task ] with-port-continuation drop ; M: unix-io receive ( datagram -- packet addrspec ) dup check-datagram-port @@ -166,8 +161,8 @@ M: unix-io receive ( datagram -- packet addrspec ) TUPLE: send-task packet sockaddr len ; -: ( packet sockaddr len port -- task ) - send-task [ +: ( packet sockaddr len stream continuation -- task ) + send-task [ { set-send-task-packet set-send-task-sockaddr @@ -182,10 +177,8 @@ M: send-task do-io-task [ send-task-len do-send ] keep swap 0 < [ io-task-port defer-error ] [ drop t ] if ; -M: send-task task-container drop write-tasks get ; - : wait-send ( packet sockaddr len stream -- ) - [ >r r> swap add-io-task stop ] callcc0 + [ add-io-task ] with-port-continuation 2drop 2drop ; M: unix-io send ( packet addrspec datagram -- ) diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor old mode 100644 new mode 100755 index e328e7bf5d..8a621f8f48 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -56,14 +56,14 @@ yield "Receive 2" print - "d" get receive >r >upper r> + "d" get receive >r " world" append r> "Send 1" print dup . "d" get send - "d" get stream-close + "d" get dispose "Done" print @@ -98,13 +98,13 @@ client-addr "d" get send ] unit-test -[ "HELLO" t ] [ +[ "hello world" t ] [ "d" get receive server-addr = >r >string r> ] unit-test -[ ] [ "d" get stream-close ] unit-test +[ ] [ "d" get dispose ] unit-test ! Test error behavior @@ -120,7 +120,7 @@ client-addr B{ 1 2 3 } "unix-domain-datagram-test-3" "d" get send ] unit-test-fails -[ ] [ "d" get stream-close ] unit-test +[ ] [ "d" get dispose ] unit-test ! See what happens on send/receive after close diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 7114f388e0..7dc66a05ad 100755 --- a/extra/io/unix/unix.factor +++ b/extra/io/unix/unix.factor @@ -1,9 +1,10 @@ -USE: io.unix.backend -USE: io.unix.files -USE: io.unix.sockets -USE: io.unix.launcher -USE: io.unix.mmap -USE: io.backend -USE: namespaces +USING: io.unix.backend io.unix.files io.unix.sockets +io.unix.launcher io.unix.mmap io.backend combinators namespaces +system vocabs.loader ; -T{ unix-io } io-backend set-global +{ + { [ bsd? ] [ "io.unix.bsd" ] } + { [ macosx? ] [ "io.unix.bsd" ] } + { [ linux? ] [ "io.unix.linux" ] } + { [ solaris? ] [ "io.unix.solaris" ] } +} cond require diff --git a/extra/io/windows/ce/backend/authors.txt b/extra/io/windows/ce/backend/authors.txt new file mode 100755 index 0000000000..026f4cd0de --- /dev/null +++ b/extra/io/windows/ce/backend/authors.txt @@ -0,0 +1,3 @@ +Doug Coleman +Slava Pestov +Mackenzie Straight diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index 142447fe0c..e90a9f16e2 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -8,7 +8,7 @@ IN: io.windows.ce.backend win32-error-string swap set-port-error ; M: windows-ce-io io-multiplex ( ms -- ) (sleep) ; -M: windows-ce-io add-completion ( port -- ) drop ; +M: windows-ce-io add-completion ( handle -- ) drop ; GENERIC: wince-read ( port port-handle -- ) diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor index 9fb0d700d9..a5e0cb6b4a 100755 --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -3,4 +3,4 @@ io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher namespaces io.windows.mmap ; IN: io.windows.ce -T{ windows-ce-io } io-backend set-global +T{ windows-ce-io } set-io-backend diff --git a/extra/io/windows/ce/files/authors.txt b/extra/io/windows/ce/files/authors.txt new file mode 100755 index 0000000000..5674120196 --- /dev/null +++ b/extra/io/windows/ce/files/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/extra/io/windows/ce/sockets/authors.txt b/extra/io/windows/ce/sockets/authors.txt new file mode 100755 index 0000000000..5674120196 --- /dev/null +++ b/extra/io/windows/ce/sockets/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index da64b25933..9114dceb75 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -38,27 +38,28 @@ M: windows-ce-io ( addrspec -- duplex-stream ) [ windows.winsock:SOCK_STREAM server-fd dup listen-on-socket - f + ] keep ; M: windows-ce-io accept ( server -- client ) - dup check-server-port [ - dup touch-port - dup port-handle win32-file-handle - swap server-port-addr sockaddr-type heap-size - dup [ - swap f 0 - windows.winsock:WSAAccept - dup windows.winsock:INVALID_SOCKET = - [ windows.winsock:winsock-error ] when - ] keep - ] keep server-port-addr parse-sockaddr swap - dup handle>duplex-stream ; + dup check-server-port + [ + dup port-handle win32-file-handle + swap server-port-addr sockaddr-type heap-size + dup [ + swap f 0 + windows.winsock:WSAAccept + dup windows.winsock:INVALID_SOCKET = + [ windows.winsock:winsock-error ] when + ] keep + ] keep server-port-addr parse-sockaddr swap + dup handle>duplex-stream + ] with-port-timeout ; M: windows-ce-io ( addrspec -- datagram ) [ - windows.winsock:SOCK_DGRAM server-fd f + windows.winsock:SOCK_DGRAM server-fd ] keep ; : packet-size 65536 ; inline @@ -78,7 +79,7 @@ M: windows-ce-io ( addrspec -- datagram ) packet-size receive-buffer make-WSABUF ; : packet-data ( len -- byte-array ) - receive-buffer swap memory>string >byte-array ; + receive-buffer swap memory>byte-array ; packet-size receive-buffer set-global diff --git a/extra/io/windows/launcher/authors.txt b/extra/io/windows/launcher/authors.txt new file mode 100755 index 0000000000..5674120196 --- /dev/null +++ b/extra/io/windows/launcher/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 136c8197fc..ec53d9152c 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2007 Doug Coleman, Slava Pestov. +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations destructors io -io.windows libc io.nonblocking io.streams.duplex windows.types -math windows.kernel32 windows namespaces io.launcher kernel -sequences windows.errors assocs splitting system ; +io.windows io.windows.pipes libc io.nonblocking +io.streams.duplex windows.types math windows.kernel32 windows +namespaces io.launcher kernel sequences windows.errors assocs +splitting system threads init strings combinators io.backend ; IN: io.windows.launcher TUPLE: CreateProcess-args @@ -19,24 +20,17 @@ TUPLE: CreateProcess-args lpProcessInformation stdout-pipe stdin-pipe ; -: dispose-CreateProcess-args ( args -- ) - #! From MSDN: "Handles in PROCESS_INFORMATION must be closed - #! with CloseHandle when they are no longer needed." - CreateProcess-args-lpProcessInformation dup - PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* - PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; - : default-CreateProcess-args ( -- obj ) - 0 0 "STARTUPINFO" "STARTUPINFO" heap-size over set-STARTUPINFO-cb "PROCESS_INFORMATION" + TRUE { - set-CreateProcess-args-bInheritHandles set-CreateProcess-args-dwCreateFlags set-CreateProcess-args-lpStartupInfo set-CreateProcess-args-lpProcessInformation + set-CreateProcess-args-bInheritHandles } \ CreateProcess-args construct ; : call-CreateProcess ( CreateProcess-args -- ) @@ -57,7 +51,7 @@ TUPLE: CreateProcess-args [ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ; : join-arguments ( args -- cmd-line ) - [ "\"" swap escape-argument "\"" 3append ] map " " join ; + " " join ; : app-name/cmd-line ( -- app-name cmd-line ) +command+ get [ @@ -93,10 +87,65 @@ TUPLE: CreateProcess-args over set-CreateProcess-args-lpEnvironment ] when ; -: wait-for-process ( args -- ) - CreateProcess-args-lpProcessInformation - PROCESS_INFORMATION-hProcess INFINITE - WaitForSingleObject drop ; +: (redirect) ( path access-mode create-mode -- handle ) + >r >r + normalize-pathname + r> ! access-mode + share-mode + security-attributes-inherit + r> ! create-mode + FILE_ATTRIBUTE_NORMAL ! flags and attributes + f ! template file + CreateFile dup invalid-handle? dup close-later ; + +: redirect ( obj access-mode create-mode -- handle ) + { + { [ pick not ] [ 3drop f ] } + { [ pick +closed+ eq? ] [ 3drop t ] } + { [ pick string? ] [ (redirect) ] } + } cond ; + +: ?closed or dup t eq? [ drop f ] when ; + +: inherited-stdout ( args -- handle ) + CreateProcess-args-stdout-pipe + [ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ; + +: redirect-stdout ( args -- handle ) + +stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect + swap inherited-stdout ?closed ; + +: inherited-stderr ( args -- handle ) + drop STD_ERROR_HANDLE GetStdHandle ; + +: redirect-stderr ( args -- handle ) + +stderr+ get + dup +stdout+ eq? [ + drop + CreateProcess-args-lpStartupInfo + STARTUPINFO-hStdOutput + ] [ + GENERIC_WRITE CREATE_ALWAYS redirect + swap inherited-stderr ?closed + ] if ; + +: inherited-stdin ( args -- handle ) + CreateProcess-args-stdin-pipe + [ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ; + +: redirect-stdin ( args -- handle ) + +stdin+ get GENERIC_READ OPEN_EXISTING redirect + swap inherited-stdin ?closed ; + +: fill-startup-info + dup CreateProcess-args-lpStartupInfo + STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags + + over redirect-stdout over set-STARTUPINFO-hStdOutput + over redirect-stderr over set-STARTUPINFO-hStdError + over redirect-stdin over set-STARTUPINFO-hStdInput + + drop ; : make-CreateProcess-args ( -- args ) default-CreateProcess-args @@ -104,10 +153,46 @@ TUPLE: CreateProcess-args fill-dwCreateFlags fill-lpEnvironment ; -M: windows-io run-process* ( desc -- ) +M: windows-io run-process* ( desc -- handle ) [ - make-CreateProcess-args - dup call-CreateProcess - +detached+ get [ dup wait-for-process ] unless - dispose-CreateProcess-args - ] with-descriptor ; + [ + make-CreateProcess-args fill-startup-info + dup call-CreateProcess + CreateProcess-args-lpProcessInformation + ] with-descriptor + ] with-destructors ; + +: dispose-process ( process-information -- ) + #! From MSDN: "Handles in PROCESS_INFORMATION must be closed + #! with CloseHandle when they are no longer needed." + dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* + PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; + +: exit-code ( process -- n ) + PROCESS_INFORMATION-hProcess + 0 [ GetExitCodeProcess ] keep *ulong + swap win32-error=0/f ; + +: process-exited ( process -- ) + dup process-handle exit-code + over process-handle dispose-process + swap notify-exit ; + +: wait-for-processes ( processes -- ? ) + keys dup + [ process-handle PROCESS_INFORMATION-hProcess ] map + dup length swap >c-void*-array 0 0 + WaitForMultipleObjects + dup HEX: ffffffff = [ win32-error ] when + dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; + +: wait-loop ( -- ) + processes get dup assoc-empty? + [ drop t ] [ wait-for-processes ] if + [ 250 sleep ] when + wait-loop ; + +: start-wait-thread ( -- ) + [ wait-loop ] in-thread ; + +[ start-wait-thread ] "io.windows.launcher" add-init-hook diff --git a/extra/io/windows/mmap/authors.txt b/extra/io/windows/mmap/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/io/windows/mmap/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index 27587e8340..d1cafa4c0f 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -81,7 +81,7 @@ M: windows-io ( path length -- mmap ) f \ mapped-file construct-boa ] with-destructors ; -M: windows-io (close-mapped-file) ( mapped-file -- ) +M: windows-io close-mapped-file ( mapped-file -- ) [ dup mapped-file-handle [ close-always ] each mapped-file-address UnmapViewOfFile win32-error=0/f diff --git a/extra/io/windows/nt/backend/authors.txt b/extra/io/windows/nt/backend/authors.txt new file mode 100755 index 0000000000..026f4cd0de --- /dev/null +++ b/extra/io/windows/nt/backend/authors.txt @@ -0,0 +1,3 @@ +Doug Coleman +Slava Pestov +Mackenzie Straight diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 0d1f2cec0b..88e7cdf84a 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,8 +1,8 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking -io.windows libc kernel math namespaces sequences threads -tuples.lib windows windows.errors windows.kernel32 strings -splitting io.files qualified ; +io.windows libc kernel math namespaces sequences +threads tuples.lib windows windows.errors windows.kernel32 +strings splitting io.files qualified ascii ; QUALIFIED: windows.winsock IN: io.windows.nt.backend @@ -43,28 +43,17 @@ M: windows-nt-io normalize-pathname ( string -- string ) SYMBOL: io-hash -TUPLE: io-callback continuation port ; +TUPLE: io-callback port continuation ; C: io-callback : (make-overlapped) ( -- overlapped-ext ) - "OVERLAPPED" malloc-object dup free-always - 0 over set-OVERLAPPED-internal - 0 over set-OVERLAPPED-internal-high - 0 over set-OVERLAPPED-offset-high - 0 over set-OVERLAPPED-offset - f over set-OVERLAPPED-event ; + "OVERLAPPED" malloc-object dup free-always ; : make-overlapped ( port -- overlapped-ext ) >r (make-overlapped) r> port-handle win32-file-ptr [ over set-OVERLAPPED-offset ] when* ; -: port-overlapped ( port -- overlapped ) - port-handle win32-file-overlapped ; - -: set-port-overlapped ( overlapped port -- ) - port-handle set-win32-file-overlapped ; - : ( handle existing -- handle ) f 1 CreateIoCompletionPort dup win32-error=0/f ; @@ -90,21 +79,16 @@ M: windows-nt-io add-completion ( handle -- ) drop t ] if ; -: get-overlapped-result ( port -- bytes-transferred ) - dup - port-handle - dup win32-file-handle - swap win32-file-overlapped - 0 [ - 0 - GetOverlappedResult overlapped-error? drop - ] keep *uint ; +: get-overlapped-result ( overlapped port -- bytes-transferred ) + dup port-handle win32-file-handle rot 0 + [ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ; -: save-callback ( port -- ) +: save-callback ( overlapped port -- ) [ - [ ] keep port-handle win32-file-overlapped + swap + dup alien? [ "bad overlapped in save-callback" throw ] unless io-hash get-global set-at stop - ] curry callcc0 ; + ] callcc0 2drop ; : wait-for-overlapped ( ms -- overlapped ? ) >r master-completion-port get-global r> ! port ms @@ -113,41 +97,36 @@ M: windows-nt-io add-completion ( handle -- ) f ! overlapped [ roll GetQueuedCompletionStatus ] keep *void* swap zero? ; -: lookup-callback ( GetQueuedCompletion-args -- callback ) - io-hash get-global delete-at* drop ; +: lookup-callback ( overlapped -- callback ) + io-hash get-global delete-at* drop + dup io-callback? [ "no callback in io-hash" throw ] unless ; -: wait-for-io ( timeout -- continuation/f ) +: handle-overlapped ( timeout -- ? ) wait-for-overlapped [ GetLastError dup expected-io-error? [ - 2drop f + 2drop t ] [ dup eof? [ drop lookup-callback dup io-callback-port t swap set-port-eof? - io-callback-continuation ] [ (win32-error-string) swap lookup-callback [ io-callback-port set-port-error ] keep - io-callback-continuation - ] if + ] if io-callback-continuation schedule-thread f ] if ] [ - lookup-callback io-callback-continuation + lookup-callback + io-callback-continuation schedule-thread f ] if ; -: maybe-expire ( io-callbck -- ) - io-callback-port - dup timeout? [ - port-handle win32-file-handle CancelIo drop - ] [ - drop - ] if ; +: drain-overlapped ( timeout -- ) + handle-overlapped [ 0 drain-overlapped ] unless ; -: cancel-timeout ( -- ) - io-hash get-global values [ maybe-expire ] each ; +M: windows-nt-io cancel-io + port-handle win32-file-handle CancelIo drop ; M: windows-nt-io io-multiplex ( ms -- ) - cancel-timeout wait-for-io [ schedule-thread ] when* ; + expire-timeouts drain-overlapped ; M: windows-nt-io init-io ( -- ) master-completion-port set-global diff --git a/extra/io/windows/nt/files/authors.txt b/extra/io/windows/nt/files/authors.txt new file mode 100755 index 0000000000..026f4cd0de --- /dev/null +++ b/extra/io/windows/nt/files/authors.txt @@ -0,0 +1,3 @@ +Doug Coleman +Slava Pestov +Mackenzie Straight diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 375f35176c..4a304e5ac9 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -17,22 +17,18 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) 2drop ] if* ; -: finish-flush ( port -- ) +: finish-flush ( overlapped port -- ) dup pending-error - dup get-overlapped-result + tuck get-overlapped-result dup pick update-file-ptr swap buffer-consume ; -: save-overlapped-and-callback ( fileargs port -- ) - swap FileArgs-lpOverlapped over set-port-overlapped - save-callback ; - : (flush-output) ( port -- ) - dup touch-port dup make-FileArgs tuck setup-write WriteFile dupd overlapped-error? [ - [ save-overlapped-and-callback ] keep + >r FileArgs-lpOverlapped r> + [ save-callback ] 2keep [ finish-flush ] keep dup buffer-empty? [ drop ] [ (flush-output) ] if ] [ @@ -40,14 +36,14 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) ] if ; : flush-output ( port -- ) - [ (flush-output) ] with-destructors ; + [ [ (flush-output) ] with-port-timeout ] with-destructors ; M: port port-flush dup buffer-empty? [ dup flush-output ] unless drop ; -: finish-read ( port -- ) +: finish-read ( overlapped port -- ) dup pending-error - dup get-overlapped-result dup zero? [ + tuck get-overlapped-result dup zero? [ drop t swap set-port-eof? ] [ dup pick n>buffer @@ -55,16 +51,13 @@ M: port port-flush ] if ; : ((wait-to-read)) ( port -- ) - dup touch-port dup make-FileArgs tuck setup-read ReadFile dupd overlapped-error? [ - [ save-overlapped-and-callback ] keep + >r FileArgs-lpOverlapped r> + [ save-callback ] 2keep finish-read - ] [ - 2drop - ] if ; + ] [ 2drop ] if ; M: input-port (wait-to-read) ( port -- ) - [ ((wait-to-read)) ] with-destructors ; - + [ [ ((wait-to-read)) ] with-port-timeout ] with-destructors ; diff --git a/extra/io/windows/nt/launcher/authors.txt b/extra/io/windows/nt/launcher/authors.txt new file mode 100755 index 0000000000..026f4cd0de --- /dev/null +++ b/extra/io/windows/nt/launcher/authors.txt @@ -0,0 +1,3 @@ +Doug Coleman +Slava Pestov +Mackenzie Straight diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 3ee0e05e32..c2f14c21bb 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: alien alien.c-types arrays continuations destructors io io.windows libc io.nonblocking io.streams.duplex windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system -io.windows.launcher io.windows.nt.pipes ; +io.windows.launcher io.windows.pipes ; IN: io.windows.nt.launcher ! The below code is based on the example given in @@ -30,22 +30,10 @@ IN: io.windows.nt.launcher dup pipe-out f set-inherit over set-CreateProcess-args-stdin-pipe ; -: fill-startup-info - dup CreateProcess-args-lpStartupInfo - STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags - - over CreateProcess-args-stdout-pipe - pipe-out over set-STARTUPINFO-hStdOutput - over CreateProcess-args-stdout-pipe - pipe-out over set-STARTUPINFO-hStdError - over CreateProcess-args-stdin-pipe - pipe-in swap set-STARTUPINFO-hStdInput ; - M: windows-io process-stream* [ [ make-CreateProcess-args - TRUE over set-CreateProcess-args-bInheritHandles fill-stdout-pipe fill-stdin-pipe @@ -59,6 +47,6 @@ M: windows-io process-stream* dup CreateProcess-args-stdout-pipe pipe-in over CreateProcess-args-stdin-pipe pipe-out - swap dispose-CreateProcess-args + swap CreateProcess-args-lpProcessInformation ] with-destructors ] with-descriptor ; diff --git a/extra/io/windows/nt/monitor/authors.txt b/extra/io/windows/nt/monitor/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/io/windows/nt/monitor/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor new file mode 100755 index 0000000000..8e0e63923d --- /dev/null +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -0,0 +1,92 @@ +! Copyright (C) 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types destructors io.windows +io.windows.nt.backend kernel math windows windows.kernel32 +windows.types libc assocs alien namespaces continuations +io.monitor io.nonblocking io.buffers io.files io sequences +hashtables sorting arrays combinators ; +IN: io.windows.nt.monitor + +TUPLE: monitor path recursive? queue closed? ; + +: open-directory ( path -- handle ) + FILE_LIST_DIRECTORY + share-mode + f + OPEN_EXISTING + FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED bitor + f + CreateFile + dup invalid-handle? + dup close-later + dup add-completion + f ; + +M: windows-nt-io ( path recursive? -- monitor ) + [ + >r dup open-directory monitor r> { + set-monitor-path + set-delegate + set-monitor-recursive? + } monitor construct + ] with-destructors ; + +: check-closed ( monitor -- ) + port-type closed eq? [ "Monitor closed" throw ] when ; + +: begin-reading-changes ( monitor -- overlapped ) + dup port-handle win32-file-handle + over buffer-ptr + pick buffer-size + roll monitor-recursive? 1 0 ? + FILE_NOTIFY_CHANGE_ALL + 0 + (make-overlapped) + [ f ReadDirectoryChangesW win32-error=0/f ] keep ; + +: read-changes ( monitor -- bytes ) + [ + [ + dup begin-reading-changes + swap [ save-callback ] 2keep + get-overlapped-result + ] with-port-timeout + ] with-destructors ; + +: parse-action ( action -- changed ) + { + { [ dup FILE_ACTION_ADDED = ] [ +add-file+ ] } + { [ dup FILE_ACTION_REMOVED = ] [ +remove-file+ ] } + { [ dup FILE_ACTION_MODIFIED = ] [ +modify-file+ ] } + { [ dup FILE_ACTION_RENAMED_OLD_NAME = ] [ +rename-file+ ] } + { [ dup FILE_ACTION_RENAMED_NEW_NAME = ] [ +rename-file+ ] } + { [ t ] [ +modify-file+ ] } + } cond nip ; + +: changed-file ( directory buffer -- changed path ) + { + FILE_NOTIFY_INFORMATION-FileName + FILE_NOTIFY_INFORMATION-FileNameLength + FILE_NOTIFY_INFORMATION-Action + } get-slots >r memory>u16-string path+ r> parse-action swap ; + +: (changed-files) ( directory buffer -- ) + 2dup changed-file namespace [ swap add ] change-at + dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero? + [ 3drop ] [ swap (changed-files) ] if ; + +: changed-files ( directory buffer len -- assoc ) + [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc ; + +: fill-queue ( monitor -- ) + dup monitor-path over buffer-ptr pick read-changes + changed-files + swap set-monitor-queue ; + +M: windows-nt-io next-change ( monitor -- path changes ) + dup check-closed + dup monitor-queue dup assoc-empty? [ + drop dup fill-queue next-change + ] [ + nip delete-any prune natural-sort >array + ] if ; diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 9ec97b33c6..5bdefd7713 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -1,12 +1,13 @@ -! Copyright (C) 2004, 2007 Mackenzie Straight, Doug Coleman. +! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman, +! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USE: io.windows USE: io.windows.nt.backend USE: io.windows.nt.files -USE: io.windows.nt.sockets USE: io.windows.nt.launcher +USE: io.windows.nt.monitor +USE: io.windows.nt.sockets USE: io.windows.mmap USE: io.backend -USE: namespaces -T{ windows-nt-io } io-backend set-global +T{ windows-nt-io } set-io-backend diff --git a/extra/io/windows/nt/sockets/authors.txt b/extra/io/windows/nt/sockets/authors.txt new file mode 100755 index 0000000000..026f4cd0de --- /dev/null +++ b/extra/io/windows/nt/sockets/authors.txt @@ -0,0 +1,3 @@ +Doug Coleman +Slava Pestov +Mackenzie Straight diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index e86f070719..77249df9f1 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -1,7 +1,8 @@ -USING: alien alien.c-types byte-arrays continuations destructors -io.nonblocking io io.sockets io.sockets.impl namespaces -io.streams.duplex io.windows io.windows.nt.backend -windows.winsock kernel libc math sequences threads tuples.lib ; +USING: alien alien.accessors alien.c-types byte-arrays +continuations destructors io.nonblocking io io.sockets +io.sockets.impl namespaces io.streams.duplex io.windows +io.windows.nt.backend windows.winsock kernel libc math sequences +threads tuples.lib ; IN: io.windows.nt.sockets : malloc-int ( object -- object ) @@ -44,12 +45,11 @@ TUPLE: ConnectEx-args port "stdcall" alien-indirect drop winsock-error-string [ throw ] when* ; -: check-connect-error ( ConnectEx -- ) - ConnectEx-args-port duplex-stream-in get-overlapped-result drop ; - : connect-continuation ( ConnectEx -- ) - [ ConnectEx-args-port duplex-stream-in save-callback ] keep - check-connect-error ; + dup ConnectEx-args-lpOverlapped* + swap ConnectEx-args-port duplex-stream-in + [ save-callback ] 2keep + get-overlapped-result drop ; M: windows-nt-io (client) ( addrspec -- duplex-stream ) [ @@ -64,10 +64,6 @@ M: windows-nt-io (client) ( addrspec -- duplex-stream ) dup ConnectEx-args-s* dup handle>duplex-stream over set-ConnectEx-args-port - [ - dup ConnectEx-args-lpOverlapped* - swap ConnectEx-args-port duplex-stream-in set-port-overlapped - ] keep dup connect-continuation ConnectEx-args-port [ duplex-stream-in pending-error ] keep @@ -93,8 +89,7 @@ TUPLE: AcceptEx-args port over set-AcceptEx-args-sAcceptSocket* 0 over set-AcceptEx-args-dwReceiveDataLength* f over set-AcceptEx-args-lpdwBytesReceived* - (make-overlapped) over set-AcceptEx-args-lpOverlapped* - dup AcceptEx-args-lpOverlapped* swap AcceptEx-args-port set-port-overlapped ; + (make-overlapped) swap set-AcceptEx-args-lpOverlapped* ; : (accept) ( AcceptEx -- ) \ AcceptEx-args >tuple*< @@ -102,10 +97,12 @@ TUPLE: AcceptEx-args port winsock-error-string [ throw ] when* ; : make-accept-continuation ( AcceptEx -- ) - AcceptEx-args-port save-callback ; + dup AcceptEx-args-lpOverlapped* + swap AcceptEx-args-port save-callback ; : check-accept-error ( AcceptEx -- ) - AcceptEx-args-port get-overlapped-result drop ; + dup AcceptEx-args-lpOverlapped* + swap AcceptEx-args-port get-overlapped-result drop ; : extract-remote-host ( AcceptEx -- addrspec ) [ @@ -133,15 +130,16 @@ TUPLE: AcceptEx-args port M: windows-nt-io accept ( server -- client ) [ - dup check-server-port - dup touch-port - \ AcceptEx-args construct-empty - [ init-accept ] keep - [ (accept) ] keep - [ accept-continuation ] keep - AcceptEx-args-port pending-error - dup duplex-stream-in pending-error - dup duplex-stream-out pending-error + [ + dup check-server-port + \ AcceptEx-args construct-empty + [ init-accept ] keep + [ (accept) ] keep + [ accept-continuation ] keep + AcceptEx-args-port pending-error + dup duplex-stream-in pending-error + dup duplex-stream-out pending-error + ] with-port-timeout ] with-destructors ; M: windows-nt-io ( addrspec -- server ) @@ -149,7 +147,7 @@ M: windows-nt-io ( addrspec -- server ) [ SOCK_STREAM server-fd dup listen-on-socket dup add-completion - f + ] keep ] with-destructors ; @@ -158,7 +156,7 @@ M: windows-nt-io ( addrspec -- datagram ) [ SOCK_DGRAM server-fd dup add-completion - f + ] keep ] with-destructors ; @@ -166,6 +164,11 @@ TUPLE: WSARecvFrom-args port s* lpBuffers* dwBufferCount* lpNumberOfBytesRecvd* lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ; +: make-receive-buffer ( -- WSABUF ) + "WSABUF" malloc-object dup free-always + default-buffer-size get over set-WSABUF-len + default-buffer-size get malloc dup free-always over set-WSABUF-buf ; + : init-WSARecvFrom ( datagram WSARecvFrom -- ) [ set-WSARecvFrom-args-port ] 2keep [ @@ -176,33 +179,26 @@ TUPLE: WSARecvFrom-args port 2dup >r malloc dup free-always r> set-WSARecvFrom-args-lpFrom* >r malloc-int dup free-always r> set-WSARecvFrom-args-lpFromLen* ] keep - "WSABUF" malloc-object dup free-always - 2dup swap set-WSARecvFrom-args-lpBuffers* - default-buffer-size get [ malloc dup free-always ] keep - pick set-WSABUF-len - swap set-WSABUF-buf + make-receive-buffer over set-WSARecvFrom-args-lpBuffers* 1 over set-WSARecvFrom-args-dwBufferCount* 0 malloc-int dup free-always over set-WSARecvFrom-args-lpFlags* 0 malloc-int dup free-always over set-WSARecvFrom-args-lpNumberOfBytesRecvd* - (make-overlapped) [ over set-WSARecvFrom-args-lpOverlapped* ] keep - swap WSARecvFrom-args-port set-port-overlapped ; + (make-overlapped) swap set-WSARecvFrom-args-lpOverlapped* ; -: make-WSARecvFrom-continuation ( WSARecvFrom -- ) - WSARecvFrom-args-port save-callback ; +: WSARecvFrom-continuation ( WSARecvFrom -- n ) + dup WSARecvFrom-args-lpOverlapped* + swap WSARecvFrom-args-port [ save-callback ] 2keep + get-overlapped-result ; : call-WSARecvFrom ( WSARecvFrom -- ) \ WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ; -: WSARecvFrom-continuation ( WSARecvFrom -- n ) - [ make-WSARecvFrom-continuation ] keep - WSARecvFrom-args-port get-overlapped-result ; - : parse-WSARecvFrom ( n WSARecvFrom -- packet addrspec ) [ WSARecvFrom-args-lpBuffers* WSABUF-buf - swap memory>string >byte-array + swap memory>byte-array ] keep [ WSARecvFrom-args-lpFrom* ] keep WSARecvFrom-args-port datagram-port-addr parse-sockaddr ; @@ -222,35 +218,36 @@ TUPLE: WSASendTo-args port s* lpBuffers* dwBufferCount* lpNumberOfBytesSent* dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ; +: make-send-buffer ( packet -- WSABUF ) + "WSABUF" malloc-object dup free-always + over malloc-byte-array dup free-always over set-WSABUF-buf + swap length over set-WSABUF-len ; + : init-WSASendTo ( packet addrspec datagram WSASendTo -- ) [ set-WSASendTo-args-port ] 2keep [ - >r delegate port-handle delegate win32-file-handle r> - set-WSASendTo-args-s* - ] keep [ + >r port-handle win32-file-handle r> set-WSASendTo-args-s* + ] keep + [ >r make-sockaddr/size >r malloc-byte-array dup free-always r> r> [ set-WSASendTo-args-iToLen* ] keep set-WSASendTo-args-lpTo* - ] keep [ - "WSABUF" malloc-object dup free-always - dup rot set-WSASendTo-args-lpBuffers* - swap [ malloc-byte-array dup free-always ] keep length - rot [ set-WSABUF-len ] keep - set-WSABUF-buf + ] keep + [ + >r make-send-buffer r> set-WSASendTo-args-lpBuffers* ] keep 1 over set-WSASendTo-args-dwBufferCount* 0 over set-WSASendTo-args-dwFlags* - (make-overlapped) [ over set-WSASendTo-args-lpOverlapped* ] keep - swap WSASendTo-args-port set-port-overlapped ; - -: make-WSASendTo-continuation ( WSASendTo -- ) - WSASendTo-args-port save-callback ; + 0 over set-WSASendTo-args-lpNumberOfBytesSent* + (make-overlapped) swap set-WSASendTo-args-lpOverlapped* ; : WSASendTo-continuation ( WSASendTo -- ) - [ make-WSASendTo-continuation ] keep - WSASendTo-args-port get-overlapped-result drop ; + dup WSASendTo-args-lpOverlapped* + swap WSASendTo-args-port + [ save-callback ] 2keep + get-overlapped-result drop ; : call-WSASendTo ( WSASendTo -- ) \ WSASendTo-args >tuple*< diff --git a/extra/io/windows/pipes/authors.txt b/extra/io/windows/pipes/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/windows/pipes/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/pipes/pipes.factor similarity index 84% rename from extra/io/windows/nt/pipes/pipes.factor rename to extra/io/windows/pipes/pipes.factor index a10a98bd30..8c2acc4009 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/pipes/pipes.factor @@ -3,19 +3,11 @@ USING: alien alien.c-types arrays destructors io io.windows libc windows.types math windows.kernel32 windows namespaces kernel sequences windows.errors assocs math.parser system random ; -IN: io.windows.nt.pipes +IN: io.windows.pipes ! This code is based on ! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py -: default-security-attributes ( -- obj ) - "SECURITY_ATTRIBUTES" - "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ; - -: security-attributes-inherit ( -- obj ) - default-security-attributes - TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable - : create-named-pipe ( name mode -- handle ) FILE_FLAG_OVERLAPPED bitor PIPE_TYPE_BYTE diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 8dcb138999..419864b624 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -1,10 +1,11 @@ -! Copyright (C) 2004, 2007 Mackenzie Straight, Doug Coleman. +! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend io.buffers io.files io.nonblocking io.sockets io.binary io.sockets.impl windows.errors strings io.streams.duplex kernel math namespaces sequences windows windows.kernel32 -windows.shell32 windows.winsock splitting ; +windows.shell32 windows.types windows.winsock splitting +continuations ; IN: io.windows TUPLE: windows-nt-io ; @@ -15,10 +16,9 @@ M: windows-io destruct-handle CloseHandle drop ; M: windows-io destruct-socket closesocket drop ; -TUPLE: win32-file handle ptr overlapped ; +TUPLE: win32-file handle ptr ; -: ( handle ptr -- obj ) - f win32-file construct-boa ; +C: win32-file : ( in out -- stream ) >r f r> f handle>duplex-stream ; @@ -34,6 +34,14 @@ M: windows-io normalize-directory ( string -- string ) FILE_SHARE_READ FILE_SHARE_WRITE bitor FILE_SHARE_DELETE bitor ; foldable +: default-security-attributes ( -- obj ) + "SECURITY_ATTRIBUTES" + "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ; + +: security-attributes-inherit ( -- obj ) + default-security-attributes + TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable + M: win32-file init-handle ( handle -- ) drop ; @@ -167,7 +175,7 @@ USE: namespaces : listen-on-socket ( socket -- ) listen-backlog listen winsock-return-check ; -M: win32-socket stream-close ( stream -- ) +M: win32-socket dispose ( stream -- ) win32-file-handle closesocket drop ; M: windows-io addrinfo-error ( n -- ) diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor old mode 100644 new mode 100755 index 6f54768cab..5b4355986f --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays calendar io io.sockets kernel match namespaces -sequences splitting strings continuations threads ; +sequences splitting strings continuations threads ascii ; IN: irc ! "setup" objects @@ -185,7 +185,7 @@ SYMBOL: line dup irc-client-profile profile-server over irc-client-profile profile-port connect* dup irc-client-profile profile-nickname login - [ irc-loop ] [ irc-stream> stream-close ] [ ] cleanup ; + [ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ; : with-infinite-loop ( quot timeout -- quot timeout ) "looping" print flush diff --git a/extra/jamshred/authors.txt b/extra/jamshred/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/game/authors.txt b/extra/jamshred/game/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/game/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/gl/authors.txt b/extra/jamshred/gl/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/gl/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/oint/authors.txt b/extra/jamshred/oint/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/oint/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/player/authors.txt b/extra/jamshred/player/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/player/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/jamshred/tunnel/authors.txt b/extra/jamshred/tunnel/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/jamshred/tunnel/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/json/authors.txt b/extra/json/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/json/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor index 0f774103e1..105989ab93 100644 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser-combinators namespaces sequences promises strings assocs math math.parser math.vectors math.functions - lazy-lists hashtables ; + lazy-lists hashtables ascii ; IN: json.reader ! Grammar for JSON from RFC 4627 diff --git a/extra/json/summary.txt b/extra/json/summary.txt new file mode 100755 index 0000000000..33c7c9780c --- /dev/null +++ b/extra/json/summary.txt @@ -0,0 +1 @@ +JSON reader and writer diff --git a/extra/koszul/authors.txt b/extra/koszul/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/koszul/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/koszul/summary.txt b/extra/koszul/summary.txt new file mode 100755 index 0000000000..33ad2754b8 --- /dev/null +++ b/extra/koszul/summary.txt @@ -0,0 +1 @@ +Lie algebra cohomology diff --git a/extra/lazy-lists/examples/authors.txt b/extra/lazy-lists/examples/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/lazy-lists/examples/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/lcd/lcd.factor b/extra/lcd/lcd.factor old mode 100644 new mode 100755 index 192e4053d4..605ac4cd59 --- a/extra/lcd/lcd.factor +++ b/extra/lcd/lcd.factor @@ -1,19 +1,19 @@ USING: sequences kernel math io ; IN: lcd -: lcd-digit ( digit row -- str ) - { - " _ _ _ _ _ _ _ _ " - " | | | _| _| |_| |_ |_ | |_| |_| " - " |_| | |_ _| | _| |_| | |_| | " +: lcd-digit ( row digit -- str ) + dup CHAR: : = [ drop 10 ] [ CHAR: 0 - ] if swap { + " _ _ _ _ _ _ _ _ " + " | | | _| _| |_| |_ |_ | |_| |_| * " + " |_| | |_ _| | _| |_| | |_| | * " } nth >r 4 * dup 4 + r> subseq ; -: lcd-row ( num row -- ) - swap [ CHAR: 0 - swap lcd-digit write ] with each ; +: lcd-row ( num row -- string ) + [ swap lcd-digit ] curry { } map-as concat ; -: lcd ( digit-str -- ) - 3 [ lcd-row nl ] with each ; +: lcd ( digit-str -- string ) + 3 [ lcd-row ] with map "\n" join ; -: lcd-demo ( -- ) "31337" lcd ; +: lcd-demo ( -- ) "31337" lcd print ; MAIN: lcd-demo diff --git a/extra/ldap/libldap/authors.txt b/extra/ldap/libldap/authors.txt new file mode 100755 index 0000000000..7c29e7c401 --- /dev/null +++ b/extra/ldap/libldap/authors.txt @@ -0,0 +1 @@ +Elie Chaftari diff --git a/extra/line-art/authors.txt b/extra/line-art/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/line-art/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/line-art/line-art.factor b/extra/line-art/line-art.factor new file mode 100644 index 0000000000..1a0ae6993f --- /dev/null +++ b/extra/line-art/line-art.factor @@ -0,0 +1,255 @@ +USING: arrays bunny combinators.lib continuations io io.files kernel + math math.functions math.vectors multiline + namespaces debugger + opengl opengl.gl opengl-demo-support + prettyprint + sequences ui ui.gadgets ui.gestures ui.render ; +IN: line-art + +TUPLE: line-art-gadget + model step1-program step2-program + framebuffer color-texture normal-texture depth-texture framebuffer-dim ; + +: ( -- line-art-gadget ) + 40.0 -5.0 0.275 + maybe-download read-model + { set-delegate set-line-art-gadget-model } line-art-gadget construct ; + +STRING: line-art-step1-vertex-shader-source +varying vec3 normal; + +void +main() +{ + gl_Position = ftransform(); + normal = gl_Normal; +} + +; + +STRING: line-art-step1-fragment-shader-source +varying vec3 normal; +uniform vec4 color; + +void +main() +{ + gl_FragData[0] = color; + gl_FragData[1] = vec4(normal, 1); +} + +; + +STRING: line-art-step2-vertex-shader-source +varying vec2 coord; + +void +main() +{ + gl_Position = ftransform(); + coord = (gl_Vertex * vec4(0.5) + vec4(0.5)).xy; +} + +; + +STRING: line-art-step2-fragment-shader-source +uniform sampler2D colormap, normalmap, depthmap; +uniform vec4 line_color; +varying vec2 coord; + +const float DEPTH_RATIO_THRESHOLD = 1.001, NORMAL_DOT_THRESHOLD = 1.0, SAMPLE_SPREAD = 1.0/512.0; + +bool +is_normal_border(vec3 norm1, vec3 norm2) +{ + return dot(norm1, norm2) < NORMAL_DOT_THRESHOLD; +} + +float +depth_sample(vec2 c) +{ + return texture2D(depthmap, c).x; +} +bool +are_depths_border(vec3 depths) +{ + return any(lessThan(depths, vec3(1.0/DEPTH_RATIO_THRESHOLD))) + || any(greaterThan(depths, vec3(DEPTH_RATIO_THRESHOLD))); +} + +vec3 +normal_sample(vec2 c) +{ + return texture2D(normalmap, c).xyz; +} + +float +min6(float a, float b, float c, float d, float e, float f) +{ + return min(min(min(min(min(a, b), c), d), e), f); +} + +float +border_factor(vec2 c) +{ + vec2 coord1 = c + vec2(-SAMPLE_SPREAD, -SAMPLE_SPREAD), + coord2 = c + vec2( SAMPLE_SPREAD, -SAMPLE_SPREAD), + coord3 = c + vec2(-SAMPLE_SPREAD, SAMPLE_SPREAD), + coord4 = c + vec2( SAMPLE_SPREAD, SAMPLE_SPREAD); + + vec4 depths = vec4(depth_sample(coord1), + depth_sample(coord2), + depth_sample(coord3), + depth_sample(coord4)); + if (depths == vec4(1, 1, 1, 1)) + return 0.0; + + vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww; + + if (are_depths_border(ratios1) || are_depths_border(ratios2)) + return 1.0; + + vec3 normal1 = normal_sample(coord1), + normal2 = normal_sample(coord2), + normal3 = normal_sample(coord3), + normal4 = normal_sample(coord4); + + float normal_border = 1.0 - min6( + dot(normal1, normal2), + dot(normal1, normal3), + dot(normal1, normal4), + dot(normal2, normal3), + dot(normal2, normal4), + dot(normal3, normal4) + ); + + return normal_border; +} + +void +main() +{ + gl_FragColor = mix(texture2D(colormap, coord), line_color, border_factor(coord)); +} + +; + +: (line-art-step1-program) ( -- step1 ) + line-art-step1-vertex-shader-source line-art-step1-fragment-shader-source + ; +: (line-art-step2-program) ( -- step2 ) + line-art-step2-vertex-shader-source line-art-step2-fragment-shader-source + ; + +: (line-art-framebuffer-texture) ( dim iformat xformat -- texture ) + swapd >r >r >r + GL_TEXTURE0 glActiveTexture + gen-texture GL_TEXTURE_2D over glBindTexture + GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri + GL_TEXTURE_2D 0 r> r> first2 0 r> GL_UNSIGNED_BYTE f glTexImage2D ; + +: (line-art-color-texture) ( dim -- texture ) + GL_RGBA16F_ARB GL_RGBA (line-art-framebuffer-texture) ; + +: (line-art-normal-texture) ( dim -- texture ) + GL_RGBA16F_ARB GL_RGBA (line-art-framebuffer-texture) ; + +: (line-art-depth-texture) ( dim -- texture ) + GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (line-art-framebuffer-texture) ; + +: (attach-framebuffer-texture) ( texture attachment -- ) + swap >r >r GL_FRAMEBUFFER_EXT r> GL_TEXTURE_2D r> 0 glFramebufferTexture2DEXT gl-error ; + +: (line-art-framebuffer) ( color-texture normal-texture depth-texture -- framebuffer ) + 3array gen-framebuffer dup [ + swap GL_COLOR_ATTACHMENT0_EXT + GL_COLOR_ATTACHMENT1_EXT + GL_DEPTH_ATTACHMENT_EXT 3array [ (attach-framebuffer-texture) ] 2each + check-framebuffer + ] with-framebuffer ; + +: line-art-remake-framebuffer-if-needed ( gadget -- ) + dup { rect-dim rect-dim line-art-gadget-framebuffer-dim } get-slots = [ 2drop ] [ + swap >r + dup (line-art-color-texture) gl-error + swap dup (line-art-normal-texture) gl-error + swap dup (line-art-depth-texture) gl-error + swap >r + [ (line-art-framebuffer) ] 3keep + r> r> { set-line-art-gadget-framebuffer + set-line-art-gadget-color-texture + set-line-art-gadget-normal-texture + set-line-art-gadget-depth-texture + set-line-art-gadget-framebuffer-dim } set-slots + ] if ; + +M: line-art-gadget graft* ( gadget -- ) + [ "2.0" { "GL_ARB_draw_buffers" + "GL_ARB_shader_objects" + "GL_ARB_multitexture" + "GL_ARB_texture_float" } + require-gl-version-or-extensions + { "GL_EXT_framebuffer_object" } require-gl-extensions + GL_CULL_FACE glEnable + GL_DEPTH_TEST glEnable + (line-art-step1-program) over set-line-art-gadget-step1-program + (line-art-step2-program) swap set-line-art-gadget-step2-program + ] [ ] [ :c ] cleanup ; + +M: line-art-gadget ungraft* ( gadget -- ) + dup line-art-gadget-framebuffer [ + { [ line-art-gadget-step1-program [ delete-gl-program ] when* ] + [ line-art-gadget-step2-program [ delete-gl-program ] when* ] + [ line-art-gadget-framebuffer [ delete-framebuffer ] when* ] + [ line-art-gadget-color-texture [ delete-texture ] when* ] + [ line-art-gadget-normal-texture [ delete-texture ] when* ] + [ line-art-gadget-depth-texture [ delete-texture ] when* ] + [ f swap set-line-art-gadget-framebuffer-dim ] + [ f swap set-line-art-gadget-framebuffer ] } call-with + ] [ drop ] if ; + +: line-art-draw-setup ( gadget -- gadget ) + 0.0 0.0 0.0 1.0 glClearColor + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + dup demo-gadget-set-matrices + dup line-art-remake-framebuffer-if-needed + gl-error ; + +: line-art-clear-framebuffer ( -- ) + GL_COLOR_ATTACHMENT0_EXT glDrawBuffer + 0.2 0.2 0.2 1.0 glClearColor + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_COLOR_ATTACHMENT1_EXT glDrawBuffer + 0.0 0.0 0.0 0.0 glClearColor + GL_COLOR_BUFFER_BIT glClear ; + +M: line-art-gadget draw-gadget* ( gadget -- ) + line-art-draw-setup + dup line-art-gadget-framebuffer [ + line-art-clear-framebuffer + { GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers + dup line-art-gadget-step1-program dup [ + "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f + 0.0 -0.12 0.0 glTranslatef + dup line-art-gadget-model first3 draw-bunny + ] with-gl-program + ] with-framebuffer + init-matrices + dup line-art-gadget-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit + dup line-art-gadget-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit + dup line-art-gadget-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit + line-art-gadget-step2-program dup [ + { [ "colormap" glGetUniformLocation 0 glUniform1i ] + [ "normalmap" glGetUniformLocation 1 glUniform1i ] + [ "depthmap" glGetUniformLocation 2 glUniform1i ] + [ "line_color" glGetUniformLocation 0.2 0.0 0.0 1.0 glUniform4f ] } call-with + { -1.0 -1.0 } { 1.0 1.0 } rect-vertices + ] with-gl-program ; + +: line-art-window ( -- ) + [ "Line Art" open-window ] with-ui ; + +MAIN: line-art-window diff --git a/extra/line-art/summary.txt b/extra/line-art/summary.txt new file mode 100644 index 0000000000..06d16da2bf --- /dev/null +++ b/extra/line-art/summary.txt @@ -0,0 +1 @@ +Stanford Bunny rendered with cartoon-style lines instead of shading \ No newline at end of file diff --git a/extra/line-art/tags.txt b/extra/line-art/tags.txt new file mode 100644 index 0000000000..0db7e8e629 --- /dev/null +++ b/extra/line-art/tags.txt @@ -0,0 +1,3 @@ +demos +opengl +glsl \ No newline at end of file diff --git a/extra/lint/lint.factor b/extra/lint/lint.factor index 44b234b254..a220eece01 100644 --- a/extra/lint/lint.factor +++ b/extra/lint/lint.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays assocs combinators.lib io kernel +USING: alien alien.accessors arrays assocs combinators.lib io kernel macros math namespaces prettyprint quotations sequences -vectors vocabs words ; -USING: html.elements slots.private tar ; +vectors vocabs words html.elements slots.private tar ; IN: lint SYMBOL: def-hash diff --git a/extra/lint/summary.txt b/extra/lint/summary.txt new file mode 100755 index 0000000000..943869d7d2 --- /dev/null +++ b/extra/lint/summary.txt @@ -0,0 +1 @@ +Finds potential mistakes in code diff --git a/extra/lsys/strings/authors.txt b/extra/lsys/strings/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/lsys/strings/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/lsys/strings/interpret/authors.txt b/extra/lsys/strings/interpret/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/lsys/strings/interpret/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/lsys/strings/rewrite/authors.txt b/extra/lsys/strings/rewrite/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/lsys/strings/rewrite/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/lsys/tortoise/authors.txt b/extra/lsys/tortoise/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/lsys/tortoise/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/lsys/tortoise/graphics/authors.txt b/extra/lsys/tortoise/graphics/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/lsys/tortoise/graphics/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/lsys/ui/authors.txt b/extra/lsys/ui/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/lsys/ui/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/macros/zoo/authors.txt b/extra/macros/zoo/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/macros/zoo/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/mad/api/authors.txt b/extra/mad/api/authors.txt new file mode 100755 index 0000000000..bbc876e7b6 --- /dev/null +++ b/extra/mad/api/authors.txt @@ -0,0 +1 @@ +Adam Wendt diff --git a/extra/mad/player/authors.txt b/extra/mad/player/authors.txt new file mode 100755 index 0000000000..bbc876e7b6 --- /dev/null +++ b/extra/mad/player/authors.txt @@ -0,0 +1 @@ +Adam Wendt diff --git a/extra/math/combinatorics/authors.txt b/extra/math/combinatorics/authors.txt index f372b574ae..708cc3e23e 100644 --- a/extra/math/combinatorics/authors.txt +++ b/extra/math/combinatorics/authors.txt @@ -1,2 +1,3 @@ Slava Pestov Doug Coleman +Aaron Schaefer diff --git a/extra/math/combinatorics/combinatorics-docs.factor b/extra/math/combinatorics/combinatorics-docs.factor new file mode 100644 index 0000000000..c763cc32cf --- /dev/null +++ b/extra/math/combinatorics/combinatorics-docs.factor @@ -0,0 +1,49 @@ +USING: help.markup help.syntax kernel math sequences ; +IN: math.combinatorics + +HELP: factorial +{ $values { "n" "a non-negative integer" } { "n!" integer } } +{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." } +{ $examples { $example "4 factorial ." "24" } } ; + +HELP: nPk +{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } } +{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." } +{ $examples { $example "10 4 nPk ." "5040" } } ; + +HELP: nCk +{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } } +{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." } +{ $examples { $example "10 4 nCk ." "210" } } ; + +HELP: permutation +{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } +{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } +{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." } +{ $examples { $example "1 3 permutation ." "{ 0 2 1 }" } { $example "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\"}" } } ; + +HELP: all-permutations +{ $values { "seq" sequence } { "seq" sequence } } +{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } +{ $examples { $example "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; + +HELP: inverse-permutation +{ $values { "seq" sequence } { "permutation" sequence } } +{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." } +{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." } +{ $examples { $example "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ; + + +IN: math.combinatorics.private + +HELP: factoradic +{ $values { "n" integer } { "seq" sequence } } +{ $description "Converts a positive integer " { $snippet "n" } " to factoradic form. The factoradic of an integer is its representation based on a mixed radix numerical system that corresponds to the values of " { $snippet "n" } " factorial." } +{ $examples { $example "859 factoradic ." "{ 1 1 0 3 0 1 0 }" } } ; + +HELP: >permutation +{ $values { "factoradic" sequence } { "permutation" sequence } } +{ $description "Converts an integer represented in factoradic form into its corresponding unique permutation (0-based)." } +{ $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } } +{ $examples { $example "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ; + diff --git a/extra/math/combinatorics/combinatorics-tests.factor b/extra/math/combinatorics/combinatorics-tests.factor new file mode 100644 index 0000000000..440630e38f --- /dev/null +++ b/extra/math/combinatorics/combinatorics-tests.factor @@ -0,0 +1,50 @@ +USING: math.combinatorics math.combinatorics.private tools.test ; +IN: temporary + +[ { } ] [ 0 factoradic ] unit-test +[ { 1 0 } ] [ 1 factoradic ] unit-test +[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test + +[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test +[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test + +[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test +[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test + +[ { "b" "d" } ] [ { "a" "b" "c" "d" } { 1 3 } reorder ] unit-test +[ { "a" "b" "c" "d" } ] [ { "a" "b" "c" "d" } { 0 1 2 3 } reorder ] unit-test +[ { "d" "c" "b" "a" } ] [ { "a" "b" "c" "d" } { 3 2 1 0 } reorder ] unit-test +[ { "d" "a" "b" "c" } ] [ { "a" "b" "c" "d" } { 3 0 1 2 } reorder ] unit-test + +[ 1 ] [ 0 factorial ] unit-test +[ 1 ] [ 1 factorial ] unit-test +[ 3628800 ] [ 10 factorial ] unit-test + +[ 1 ] [ 3 0 nPk ] unit-test +[ 6 ] [ 3 2 nPk ] unit-test +[ 6 ] [ 3 3 nPk ] unit-test +[ 0 ] [ 3 4 nPk ] unit-test +[ 311875200 ] [ 52 5 nPk ] unit-test +[ 672151459757865654763838640470031391460745878674027315200000000000 ] [ 52 47 nPk ] unit-test + +[ 1 ] [ 3 0 nCk ] unit-test +[ 3 ] [ 3 2 nCk ] unit-test +[ 1 ] [ 3 3 nCk ] unit-test +[ 0 ] [ 3 4 nCk ] unit-test +[ 2598960 ] [ 52 5 nCk ] unit-test +[ 2598960 ] [ 52 47 nCk ] unit-test + +[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test +[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test +[ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test + +[ { { "a" "b" "c" } { "a" "c" "b" } + { "b" "a" "c" } { "b" "c" "a" } + { "c" "a" "b" } { "c" "b" "a" } } ] [ { "a" "b" "c" } all-permutations ] unit-test + +[ { 0 1 2 } ] [ { "a" "b" "c" } inverse-permutation ] unit-test +[ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test +[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test + diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor index a0f331e6f6..99a098ca09 100644 --- a/extra/math/combinatorics/combinatorics.factor +++ b/extra/math/combinatorics/combinatorics.factor @@ -1,21 +1,53 @@ -USING: kernel math math.ranges math.vectors -sequences sorting mirrors assocs ; +! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel math math.ranges mirrors namespaces sequences sorting ; IN: math.combinatorics -: possible? 0 rot between? ; inline + [ dupd - ] when ; inline -: (nCk) ( n k -- nCk ) - [ nPk ] 2keep - factorial / ; +! See this article for explanation of the factoradic-based permutation methodology: +! http://msdn2.microsoft.com/en-us/library/aa302371.aspx -: twiddle 2dup - dupd < [ dupd - ] when ; inline +: factoradic ( n -- factoradic ) + 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ; + +: (>permutation) ( seq n -- seq ) + [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ; + +: >permutation ( factoradic -- permutation ) + reverse 1 cut [ (>permutation) ] each ; + +: permutation-indices ( n seq -- permutation ) + length [ factoradic ] dip 0 pad-left >permutation ; + +: reorder ( seq indices -- seq ) + [ [ over nth , ] each drop ] { } make ; + +PRIVATE> + +: factorial ( n -- n! ) + 1 [ 1+ * ] reduce ; + +: nPk ( n k -- nPk ) + 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; : nCk ( n k -- nCk ) - 2dup possible? [ twiddle (nCk) ] [ 2drop 0 ] if ; + twiddle [ nPk ] keep factorial / ; -: inverse-permutation ( seq -- seq ) +: permutation ( n seq -- seq ) + tuck permutation-indices reorder ; + +: all-permutations ( seq -- seq ) + [ + [ length factorial ] keep [ permutation , ] curry each + ] { } make ; + +: inverse-permutation ( seq -- permutation ) >alist sort-values keys ; + diff --git a/extra/math/constants/constants-docs.factor b/extra/math/constants/constants-docs.factor index 92c96985c3..653444376a 100755 --- a/extra/math/constants/constants-docs.factor +++ b/extra/math/constants/constants-docs.factor @@ -4,6 +4,8 @@ IN: math.constants ARTICLE: "math-constants" "Constants" "Standard mathematical constants:" { $subsection e } +{ $subsection gamma } +{ $subsection phi } { $subsection pi } "Various limits:" { $subsection most-positive-fixnum } @@ -15,6 +17,13 @@ ABOUT: "math-constants" HELP: e { $values { "e" "base of natural logarithm" } } ; +HELP: gamma +{ $values { "gamma" "Euler-Mascheroni constant" } } +{ $description "The Euler-Mascheroni constant, also called \"Euler's constant\" or \"the Euler constant\"." } ; + +HELP: phi +{ $values { "phi" "golden ratio" } } ; + HELP: pi { $values { "pi" "circumference of circle with diameter 1" } } ; diff --git a/extra/math/constants/constants.factor b/extra/math/constants/constants.factor index e2d7c4f433..c4abeca0eb 100755 --- a/extra/math/constants/constants.factor +++ b/extra/math/constants/constants.factor @@ -3,5 +3,7 @@ IN: math.constants : e ( -- e ) 2.7182818284590452354 ; inline +: gamma ( -- gamma ) 0.57721566490153286060 ; inline +: phi ( -- phi ) 1.61803398874989484820 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline diff --git a/extra/math/miller-rabin/authors.txt b/extra/math/miller-rabin/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/math/miller-rabin/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/math/miller-rabin/miller-rabin-tests.factor b/extra/math/miller-rabin/miller-rabin-tests.factor index 42e4164ef3..f8bc9d4970 100644 --- a/extra/math/miller-rabin/miller-rabin-tests.factor +++ b/extra/math/miller-rabin/miller-rabin-tests.factor @@ -1,4 +1,5 @@ -USING: math.miller-rabin kernel math namespaces tools.test ; +USING: math.miller-rabin tools.test ; +IN: temporary [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test [ t ] [ 2 miller-rabin ] unit-test @@ -7,4 +8,3 @@ USING: math.miller-rabin kernel math namespaces tools.test ; [ t ] [ 37 miller-rabin ] unit-test [ 101 ] [ 100 next-prime ] unit-test [ 100000000000031 ] [ 100000000000000 next-prime ] unit-test - diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor old mode 100644 new mode 100755 index e2d012ec0a..8b0d98283c --- a/extra/math/miller-rabin/miller-rabin.factor +++ b/extra/math/miller-rabin/miller-rabin.factor @@ -1,5 +1,6 @@ USING: combinators combinators.lib io locals kernel math -math.functions math.ranges namespaces random sequences ; +math.functions math.ranges namespaces random sequences +hashtables ; IN: math.miller-rabin SYMBOL: a diff --git a/extra/math/miller-rabin/summary.txt b/extra/math/miller-rabin/summary.txt new file mode 100644 index 0000000000..b2591a3182 --- /dev/null +++ b/extra/math/miller-rabin/summary.txt @@ -0,0 +1 @@ +Miller-Rabin probabilistic primality test diff --git a/extra/math/primes/list/authors.txt b/extra/math/primes/list/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/math/primes/list/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor index a6179382bd..645d7e2054 100644 --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -12,10 +12,10 @@ IN: math.text.english "Seventeen" "Eighteen" "Nineteen" } nth ; : tens ( n -- str ) - { "" "" "Twenty" "Thirty" "Forty" "Fifty" "Sixty" "Seventy" "Eighty" "Ninety" } nth ; + { f f "Twenty" "Thirty" "Forty" "Fifty" "Sixty" "Seventy" "Eighty" "Ninety" } nth ; : scale-numbers ( n -- str ) ! up to 10^99 - { "" "Thousand" "Million" "Billion" "Trillion" "Quadrillion" "Quintillion" + { f "Thousand" "Million" "Billion" "Trillion" "Quadrillion" "Quintillion" "Sextillion" "Septillion" "Octillion" "Nonillion" "Decillion" "Undecillion" "Duodecillion" "Tredecillion" "Quattuordecillion" "Quindecillion" "Sexdecillion" "Septendecillion" "Octodecillion" "Novemdecillion" @@ -45,7 +45,7 @@ SYMBOL: and-needed? : tens-place ( n -- str ) 100 mod dup 20 >= [ - 10 /mod >r tens r> + 10 /mod [ tens ] dip dup zero? [ drop ] [ "-" swap small-numbers 3append ] if ] [ dup zero? [ drop "" ] [ small-numbers ] if @@ -97,3 +97,4 @@ PRIVATE> ] [ [ (number>text) ] with-scope ] if ; + diff --git a/extra/math/text/summary.txt b/extra/math/text/summary.txt new file mode 100644 index 0000000000..95dc6939e2 --- /dev/null +++ b/extra/math/text/summary.txt @@ -0,0 +1 @@ +Convert integers to text in multiple languages diff --git a/extra/minneapolis-talk/authors.txt b/extra/minneapolis-talk/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/minneapolis-talk/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/catalyst-talk/deploy.factor b/extra/minneapolis-talk/deploy.factor similarity index 100% rename from extra/catalyst-talk/deploy.factor rename to extra/minneapolis-talk/deploy.factor diff --git a/extra/minneapolis-talk/minneapolis-talk.factor b/extra/minneapolis-talk/minneapolis-talk.factor new file mode 100755 index 0000000000..19cdcab2fb --- /dev/null +++ b/extra/minneapolis-talk/minneapolis-talk.factor @@ -0,0 +1,182 @@ +USING: slides help.markup math arrays hashtables namespaces +sequences kernel sequences parser memoize ; +IN: minneapolis-talk + +: minneapolis-slides +{ + { $slide "What is Factor?" + "Dynamically typed, stack language" + "Have our cake and eat it too" + "Research -vs- production" + "High level -vs- performance" + "Interactive -vs- stand-alone apps" + } + { $slide "The view from 10,000 feet" + "Influenced by Forth, Lisp, Joy, Smalltalk, even Java..." + "Vocabularies: modules" + "Words: named functions, classes, variables" + "Combinators: higher-order functions" + "Quotations: anonymous functions" + } + { $slide "Stack-based programming" + { "Most languages are " { $emphasis "applicative" } } + "Words pop inputs from the stack and push outputs on the stack" + "Literals are pushed on the stack" + { $code "{ 1 2 } { 7 } append reverse sum ." } + } + { $slide "Stack-based programming" + "With the stack you can omit unnecessary names" + "You can still name things: lexical/dynamic variables, sequences, associations, objects, ..." + } + { $slide "Functional programming" + "A quotation is a sequence of literals and words" + "Combinators replace imperative-style loops" + "A simple example:" + { $code "10 [ \"Hello world\" print ] times" } + { "Partial application: " { $link curry } } + { $code "{ 3 1 3 3 7 } [ 5 + ] map ." } + { $code "{ 3 1 3 3 7 } 5 [ + ] curry map ." } + } + { $slide "Word definitions" + { $code ": name ( inputs -- outputs )" + " definition ;" } + "Stack effect comments document stack inputs and outputs." + "Example from previous slide:" + { $code ": add-each ( seq n -- newseq )" + " [ + ] curry map ;" } + { $code "{ 3 1 3 3 7 } 5 add-each ." } + } + { $slide "Object-oriented programming" + { "Define a tuple class and a constructor:" + { $code + "TUPLE: person name address ;" + "C: person" + } } + { "Create an instance:" + { $code + "\"Cosmo Kramer\"" + "\"100 Blah blah St, New York\"" + "" + } } + } + { $slide "Object-oriented programming" + "We can inspect it and edit objects" + "We can reshape the class!" + { $code "TUPLE: person" "name address age phone-number ;" } + { $code "TUPLE: person" "name address phone-number age ;" } + } + { $slide "An example" + { $code + "TUPLE: square dimension ;" + "C: square" + "" + "TUPLE: circle radius ;" + "C: circle" + "" + "TUPLE: rectangle width height ;" + "C: rectangle" + } + } + STRIP-TEASE: + $slide "An example" + { $code + "USE: math.constants" + "GENERIC: area ( shape -- meters^2 )" + "M: square area square-dimension sq ;" + "M: circle area circle-radius sq pi * ;" + "M: rectangle area" + " dup rectangle-width" + " swap rectangle-height * ;" + } + ; + + { $slide "An example" + { $code "10 area ." } + { $code "18 area ." } + { $code "20 40 area ." } + } + { $slide "Meta language" + "Here's fibonacci:" + { $code + ": fib ( x -- y )" + " dup 1 > [" + " 1 - dup fib swap 1 - fib +" + " ] when ;" + } + "It is slow:" + { $code + "35 [ fib ] map ." + } + "Let's profile it!" + } + { $slide "Memoization" + { { $link POSTPONE: : } " is just another word" } + "What if we could define a word which caches its results?" + { "The " { $vocab-link "memoize" } " library provides such a feature" } + { "Just change " { $link POSTPONE: : } " to " { $link POSTPONE: MEMO: } } + } + { $slide "Memoization" + { $code + "USE: memoize" + "" + "MEMO: fib ( x -- y )" + " dup 1 > [" + " 1 - dup fib swap 1 - fib +" + " ] when ;" + } + "It is faster:" + { $code + "35 [ fib ] map ." + } + } + { $slide "The Factor UI" + "Written in Factor" + "Renders with OpenGL" + "Backends for Windows, X11, Cocoa" + "You can call Windows, X11, Cocoa APIs directly too" + "OpenGL 2.1 shaders, OpenAL 3D audio..." + } + { $slide "Live coding demo" + + } + { $slide "C library interface" + "Efficient" + "No need to write C code" + "Supports floats, structs, unions, ..." + "Function pointers, callbacks" + } + { $slide "Live coding demo" + + } + { $slide "Deployment" + { "Let's play " { $vocab-link "tetris" } } + } + { $slide "Implementation" + "Portable: Windows, Mac OS X, Linux" + "Non-optimizing compiler" + "Optimizing compiler: x86, x86-64, PowerPC, ARM" + "Generational garbage collector" + "Non-blocking I/O" + } + { $slide "Some statistics" + "VM: 11,800 lines of C" + "Core library: 22,600 lines of Factor" + "Docs, tests, extra libraries: 117,000 lines of Factor" + } + { $slide "But wait, there's more!" + "Web server and framework, syntax highlighting, Ogg Theora video, SMTP, embedded Prolog, efficient unboxed arrays, XML, Unicode 5.0, memory mapped files, regular expressions, LDAP, database access, coroutines, Factor->JavaScript compiler, JSON, pattern matching, advanced math, parser generators, serialization, RSS/Atom, ..." + } + { $slide "Community" + "Factor development began in 2003" + "About a dozen contributors" + "Handful of \"core contributors\"" + { "Web site: " { $url "http://factorcode.org" } } + "IRC: #concatenative on irc.freenode.net" + "Mailing list: factor-talk@lists.sf.net" + } + { $slide "Questions?" } +} ; + +: minneapolis-talk minneapolis-slides slides-window ; + +MAIN: minneapolis-talk diff --git a/extra/minneapolis-talk/minneapolis-talk.txt b/extra/minneapolis-talk/minneapolis-talk.txt new file mode 100755 index 0000000000..5310accf5b --- /dev/null +++ b/extra/minneapolis-talk/minneapolis-talk.txt @@ -0,0 +1,116 @@ +- how to create a small module +- editor integration +- presentations +- module system +- copy and paste factoring, inverse +- help system +- tetris +- memoization +- editing inspector demo +- dynamic scope, lexical scope + +Factor: contradictions? +----------------------- + +Have our cake and eat it too + +Research -vs- practical +High level -vs- fast +Interactive -vs- deployment + +Factor from 10,000 feet +----------------------- + +word: named function +vocabulary: module +quotation: anonymous function +classes, objects, etc. + +The stack +--------- + +- Stack -vs- applicative +- Pass by reference, dynamically typed +- Stack languages: you can omit names where they're not needed +- More compositional style +- If you need to name things for clarity, you can: + lexical vars, dynamic vars, sequences, assocs, objects... + +Functional programming +---------------------- + +Quotations +Curry +Continuations + +Object-oriented programming +--------------------------- + +Generic words: sort of like open classes +Tuple reshaping +Editing inspector + +Meta programming +---------------- + +Simple, orthogonal core + +Why use a stack at all? +----------------------- + +Nice idioms: 10 days ago +Copy and paste factoring +Easy meta-programming +Sequence operations correspond to functional operations: +- curry is adding at the front +- compose is append + +UI +-- + +Written in Factor +renders with OpenGL +Windows, X11, Cocoa backends +You can call Windows, X11, Cocoa APIs directly +OpenGL 2.1 shaders, OpenAL 3D audio... + +Tools +----- + +Edit +Usages +Profiler +Easy to make your own tools + +Implementation +-------------- + +Two compilers +Generational garbage collector +Non-blocking I/O + +Hands on +-------- + +Community +--------- + +Factor started in 2003 +About a dozen contributors +Handful of "core contributors" +Web site: http://factorcode.org +IRC: #concatenative on irc.freenode.net +Mailing list: factor-talk@lists.sf.net + +C library interface +------------------- + +Efficient +No need to write C code +Supports floats, structs, unions, ... +Function pointers, callbacks +Here is an example + +TerminateProcess + +process-handle TerminateProcess diff --git a/extra/minneapolis-talk/summary.txt b/extra/minneapolis-talk/summary.txt new file mode 100755 index 0000000000..7fcc7abc88 --- /dev/null +++ b/extra/minneapolis-talk/summary.txt @@ -0,0 +1 @@ +Slides for a talk at Ruby.mn, Minneapolis MN, January 2008 diff --git a/extra/catalyst-talk/tags.txt b/extra/minneapolis-talk/tags.txt similarity index 100% rename from extra/catalyst-talk/tags.txt rename to extra/minneapolis-talk/tags.txt diff --git a/extra/multiline/multiline-docs.factor b/extra/multiline/multiline-docs.factor index c48ee16490..0c0eb5e9dd 100644 --- a/extra/multiline/multiline-docs.factor +++ b/extra/multiline/multiline-docs.factor @@ -1,5 +1,4 @@ USING: help.markup help.syntax ; - IN: multiline HELP: STRING: diff --git a/extra/multiline/tags.txt b/extra/multiline/tags.txt new file mode 100755 index 0000000000..abf53a421b --- /dev/null +++ b/extra/multiline/tags.txt @@ -0,0 +1 @@ +reflection diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 6e66119cb0..528e770558 100644 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -16,4 +16,4 @@ IN: namespaces.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: set* ( val var -- ) namestack* set-hash-stack ; +: set* ( val var -- ) namestack* set-assoc-stack ; diff --git a/extra/nehe/2/authors.txt b/extra/nehe/2/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/nehe/2/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/nehe/3/authors.txt b/extra/nehe/3/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/nehe/3/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/nehe/4/authors.txt b/extra/nehe/4/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/nehe/4/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/nehe/5/authors.txt b/extra/nehe/5/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/nehe/5/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/network-clipboard/authors.txt b/extra/network-clipboard/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/network-clipboard/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/new-slots/authors.txt b/extra/new-slots/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/new-slots/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/openal/backend/authors.txt b/extra/openal/backend/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/openal/backend/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/openal/example/authors.txt b/extra/openal/example/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/openal/example/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/openal/macosx/authors.txt b/extra/openal/macosx/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/openal/macosx/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/openal/other/authors.txt b/extra/openal/other/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/openal/other/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/opengl-demo-support/authors.txt b/extra/opengl-demo-support/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/opengl-demo-support/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/opengl-demo-support/opengl-demo-support.factor b/extra/opengl-demo-support/opengl-demo-support.factor new file mode 100644 index 0000000000..ecc6458d41 --- /dev/null +++ b/extra/opengl-demo-support/opengl-demo-support.factor @@ -0,0 +1,74 @@ +USING: arrays combinators.lib kernel math math.functions math.vectors namespaces + opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; +IN: opengl-demo-support + +: NEAR-PLANE 1.0 64.0 / ; inline +: FAR-PLANE 4.0 ; inline +: FOV 2.0 sqrt 1+ ; inline +: MOUSE-MOTION-SCALE 0.5 ; inline +: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline +: KEY-ROTATE-STEP 1.0 ; inline +: KEY-DISTANCE-STEP 1.0 64.0 / ; inline +: DIMS { 640 480 } ; inline + +: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ; + +SYMBOL: last-drag-loc + +TUPLE: demo-gadget yaw pitch distance ; + +: ( yaw pitch distance -- gadget ) + demo-gadget construct-gadget + [ { set-demo-gadget-yaw set-demo-gadget-pitch set-demo-gadget-distance } set-slots ] keep ; + +: yaw-demo-gadget ( yaw gadget -- ) + [ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ; + +: pitch-demo-gadget ( pitch gadget -- ) + [ [ demo-gadget-pitch + ] keep set-demo-gadget-pitch ] keep relayout-1 ; + +: zoom-demo-gadget ( distance gadget -- ) + [ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ; + +M: demo-gadget pref-dim* ( gadget -- dim ) + drop DIMS ; + +: -+ ( x -- -x x ) + dup neg swap ; + +: demo-gadget-frustum ( -- -x x -y y near far ) + FOV-RATIO NEAR-PLANE FOV / v*n + first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ; + +: demo-gadget-set-matrices ( gadget -- ) + GL_PROJECTION glMatrixMode + glLoadIdentity + demo-gadget-frustum glFrustum + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_MODELVIEW glMatrixMode + glLoadIdentity + { [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] + [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] + [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] } call-with ; + +: reset-last-drag-rel ( -- ) + { 0 0 } last-drag-loc set ; +: last-drag-rel ( -- rel ) + drag-loc [ last-drag-loc get v- ] keep last-drag-loc set ; + +: drag-yaw-pitch ( -- yaw pitch ) + last-drag-rel MOUSE-MOTION-SCALE v*n first2 ; + +demo-gadget H{ + { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] } + { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] } + { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] } + { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] } + { T{ key-down f f "=" } [ KEY-DISTANCE-STEP neg swap zoom-demo-gadget ] } + { T{ key-down f f "-" } [ KEY-DISTANCE-STEP swap zoom-demo-gadget ] } + + { T{ button-down f f 1 } [ drop reset-last-drag-rel ] } + { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] } + { T{ mouse-scroll } [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-demo-gadget ] } +} set-gestures + diff --git a/extra/opengl-demo-support/summary.txt b/extra/opengl-demo-support/summary.txt new file mode 100644 index 0000000000..eca681450f --- /dev/null +++ b/extra/opengl-demo-support/summary.txt @@ -0,0 +1 @@ +Common support for OpenGL demos \ No newline at end of file diff --git a/extra/opengl-demo-support/tags.txt b/extra/opengl-demo-support/tags.txt new file mode 100644 index 0000000000..a6797bf627 --- /dev/null +++ b/extra/opengl-demo-support/tags.txt @@ -0,0 +1 @@ +opengl diff --git a/extra/opengl/camera/authors.txt b/extra/opengl/camera/authors.txt new file mode 100755 index 0000000000..bbc876e7b6 --- /dev/null +++ b/extra/opengl/camera/authors.txt @@ -0,0 +1 @@ +Adam Wendt diff --git a/extra/opengl/gl/gl.factor b/extra/opengl/gl/gl.factor index 40ead55ddd..071fbc45e7 100644 --- a/extra/opengl/gl/gl.factor +++ b/extra/opengl/gl/gl.factor @@ -3,7 +3,9 @@ ! This file is based on the gl.h that comes with xorg-x11 6.8.2 -USING: alien alien.syntax kernel sequences words ; +USING: alien alien.syntax kernel parser sequences system words ; +<< windows? "opengl.gl.windows" "opengl.gl.unix" ? use+ >> + IN: opengl.gl TYPEDEF: uint GLenum @@ -1118,195 +1120,688 @@ FUNCTION: void glPushName ( GLuint name ) ; FUNCTION: void glPopName ( ) ; +! OpenGL extension functions + + + + + ! OpenGL 1.2 -: GL_PACK_SKIP_IMAGES HEX: 806B ; inline -: GL_PACK_IMAGE_HEIGHT HEX: 806C ; inline -: GL_UNPACK_SKIP_IMAGES HEX: 806D ; inline -: GL_UNPACK_IMAGE_HEIGHT HEX: 806E ; inline -: GL_TEXTURE_3D HEX: 806F ; inline -: GL_PROXY_TEXTURE_3D HEX: 8070 ; inline -: GL_TEXTURE_DEPTH HEX: 8071 ; inline -: GL_TEXTURE_WRAP_R HEX: 8072 ; inline -: GL_MAX_3D_TEXTURE_SIZE HEX: 8073 ; inline -: GL_BGR HEX: 80E0 ; inline -: GL_BGRA HEX: 80E1 ; inline -: GL_UNSIGNED_BYTE_3_3_2 HEX: 8032 ; inline -: GL_UNSIGNED_BYTE_2_3_3_REV HEX: 8362 ; inline -: GL_UNSIGNED_SHORT_5_6_5 HEX: 8363 ; inline -: GL_UNSIGNED_SHORT_5_6_5_REV HEX: 8364 ; inline -: GL_UNSIGNED_SHORT_4_4_4_4 HEX: 8033 ; inline -: GL_UNSIGNED_SHORT_4_4_4_4_REV HEX: 8365 ; inline -: GL_UNSIGNED_SHORT_5_5_5_1 HEX: 8034 ; inline -: GL_UNSIGNED_SHORT_1_5_5_5_REV HEX: 8366 ; inline -: GL_UNSIGNED_INT_8_8_8_8 HEX: 8035 ; inline -: GL_UNSIGNED_INT_8_8_8_8_REV HEX: 8367 ; inline -: GL_UNSIGNED_INT_10_10_10_2 HEX: 8036 ; inline -: GL_UNSIGNED_INT_2_10_10_10_REV HEX: 8368 ; inline -: GL_RESCALE_NORMAL HEX: 803A ; inline -: GL_LIGHT_MODEL_COLOR_CONTROL HEX: 81F8 ; inline -: GL_SINGLE_COLOR HEX: 81F9 ; inline -: GL_SEPARATE_SPECULAR_COLOR HEX: 81FA ; inline -: GL_CLAMP_TO_EDGE HEX: 812F ; inline -: GL_TEXTURE_MIN_LOD HEX: 813A ; inline -: GL_TEXTURE_MAX_LOD HEX: 813B ; inline -: GL_TEXTURE_BASE_LEVEL HEX: 813C ; inline -: GL_TEXTURE_MAX_LEVEL HEX: 813D ; inline -: GL_MAX_ELEMENTS_VERTICES HEX: 80E8 ; inline -: GL_MAX_ELEMENTS_INDICES HEX: 80E9 ; inline -: GL_ALIASED_POINT_SIZE_RANGE HEX: 846D ; inline -: GL_ALIASED_LINE_WIDTH_RANGE HEX: 846E ; inline +: GL_SMOOTH_POINT_SIZE_RANGE HEX: 0B12 ; inline +: GL_SMOOTH_POINT_SIZE_GRANULARITY HEX: 0B13 ; inline +: GL_SMOOTH_LINE_WIDTH_RANGE HEX: 0B22 ; inline +: GL_SMOOTH_LINE_WIDTH_GRANULARITY HEX: 0B23 ; inline +: GL_UNSIGNED_BYTE_3_3_2 HEX: 8032 ; inline +: GL_UNSIGNED_SHORT_4_4_4_4 HEX: 8033 ; inline +: GL_UNSIGNED_SHORT_5_5_5_1 HEX: 8034 ; inline +: GL_UNSIGNED_INT_8_8_8_8 HEX: 8035 ; inline +: GL_UNSIGNED_INT_10_10_10_2 HEX: 8036 ; inline +: GL_RESCALE_NORMAL HEX: 803A ; inline +: GL_TEXTURE_BINDING_3D HEX: 806A ; inline +: GL_PACK_SKIP_IMAGES HEX: 806B ; inline +: GL_PACK_IMAGE_HEIGHT HEX: 806C ; inline +: GL_UNPACK_SKIP_IMAGES HEX: 806D ; inline +: GL_UNPACK_IMAGE_HEIGHT HEX: 806E ; inline +: GL_TEXTURE_3D HEX: 806F ; inline +: GL_PROXY_TEXTURE_3D HEX: 8070 ; inline +: GL_TEXTURE_DEPTH HEX: 8071 ; inline +: GL_TEXTURE_WRAP_R HEX: 8072 ; inline +: GL_MAX_3D_TEXTURE_SIZE HEX: 8073 ; inline +: GL_BGR HEX: 80E0 ; inline +: GL_BGRA HEX: 80E1 ; inline +: GL_MAX_ELEMENTS_VERTICES HEX: 80E8 ; inline +: GL_MAX_ELEMENTS_INDICES HEX: 80E9 ; inline +: GL_CLAMP_TO_EDGE HEX: 812F ; inline +: GL_TEXTURE_MIN_LOD HEX: 813A ; inline +: GL_TEXTURE_MAX_LOD HEX: 813B ; inline +: GL_TEXTURE_BASE_LEVEL HEX: 813C ; inline +: GL_TEXTURE_MAX_LEVEL HEX: 813D ; inline +: GL_LIGHT_MODEL_COLOR_CONTROL HEX: 81F8 ; inline +: GL_SINGLE_COLOR HEX: 81F9 ; inline +: GL_SEPARATE_SPECULAR_COLOR HEX: 81FA ; inline +: GL_UNSIGNED_BYTE_2_3_3_REV HEX: 8362 ; inline +: GL_UNSIGNED_SHORT_5_6_5 HEX: 8363 ; inline +: GL_UNSIGNED_SHORT_5_6_5_REV HEX: 8364 ; inline +: GL_UNSIGNED_SHORT_4_4_4_4_REV HEX: 8365 ; inline +: GL_UNSIGNED_SHORT_1_5_5_5_REV HEX: 8366 ; inline +: GL_UNSIGNED_INT_8_8_8_8_REV HEX: 8367 ; inline +: GL_UNSIGNED_INT_2_10_10_10_REV HEX: 8368 ; inline +: GL_ALIASED_POINT_SIZE_RANGE HEX: 846D ; inline +: GL_ALIASED_LINE_WIDTH_RANGE HEX: 846E ; inline -! Not present on Windows -! FUNCTION: void glDrawRangeElements ( GLenum mode, GLuint start, GLuint end, GLsizei count, GLenum type, GLvoid* indices ) ; +GL-FUNCTION: void glCopyTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLint x, GLint y, GLsizei width, GLsizei height ) ; +GL-FUNCTION: void glDrawRangeElements ( GLenum mode, GLuint start, GLuint end, GLsizei count, GLenum type, GLvoid* indices ) ; +GL-FUNCTION: void glTexImage3D ( GLenum target, GLint level, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, GLvoid* pixels ) ; +GL-FUNCTION: void glTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLvoid* pixels ) ; -! FUNCTION: void glTexImage3D ( GLenum target, GLint level, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLenum format, GLenum type, GLvoid* pixels ) ; - -! FUNCTION: void glTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLvoid* pixels ) ; - -! FUNCTION: void glCopyTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLint x, GLint y, GLsizei width, GLsizei height ) ; - -! TODO: the rest. looks fiddly ! OpenGL 1.3 -: GL_ACTIVE_TEXTURE HEX: 84E0 ; inline -: GL_CLIENT_ACTIVE_TEXTURE HEX: 84E1 ; inline -: GL_MAX_TEXTURE_UNITS HEX: 84E2 ; inline -: GL_TEXTURE0 HEX: 84C0 ; inline -: GL_TEXTURE1 HEX: 84C1 ; inline -: GL_TEXTURE2 HEX: 84C2 ; inline -: GL_TEXTURE3 HEX: 84C3 ; inline -: GL_TEXTURE4 HEX: 84C4 ; inline -: GL_TEXTURE5 HEX: 84C5 ; inline -: GL_TEXTURE6 HEX: 84C6 ; inline -: GL_TEXTURE7 HEX: 84C7 ; inline -: GL_TEXTURE8 HEX: 84C8 ; inline -: GL_TEXTURE9 HEX: 84C9 ; inline -: GL_TEXTURE10 HEX: 84CA ; inline -: GL_TEXTURE11 HEX: 84CB ; inline -: GL_TEXTURE12 HEX: 84CC ; inline -: GL_TEXTURE13 HEX: 84CD ; inline -: GL_TEXTURE14 HEX: 84CE ; inline -: GL_TEXTURE15 HEX: 84CF ; inline -: GL_TEXTURE16 HEX: 84D0 ; inline -: GL_TEXTURE17 HEX: 84D1 ; inline -: GL_TEXTURE18 HEX: 84D2 ; inline -: GL_TEXTURE19 HEX: 84D3 ; inline -: GL_TEXTURE20 HEX: 84D4 ; inline -: GL_TEXTURE21 HEX: 84D5 ; inline -: GL_TEXTURE22 HEX: 84D6 ; inline -: GL_TEXTURE23 HEX: 84D7 ; inline -: GL_TEXTURE24 HEX: 84D8 ; inline -: GL_TEXTURE25 HEX: 84D9 ; inline -: GL_TEXTURE26 HEX: 84DA ; inline -: GL_TEXTURE27 HEX: 84DB ; inline -: GL_TEXTURE28 HEX: 84DC ; inline -: GL_TEXTURE29 HEX: 84DD ; inline -: GL_TEXTURE30 HEX: 84DE ; inline -: GL_TEXTURE31 HEX: 84DF ; inline -: GL_NORMAL_MAP HEX: 8511 ; inline -: GL_REFLECTION_MAP HEX: 8512 ; inline -: GL_TEXTURE_CUBE_MAP HEX: 8513 ; inline -: GL_TEXTURE_BINDING_CUBE_MAP HEX: 8514 ; inline -: GL_TEXTURE_CUBE_MAP_POSITIVE_X HEX: 8515 ; inline -: GL_TEXTURE_CUBE_MAP_NEGATIVE_X HEX: 8516 ; inline -: GL_TEXTURE_CUBE_MAP_POSITIVE_Y HEX: 8517 ; inline -: GL_TEXTURE_CUBE_MAP_NEGATIVE_Y HEX: 8518 ; inline -: GL_TEXTURE_CUBE_MAP_POSITIVE_Z HEX: 8519 ; inline -: GL_TEXTURE_CUBE_MAP_NEGATIVE_Z HEX: 851A ; inline -: GL_PROXY_TEXTURE_CUBE_MAP HEX: 851B ; inline -: GL_MAX_CUBE_MAP_TEXTURE_SIZE HEX: 851C ; inline -: GL_COMBINE HEX: 8570 ; inline -: GL_COMBINE_RGB HEX: 8571 ; inline -: GL_COMBINE_ALPHA HEX: 8572 ; inline -: GL_RGB_SCALE HEX: 8573 ; inline -: GL_ADD_SIGNED HEX: 8574 ; inline -: GL_INTERPOLATE HEX: 8575 ; inline -: GL_CONSTANT HEX: 8576 ; inline -: GL_PRIMARY_COLOR HEX: 8577 ; inline -: GL_PREVIOUS HEX: 8578 ; inline -: GL_SOURCE0_RGB HEX: 8580 ; inline -: GL_SOURCE1_RGB HEX: 8581 ; inline -: GL_SOURCE2_RGB HEX: 8582 ; inline -: GL_SOURCE0_ALPHA HEX: 8588 ; inline -: GL_SOURCE1_ALPHA HEX: 8589 ; inline -: GL_SOURCE2_ALPHA HEX: 858A ; inline -: GL_OPERAND0_RGB HEX: 8590 ; inline -: GL_OPERAND1_RGB HEX: 8591 ; inline -: GL_OPERAND2_RGB HEX: 8592 ; inline -: GL_OPERAND0_ALPHA HEX: 8598 ; inline -: GL_OPERAND1_ALPHA HEX: 8599 ; inline -: GL_OPERAND2_ALPHA HEX: 859A ; inline -: GL_SUBTRACT HEX: 84E7 ; inline -: GL_TRANSPOSE_MODELVIEW_MATRIX HEX: 84E3 ; inline -: GL_TRANSPOSE_PROJECTION_MATRIX HEX: 84E4 ; inline -: GL_TRANSPOSE_TEXTURE_MATRIX HEX: 84E5 ; inline -: GL_TRANSPOSE_COLOR_MATRIX HEX: 84E6 ; inline -: GL_COMPRESSED_ALPHA HEX: 84E9 ; inline -: GL_COMPRESSED_LUMINANCE HEX: 84EA ; inline -: GL_COMPRESSED_LUMINANCE_ALPHA HEX: 84EB ; inline -: GL_COMPRESSED_INTENSITY HEX: 84EC ; inline -: GL_COMPRESSED_RGB HEX: 84ED ; inline -: GL_COMPRESSED_RGBA HEX: 84EE ; inline -: GL_TEXTURE_COMPRESSION_HINT HEX: 84EF ; inline -: GL_TEXTURE_COMPRESSED_IMAGE_SIZE HEX: 86A0 ; inline -: GL_TEXTURE_COMPRESSED HEX: 86A1 ; inline + +: GL_MULTISAMPLE HEX: 809D ; inline +: GL_SAMPLE_ALPHA_TO_COVERAGE HEX: 809E ; inline +: GL_SAMPLE_ALPHA_TO_ONE HEX: 809F ; inline +: GL_SAMPLE_COVERAGE HEX: 80A0 ; inline +: GL_SAMPLE_BUFFERS HEX: 80A8 ; inline +: GL_SAMPLES HEX: 80A9 ; inline +: GL_SAMPLE_COVERAGE_VALUE HEX: 80AA ; inline +: GL_SAMPLE_COVERAGE_INVERT HEX: 80AB ; inline +: GL_CLAMP_TO_BORDER HEX: 812D ; inline +: GL_TEXTURE0 HEX: 84C0 ; inline +: GL_TEXTURE1 HEX: 84C1 ; inline +: GL_TEXTURE2 HEX: 84C2 ; inline +: GL_TEXTURE3 HEX: 84C3 ; inline +: GL_TEXTURE4 HEX: 84C4 ; inline +: GL_TEXTURE5 HEX: 84C5 ; inline +: GL_TEXTURE6 HEX: 84C6 ; inline +: GL_TEXTURE7 HEX: 84C7 ; inline +: GL_TEXTURE8 HEX: 84C8 ; inline +: GL_TEXTURE9 HEX: 84C9 ; inline +: GL_TEXTURE10 HEX: 84CA ; inline +: GL_TEXTURE11 HEX: 84CB ; inline +: GL_TEXTURE12 HEX: 84CC ; inline +: GL_TEXTURE13 HEX: 84CD ; inline +: GL_TEXTURE14 HEX: 84CE ; inline +: GL_TEXTURE15 HEX: 84CF ; inline +: GL_TEXTURE16 HEX: 84D0 ; inline +: GL_TEXTURE17 HEX: 84D1 ; inline +: GL_TEXTURE18 HEX: 84D2 ; inline +: GL_TEXTURE19 HEX: 84D3 ; inline +: GL_TEXTURE20 HEX: 84D4 ; inline +: GL_TEXTURE21 HEX: 84D5 ; inline +: GL_TEXTURE22 HEX: 84D6 ; inline +: GL_TEXTURE23 HEX: 84D7 ; inline +: GL_TEXTURE24 HEX: 84D8 ; inline +: GL_TEXTURE25 HEX: 84D9 ; inline +: GL_TEXTURE26 HEX: 84DA ; inline +: GL_TEXTURE27 HEX: 84DB ; inline +: GL_TEXTURE28 HEX: 84DC ; inline +: GL_TEXTURE29 HEX: 84DD ; inline +: GL_TEXTURE30 HEX: 84DE ; inline +: GL_TEXTURE31 HEX: 84DF ; inline +: GL_ACTIVE_TEXTURE HEX: 84E0 ; inline +: GL_CLIENT_ACTIVE_TEXTURE HEX: 84E1 ; inline +: GL_MAX_TEXTURE_UNITS HEX: 84E2 ; inline +: GL_TRANSPOSE_MODELVIEW_MATRIX HEX: 84E3 ; inline +: GL_TRANSPOSE_PROJECTION_MATRIX HEX: 84E4 ; inline +: GL_TRANSPOSE_TEXTURE_MATRIX HEX: 84E5 ; inline +: GL_TRANSPOSE_COLOR_MATRIX HEX: 84E6 ; inline +: GL_SUBTRACT HEX: 84E7 ; inline +: GL_COMPRESSED_ALPHA HEX: 84E9 ; inline +: GL_COMPRESSED_LUMINANCE HEX: 84EA ; inline +: GL_COMPRESSED_LUMINANCE_ALPHA HEX: 84EB ; inline +: GL_COMPRESSED_INTENSITY HEX: 84EC ; inline +: GL_COMPRESSED_RGB HEX: 84ED ; inline +: GL_COMPRESSED_RGBA HEX: 84EE ; inline +: GL_TEXTURE_COMPRESSION_HINT HEX: 84EF ; inline +: GL_NORMAL_MAP HEX: 8511 ; inline +: GL_REFLECTION_MAP HEX: 8512 ; inline +: GL_TEXTURE_CUBE_MAP HEX: 8513 ; inline +: GL_TEXTURE_BINDING_CUBE_MAP HEX: 8514 ; inline +: GL_TEXTURE_CUBE_MAP_POSITIVE_X HEX: 8515 ; inline +: GL_TEXTURE_CUBE_MAP_NEGATIVE_X HEX: 8516 ; inline +: GL_TEXTURE_CUBE_MAP_POSITIVE_Y HEX: 8517 ; inline +: GL_TEXTURE_CUBE_MAP_NEGATIVE_Y HEX: 8518 ; inline +: GL_TEXTURE_CUBE_MAP_POSITIVE_Z HEX: 8519 ; inline +: GL_TEXTURE_CUBE_MAP_NEGATIVE_Z HEX: 851A ; inline +: GL_PROXY_TEXTURE_CUBE_MAP HEX: 851B ; inline +: GL_MAX_CUBE_MAP_TEXTURE_SIZE HEX: 851C ; inline +: GL_COMBINE HEX: 8570 ; inline +: GL_COMBINE_RGB HEX: 8571 ; inline +: GL_COMBINE_ALPHA HEX: 8572 ; inline +: GL_RGB_SCALE HEX: 8573 ; inline +: GL_ADD_SIGNED HEX: 8574 ; inline +: GL_INTERPOLATE HEX: 8575 ; inline +: GL_CONSTANT HEX: 8576 ; inline +: GL_PRIMARY_COLOR HEX: 8577 ; inline +: GL_PREVIOUS HEX: 8578 ; inline +: GL_SOURCE0_RGB HEX: 8580 ; inline +: GL_SOURCE1_RGB HEX: 8581 ; inline +: GL_SOURCE2_RGB HEX: 8582 ; inline +: GL_SOURCE0_ALPHA HEX: 8588 ; inline +: GL_SOURCE1_ALPHA HEX: 8589 ; inline +: GL_SOURCE2_ALPHA HEX: 858A ; inline +: GL_OPERAND0_RGB HEX: 8590 ; inline +: GL_OPERAND1_RGB HEX: 8591 ; inline +: GL_OPERAND2_RGB HEX: 8592 ; inline +: GL_OPERAND0_ALPHA HEX: 8598 ; inline +: GL_OPERAND1_ALPHA HEX: 8599 ; inline +: GL_OPERAND2_ALPHA HEX: 859A ; inline +: GL_TEXTURE_COMPRESSED_IMAGE_SIZE HEX: 86A0 ; inline +: GL_TEXTURE_COMPRESSED HEX: 86A1 ; inline : GL_NUM_COMPRESSED_TEXTURE_FORMATS HEX: 86A2 ; inline -: GL_COMPRESSED_TEXTURE_FORMATS HEX: 86A3 ; inline -: GL_DOT3_RGB HEX: 86AE ; inline -: GL_DOT3_RGBA HEX: 86AF ; inline -: GL_CLAMP_TO_BORDER HEX: 812D ; inline -: GL_MULTISAMPLE HEX: 809D ; inline -: GL_SAMPLE_ALPHA_TO_COVERAGE HEX: 809E ; inline -: GL_SAMPLE_ALPHA_TO_ONE HEX: 809F ; inline -: GL_SAMPLE_COVERAGE HEX: 80A0 ; inline -: GL_SAMPLE_BUFFERS HEX: 80A8 ; inline -: GL_SAMPLES HEX: 80A9 ; inline -: GL_SAMPLE_COVERAGE_VALUE HEX: 80AA ; inline -: GL_SAMPLE_COVERAGE_INVERT HEX: 80AB ; inline -: GL_MULTISAMPLE_BIT HEX: 20000000 ; inline +: GL_COMPRESSED_TEXTURE_FORMATS HEX: 86A3 ; inline +: GL_DOT3_RGB HEX: 86AE ; inline +: GL_DOT3_RGBA HEX: 86AF ; inline +: GL_MULTISAMPLE_BIT HEX: 20000000 ; inline + +GL-FUNCTION: void glActiveTexture ( GLenum texture ) ; +GL-FUNCTION: void glClientActiveTexture ( GLenum texture ) ; +GL-FUNCTION: void glCompressedTexImage1D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLint border, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glCompressedTexImage2D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLint border, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glCompressedTexImage3D ( GLenum target, GLint level, GLenum internalformat, GLsizei width, GLsizei height, GLsizei depth, GLint border, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glCompressedTexSubImage1D ( GLenum target, GLint level, GLint xoffset, GLsizei width, GLenum format, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glCompressedTexSubImage2D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLsizei width, GLsizei height, GLenum format, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glCompressedTexSubImage3D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLsizei imageSize, GLvoid* data ) ; +GL-FUNCTION: void glGetCompressedTexImage ( GLenum target, GLint lod, GLvoid* img ) ; +GL-FUNCTION: void glLoadTransposeMatrixd ( GLdouble m[16] ) ; +GL-FUNCTION: void glLoadTransposeMatrixf ( GLfloat m[16] ) ; +GL-FUNCTION: void glMultTransposeMatrixd ( GLdouble m[16] ) ; +GL-FUNCTION: void glMultTransposeMatrixf ( GLfloat m[16] ) ; +GL-FUNCTION: void glMultiTexCoord1d ( GLenum target, GLdouble s ) ; +GL-FUNCTION: void glMultiTexCoord1dv ( GLenum target, GLdouble* v ) ; +GL-FUNCTION: void glMultiTexCoord1f ( GLenum target, GLfloat s ) ; +GL-FUNCTION: void glMultiTexCoord1fv ( GLenum target, GLfloat* v ) ; +GL-FUNCTION: void glMultiTexCoord1i ( GLenum target, GLint s ) ; +GL-FUNCTION: void glMultiTexCoord1iv ( GLenum target, GLint* v ) ; +GL-FUNCTION: void glMultiTexCoord1s ( GLenum target, GLshort s ) ; +GL-FUNCTION: void glMultiTexCoord1sv ( GLenum target, GLshort* v ) ; +GL-FUNCTION: void glMultiTexCoord2d ( GLenum target, GLdouble s, GLdouble t ) ; +GL-FUNCTION: void glMultiTexCoord2dv ( GLenum target, GLdouble* v ) ; +GL-FUNCTION: void glMultiTexCoord2f ( GLenum target, GLfloat s, GLfloat t ) ; +GL-FUNCTION: void glMultiTexCoord2fv ( GLenum target, GLfloat* v ) ; +GL-FUNCTION: void glMultiTexCoord2i ( GLenum target, GLint s, GLint t ) ; +GL-FUNCTION: void glMultiTexCoord2iv ( GLenum target, GLint* v ) ; +GL-FUNCTION: void glMultiTexCoord2s ( GLenum target, GLshort s, GLshort t ) ; +GL-FUNCTION: void glMultiTexCoord2sv ( GLenum target, GLshort* v ) ; +GL-FUNCTION: void glMultiTexCoord3d ( GLenum target, GLdouble s, GLdouble t, GLdouble r ) ; +GL-FUNCTION: void glMultiTexCoord3dv ( GLenum target, GLdouble* v ) ; +GL-FUNCTION: void glMultiTexCoord3f ( GLenum target, GLfloat s, GLfloat t, GLfloat r ) ; +GL-FUNCTION: void glMultiTexCoord3fv ( GLenum target, GLfloat* v ) ; +GL-FUNCTION: void glMultiTexCoord3i ( GLenum target, GLint s, GLint t, GLint r ) ; +GL-FUNCTION: void glMultiTexCoord3iv ( GLenum target, GLint* v ) ; +GL-FUNCTION: void glMultiTexCoord3s ( GLenum target, GLshort s, GLshort t, GLshort r ) ; +GL-FUNCTION: void glMultiTexCoord3sv ( GLenum target, GLshort* v ) ; +GL-FUNCTION: void glMultiTexCoord4d ( GLenum target, GLdouble s, GLdouble t, GLdouble r, GLdouble q ) ; +GL-FUNCTION: void glMultiTexCoord4dv ( GLenum target, GLdouble* v ) ; +GL-FUNCTION: void glMultiTexCoord4f ( GLenum target, GLfloat s, GLfloat t, GLfloat r, GLfloat q ) ; +GL-FUNCTION: void glMultiTexCoord4fv ( GLenum target, GLfloat* v ) ; +GL-FUNCTION: void glMultiTexCoord4i ( GLenum target, GLint s, GLint t, GLint r, GLint q ) ; +GL-FUNCTION: void glMultiTexCoord4iv ( GLenum target, GLint* v ) ; +GL-FUNCTION: void glMultiTexCoord4s ( GLenum target, GLshort s, GLshort t, GLshort r, GLshort q ) ; +GL-FUNCTION: void glMultiTexCoord4sv ( GLenum target, GLshort* v ) ; +GL-FUNCTION: void glSampleCoverage ( GLclampf value, GLboolean invert ) ; ! OpenGL 1.4 -: GL_POINT_SIZE_MIN HEX: 8126 ; inline -: GL_POINT_SIZE_MAX HEX: 8127 ; inline -: GL_POINT_FADE_THRESHOLD_SIZE HEX: 8128 ; inline -: GL_POINT_DISTANCE_ATTENUATION HEX: 8129 ; inline -: GL_FOG_COORDINATE_SOURCE HEX: 8450 ; inline -: GL_FOG_COORDINATE HEX: 8451 ; inline -: GL_FRAGMENT_DEPTH HEX: 8452 ; inline -: GL_CURRENT_FOG_COORDINATE HEX: 8453 ; inline -: GL_FOG_COORDINATE_ARRAY_TYPE HEX: 8454 ; inline -: GL_FOG_COORDINATE_ARRAY_STRIDE HEX: 8455 ; inline -: GL_FOG_COORDINATE_ARRAY_POINTER HEX: 8456 ; inline -: GL_FOG_COORDINATE_ARRAY HEX: 8457 ; inline -: GL_COLOR_SUM HEX: 8458 ; inline -: GL_CURRENT_SECONDARY_COLOR HEX: 8459 ; inline -: GL_SECONDARY_COLOR_ARRAY_SIZE HEX: 845A ; inline -: GL_SECONDARY_COLOR_ARRAY_TYPE HEX: 845B ; inline -: GL_SECONDARY_COLOR_ARRAY_STRIDE HEX: 845C ; inline -: GL_SECONDARY_COLOR_ARRAY_POINTER HEX: 845D ; inline -: GL_SECONDARY_COLOR_ARRAY HEX: 845E ; inline -: GL_INCR_WRAP HEX: 8507 ; inline -: GL_DECR_WRAP HEX: 8508 ; inline -: GL_MAX_TEXTURE_LOD_BIAS HEX: 84FD ; inline -: GL_TEXTURE_FILTER_CONTROL HEX: 8500 ; inline -: GL_TEXTURE_LOD_BIAS HEX: 8501 ; inline -: GL_GENERATE_MIPMAP HEX: 8191 ; inline -: GL_GENERATE_MIPMAP_HINT HEX: 8192 ; inline -: GL_BLEND_DST_RGB HEX: 80C8 ; inline -: GL_BLEND_SRC_RGB HEX: 80C9 ; inline -: GL_BLEND_DST_ALPHA HEX: 80CA ; inline -: GL_BLEND_SRC_ALPHA HEX: 80CB ; inline -: GL_MIRRORED_REPEAT HEX: 8370 ; inline -: GL_DEPTH_COMPONENT16 HEX: 81A5 ; inline -: GL_DEPTH_COMPONENT24 HEX: 81A6 ; inline -: GL_DEPTH_COMPONENT32 HEX: 81A7 ; inline -: GL_TEXTURE_DEPTH_SIZE HEX: 884A ; inline -: GL_DEPTH_TEXTURE_MODE HEX: 884B ; inline -: GL_TEXTURE_COMPARE_MODE HEX: 884C ; inline -: GL_TEXTURE_COMPARE_FUNC HEX: 884D ; inline -: GL_COMPARE_R_TO_TEXTURE HEX: 884E ; inline + +: GL_BLEND_DST_RGB HEX: 80C8 ; inline +: GL_BLEND_SRC_RGB HEX: 80C9 ; inline +: GL_BLEND_DST_ALPHA HEX: 80CA ; inline +: GL_BLEND_SRC_ALPHA HEX: 80CB ; inline +: GL_POINT_SIZE_MIN HEX: 8126 ; inline +: GL_POINT_SIZE_MAX HEX: 8127 ; inline +: GL_POINT_FADE_THRESHOLD_SIZE HEX: 8128 ; inline +: GL_POINT_DISTANCE_ATTENUATION HEX: 8129 ; inline +: GL_GENERATE_MIPMAP HEX: 8191 ; inline +: GL_GENERATE_MIPMAP_HINT HEX: 8192 ; inline +: GL_DEPTH_COMPONENT16 HEX: 81A5 ; inline +: GL_DEPTH_COMPONENT24 HEX: 81A6 ; inline +: GL_DEPTH_COMPONENT32 HEX: 81A7 ; inline +: GL_MIRRORED_REPEAT HEX: 8370 ; inline +: GL_FOG_COORDINATE_SOURCE HEX: 8450 ; inline +: GL_FOG_COORDINATE HEX: 8451 ; inline +: GL_FRAGMENT_DEPTH HEX: 8452 ; inline +: GL_CURRENT_FOG_COORDINATE HEX: 8453 ; inline +: GL_FOG_COORDINATE_ARRAY_TYPE HEX: 8454 ; inline +: GL_FOG_COORDINATE_ARRAY_STRIDE HEX: 8455 ; inline +: GL_FOG_COORDINATE_ARRAY_POINTER HEX: 8456 ; inline +: GL_FOG_COORDINATE_ARRAY HEX: 8457 ; inline +: GL_COLOR_SUM HEX: 8458 ; inline +: GL_CURRENT_SECONDARY_COLOR HEX: 8459 ; inline +: GL_SECONDARY_COLOR_ARRAY_SIZE HEX: 845A ; inline +: GL_SECONDARY_COLOR_ARRAY_TYPE HEX: 845B ; inline +: GL_SECONDARY_COLOR_ARRAY_STRIDE HEX: 845C ; inline +: GL_SECONDARY_COLOR_ARRAY_POINTER HEX: 845D ; inline +: GL_SECONDARY_COLOR_ARRAY HEX: 845E ; inline +: GL_MAX_TEXTURE_LOD_BIAS HEX: 84FD ; inline +: GL_TEXTURE_FILTER_CONTROL HEX: 8500 ; inline +: GL_TEXTURE_LOD_BIAS HEX: 8501 ; inline +: GL_INCR_WRAP HEX: 8507 ; inline +: GL_DECR_WRAP HEX: 8508 ; inline +: GL_TEXTURE_DEPTH_SIZE HEX: 884A ; inline +: GL_DEPTH_TEXTURE_MODE HEX: 884B ; inline +: GL_TEXTURE_COMPARE_MODE HEX: 884C ; inline +: GL_TEXTURE_COMPARE_FUNC HEX: 884D ; inline +: GL_COMPARE_R_TO_TEXTURE HEX: 884E ; inline + +GL-FUNCTION: void glBlendColor ( GLclampf red, GLclampf green, GLclampf blue, GLclampf alpha ) ; +GL-FUNCTION: void glBlendEquation ( GLenum mode ) ; +GL-FUNCTION: void glBlendFuncSeparate ( GLenum sfactorRGB, GLenum dfactorRGB, GLenum sfactorAlpha, GLenum dfactorAlpha ) ; +GL-FUNCTION: void glFogCoordPointer ( GLenum type, GLsizei stride, GLvoid* pointer ) ; +GL-FUNCTION: void glFogCoordd ( GLdouble coord ) ; +GL-FUNCTION: void glFogCoorddv ( GLdouble* coord ) ; +GL-FUNCTION: void glFogCoordf ( GLfloat coord ) ; +GL-FUNCTION: void glFogCoordfv ( GLfloat* coord ) ; +GL-FUNCTION: void glMultiDrawArrays ( GLenum mode, GLint* first, GLsizei* count, GLsizei primcount ) ; +GL-FUNCTION: void glMultiDrawElements ( GLenum mode, GLsizei* count, GLenum type, GLvoid** indices, GLsizei primcount ) ; +GL-FUNCTION: void glPointParameterf ( GLenum pname, GLfloat param ) ; +GL-FUNCTION: void glPointParameterfv ( GLenum pname, GLfloat* params ) ; +GL-FUNCTION: void glSecondaryColor3b ( GLbyte red, GLbyte green, GLbyte blue ) ; +GL-FUNCTION: void glSecondaryColor3bv ( GLbyte* v ) ; +GL-FUNCTION: void glSecondaryColor3d ( GLdouble red, GLdouble green, GLdouble blue ) ; +GL-FUNCTION: void glSecondaryColor3dv ( GLdouble* v ) ; +GL-FUNCTION: void glSecondaryColor3f ( GLfloat red, GLfloat green, GLfloat blue ) ; +GL-FUNCTION: void glSecondaryColor3fv ( GLfloat* v ) ; +GL-FUNCTION: void glSecondaryColor3i ( GLint red, GLint green, GLint blue ) ; +GL-FUNCTION: void glSecondaryColor3iv ( GLint* v ) ; +GL-FUNCTION: void glSecondaryColor3s ( GLshort red, GLshort green, GLshort blue ) ; +GL-FUNCTION: void glSecondaryColor3sv ( GLshort* v ) ; +GL-FUNCTION: void glSecondaryColor3ub ( GLubyte red, GLubyte green, GLubyte blue ) ; +GL-FUNCTION: void glSecondaryColor3ubv ( GLubyte* v ) ; +GL-FUNCTION: void glSecondaryColor3ui ( GLuint red, GLuint green, GLuint blue ) ; +GL-FUNCTION: void glSecondaryColor3uiv ( GLuint* v ) ; +GL-FUNCTION: void glSecondaryColor3us ( GLushort red, GLushort green, GLushort blue ) ; +GL-FUNCTION: void glSecondaryColor3usv ( GLushort* v ) ; +GL-FUNCTION: void glSecondaryColorPointer ( GLint size, GLenum type, GLsizei stride, GLvoid* pointer ) ; +GL-FUNCTION: void glWindowPos2d ( GLdouble x, GLdouble y ) ; +GL-FUNCTION: void glWindowPos2dv ( GLdouble* p ) ; +GL-FUNCTION: void glWindowPos2f ( GLfloat x, GLfloat y ) ; +GL-FUNCTION: void glWindowPos2fv ( GLfloat* p ) ; +GL-FUNCTION: void glWindowPos2i ( GLint x, GLint y ) ; +GL-FUNCTION: void glWindowPos2iv ( GLint* p ) ; +GL-FUNCTION: void glWindowPos2s ( GLshort x, GLshort y ) ; +GL-FUNCTION: void glWindowPos2sv ( GLshort* p ) ; +GL-FUNCTION: void glWindowPos3d ( GLdouble x, GLdouble y, GLdouble z ) ; +GL-FUNCTION: void glWindowPos3dv ( GLdouble* p ) ; +GL-FUNCTION: void glWindowPos3f ( GLfloat x, GLfloat y, GLfloat z ) ; +GL-FUNCTION: void glWindowPos3fv ( GLfloat* p ) ; +GL-FUNCTION: void glWindowPos3i ( GLint x, GLint y, GLint z ) ; +GL-FUNCTION: void glWindowPos3iv ( GLint* p ) ; +GL-FUNCTION: void glWindowPos3s ( GLshort x, GLshort y, GLshort z ) ; +GL-FUNCTION: void glWindowPos3sv ( GLshort* p ) ; + + +! OpenGL 1.5 + +: GL_BUFFER_SIZE HEX: 8764 ; inline +: GL_BUFFER_USAGE HEX: 8765 ; inline +: GL_QUERY_COUNTER_BITS HEX: 8864 ; inline +: GL_CURRENT_QUERY HEX: 8865 ; inline +: GL_QUERY_RESULT HEX: 8866 ; inline +: GL_QUERY_RESULT_AVAILABLE HEX: 8867 ; inline +: GL_ARRAY_BUFFER HEX: 8892 ; inline +: GL_ELEMENT_ARRAY_BUFFER HEX: 8893 ; inline +: GL_ARRAY_BUFFER_BINDING HEX: 8894 ; inline +: GL_ELEMENT_ARRAY_BUFFER_BINDING HEX: 8895 ; inline +: GL_VERTEX_ARRAY_BUFFER_BINDING HEX: 8896 ; inline +: GL_NORMAL_ARRAY_BUFFER_BINDING HEX: 8897 ; inline +: GL_COLOR_ARRAY_BUFFER_BINDING HEX: 8898 ; inline +: GL_INDEX_ARRAY_BUFFER_BINDING HEX: 8899 ; inline +: GL_TEXTURE_COORD_ARRAY_BUFFER_BINDING HEX: 889A ; inline +: GL_EDGE_FLAG_ARRAY_BUFFER_BINDING HEX: 889B ; inline +: GL_SECONDARY_COLOR_ARRAY_BUFFER_BINDING HEX: 889C ; inline +: GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING HEX: 889D ; inline +: GL_WEIGHT_ARRAY_BUFFER_BINDING HEX: 889E ; inline +: GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING HEX: 889F ; inline +: GL_READ_ONLY HEX: 88B8 ; inline +: GL_WRITE_ONLY HEX: 88B9 ; inline +: GL_READ_WRITE HEX: 88BA ; inline +: GL_BUFFER_ACCESS HEX: 88BB ; inline +: GL_BUFFER_MAPPED HEX: 88BC ; inline +: GL_BUFFER_MAP_POINTER HEX: 88BD ; inline +: GL_STREAM_DRAW HEX: 88E0 ; inline +: GL_STREAM_READ HEX: 88E1 ; inline +: GL_STREAM_COPY HEX: 88E2 ; inline +: GL_STATIC_DRAW HEX: 88E4 ; inline +: GL_STATIC_READ HEX: 88E5 ; inline +: GL_STATIC_COPY HEX: 88E6 ; inline +: GL_DYNAMIC_DRAW HEX: 88E8 ; inline +: GL_DYNAMIC_READ HEX: 88E9 ; inline +: GL_DYNAMIC_COPY HEX: 88EA ; inline +: GL_SAMPLES_PASSED HEX: 8914 ; inline +: GL_FOG_COORD_SRC GL_FOG_COORDINATE_SOURCE ; inline +: GL_FOG_COORD GL_FOG_COORDINATE ; inline +: GL_FOG_COORD_ARRAY GL_FOG_COORDINATE_ARRAY ; inline +: GL_SRC0_RGB GL_SOURCE0_RGB ; inline +: GL_FOG_COORD_ARRAY_POINTER GL_FOG_COORDINATE_ARRAY_POINTER ; inline +: GL_FOG_COORD_ARRAY_TYPE GL_FOG_COORDINATE_ARRAY_TYPE ; inline +: GL_SRC1_ALPHA GL_SOURCE1_ALPHA ; inline +: GL_CURRENT_FOG_COORD GL_CURRENT_FOG_COORDINATE ; inline +: GL_FOG_COORD_ARRAY_STRIDE GL_FOG_COORDINATE_ARRAY_STRIDE ; inline +: GL_SRC0_ALPHA GL_SOURCE0_ALPHA ; inline +: GL_SRC1_RGB GL_SOURCE1_RGB ; inline +: GL_FOG_COORD_ARRAY_BUFFER_BINDING GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING ; inline +: GL_SRC2_ALPHA GL_SOURCE2_ALPHA ; inline +: GL_SRC2_RGB GL_SOURCE2_RGB ; inline + +TYPEDEF: ptrdiff_t GLsizeiptr +TYPEDEF: ptrdiff_t GLintptr + +GL-FUNCTION: void glBeginQuery ( GLenum target, GLuint id ) ; +GL-FUNCTION: void glBindBuffer ( GLenum target, GLuint buffer ) ; +GL-FUNCTION: void glBufferData ( GLenum target, GLsizeiptr size, GLvoid* data, GLenum usage ) ; +GL-FUNCTION: void glBufferSubData ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ; +GL-FUNCTION: void glDeleteBuffers ( GLsizei n, GLuint* buffers ) ; +GL-FUNCTION: void glDeleteQueries ( GLsizei n, GLuint* ids ) ; +GL-FUNCTION: void glEndQuery ( GLenum target ) ; +GL-FUNCTION: void glGenBuffers ( GLsizei n, GLuint* buffers ) ; +GL-FUNCTION: void glGenQueries ( GLsizei n, GLuint* ids ) ; +GL-FUNCTION: void glGetBufferParameteriv ( GLenum target, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glGetBufferPointerv ( GLenum target, GLenum pname, GLvoid** params ) ; +GL-FUNCTION: void glGetBufferSubData ( GLenum target, GLintptr offset, GLsizeiptr size, GLvoid* data ) ; +GL-FUNCTION: void glGetQueryObjectiv ( GLuint id, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glGetQueryObjectuiv ( GLuint id, GLenum pname, GLuint* params ) ; +GL-FUNCTION: void glGetQueryiv ( GLenum target, GLenum pname, GLint* params ) ; +GL-FUNCTION: GLboolean glIsBuffer ( GLuint buffer ) ; +GL-FUNCTION: GLboolean glIsQuery ( GLuint id ) ; +GL-FUNCTION: GLvoid* glMapBuffer ( GLenum target, GLenum access ) ; +GL-FUNCTION: GLboolean glUnmapBuffer ( GLenum target ) ; + + +! OpenGL 2.0 + + +: GL_VERTEX_ATTRIB_ARRAY_ENABLED HEX: 8622 ; inline +: GL_VERTEX_ATTRIB_ARRAY_SIZE HEX: 8623 ; inline +: GL_VERTEX_ATTRIB_ARRAY_STRIDE HEX: 8624 ; inline +: GL_VERTEX_ATTRIB_ARRAY_TYPE HEX: 8625 ; inline +: GL_CURRENT_VERTEX_ATTRIB HEX: 8626 ; inline +: GL_VERTEX_PROGRAM_POINT_SIZE HEX: 8642 ; inline +: GL_VERTEX_PROGRAM_TWO_SIDE HEX: 8643 ; inline +: GL_VERTEX_ATTRIB_ARRAY_POINTER HEX: 8645 ; inline +: GL_STENCIL_BACK_FUNC HEX: 8800 ; inline +: GL_STENCIL_BACK_FAIL HEX: 8801 ; inline +: GL_STENCIL_BACK_PASS_DEPTH_FAIL HEX: 8802 ; inline +: GL_STENCIL_BACK_PASS_DEPTH_PASS HEX: 8803 ; inline +: GL_MAX_DRAW_BUFFERS HEX: 8824 ; inline +: GL_DRAW_BUFFER0 HEX: 8825 ; inline +: GL_DRAW_BUFFER1 HEX: 8826 ; inline +: GL_DRAW_BUFFER2 HEX: 8827 ; inline +: GL_DRAW_BUFFER3 HEX: 8828 ; inline +: GL_DRAW_BUFFER4 HEX: 8829 ; inline +: GL_DRAW_BUFFER5 HEX: 882A ; inline +: GL_DRAW_BUFFER6 HEX: 882B ; inline +: GL_DRAW_BUFFER7 HEX: 882C ; inline +: GL_DRAW_BUFFER8 HEX: 882D ; inline +: GL_DRAW_BUFFER9 HEX: 882E ; inline +: GL_DRAW_BUFFER10 HEX: 882F ; inline +: GL_DRAW_BUFFER11 HEX: 8830 ; inline +: GL_DRAW_BUFFER12 HEX: 8831 ; inline +: GL_DRAW_BUFFER13 HEX: 8832 ; inline +: GL_DRAW_BUFFER14 HEX: 8833 ; inline +: GL_DRAW_BUFFER15 HEX: 8834 ; inline +: GL_BLEND_EQUATION_ALPHA HEX: 883D ; inline +: GL_POINT_SPRITE HEX: 8861 ; inline +: GL_COORD_REPLACE HEX: 8862 ; inline +: GL_MAX_VERTEX_ATTRIBS HEX: 8869 ; inline +: GL_VERTEX_ATTRIB_ARRAY_NORMALIZED HEX: 886A ; inline +: GL_MAX_TEXTURE_COORDS HEX: 8871 ; inline +: GL_MAX_TEXTURE_IMAGE_UNITS HEX: 8872 ; inline +: GL_FRAGMENT_SHADER HEX: 8B30 ; inline +: GL_VERTEX_SHADER HEX: 8B31 ; inline +: GL_MAX_FRAGMENT_UNIFORM_COMPONENTS HEX: 8B49 ; inline +: GL_MAX_VERTEX_UNIFORM_COMPONENTS HEX: 8B4A ; inline +: GL_MAX_VARYING_FLOATS HEX: 8B4B ; inline +: GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS HEX: 8B4C ; inline +: GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS HEX: 8B4D ; inline +: GL_SHADER_TYPE HEX: 8B4F ; inline +: GL_FLOAT_VEC2 HEX: 8B50 ; inline +: GL_FLOAT_VEC3 HEX: 8B51 ; inline +: GL_FLOAT_VEC4 HEX: 8B52 ; inline +: GL_INT_VEC2 HEX: 8B53 ; inline +: GL_INT_VEC3 HEX: 8B54 ; inline +: GL_INT_VEC4 HEX: 8B55 ; inline +: GL_BOOL HEX: 8B56 ; inline +: GL_BOOL_VEC2 HEX: 8B57 ; inline +: GL_BOOL_VEC3 HEX: 8B58 ; inline +: GL_BOOL_VEC4 HEX: 8B59 ; inline +: GL_FLOAT_MAT2 HEX: 8B5A ; inline +: GL_FLOAT_MAT3 HEX: 8B5B ; inline +: GL_FLOAT_MAT4 HEX: 8B5C ; inline +: GL_SAMPLER_1D HEX: 8B5D ; inline +: GL_SAMPLER_2D HEX: 8B5E ; inline +: GL_SAMPLER_3D HEX: 8B5F ; inline +: GL_SAMPLER_CUBE HEX: 8B60 ; inline +: GL_SAMPLER_1D_SHADOW HEX: 8B61 ; inline +: GL_SAMPLER_2D_SHADOW HEX: 8B62 ; inline +: GL_DELETE_STATUS HEX: 8B80 ; inline +: GL_COMPILE_STATUS HEX: 8B81 ; inline +: GL_LINK_STATUS HEX: 8B82 ; inline +: GL_VALIDATE_STATUS HEX: 8B83 ; inline +: GL_INFO_LOG_LENGTH HEX: 8B84 ; inline +: GL_ATTACHED_SHADERS HEX: 8B85 ; inline +: GL_ACTIVE_UNIFORMS HEX: 8B86 ; inline +: GL_ACTIVE_UNIFORM_MAX_LENGTH HEX: 8B87 ; inline +: GL_SHADER_SOURCE_LENGTH HEX: 8B88 ; inline +: GL_ACTIVE_ATTRIBUTES HEX: 8B89 ; inline +: GL_ACTIVE_ATTRIBUTE_MAX_LENGTH HEX: 8B8A ; inline +: GL_FRAGMENT_SHADER_DERIVATIVE_HINT HEX: 8B8B ; inline +: GL_SHADING_LANGUAGE_VERSION HEX: 8B8C ; inline +: GL_CURRENT_PROGRAM HEX: 8B8D ; inline +: GL_POINT_SPRITE_COORD_ORIGIN HEX: 8CA0 ; inline +: GL_LOWER_LEFT HEX: 8CA1 ; inline +: GL_UPPER_LEFT HEX: 8CA2 ; inline +: GL_STENCIL_BACK_REF HEX: 8CA3 ; inline +: GL_STENCIL_BACK_VALUE_MASK HEX: 8CA4 ; inline +: GL_STENCIL_BACK_WRITEMASK HEX: 8CA5 ; inline +: GL_BLEND_EQUATION HEX: 8009 ; inline +: GL_BLEND_EQUATION_RGB GL_BLEND_EQUATION ; inline + +TYPEDEF: char GLchar + +GL-FUNCTION: void glAttachShader ( GLuint program, GLuint shader ) ; +GL-FUNCTION: void glBindAttribLocation ( GLuint program, GLuint index, GLchar* name ) ; +GL-FUNCTION: void glBlendEquationSeparate ( GLenum modeRGB, GLenum modeAlpha ) ; +GL-FUNCTION: void glCompileShader ( GLuint shader ) ; +GL-FUNCTION: GLuint glCreateProgram ( ) ; +GL-FUNCTION: GLuint glCreateShader ( GLenum type ) ; +GL-FUNCTION: void glDeleteProgram ( GLuint program ) ; +GL-FUNCTION: void glDeleteShader ( GLuint shader ) ; +GL-FUNCTION: void glDetachShader ( GLuint program, GLuint shader ) ; +GL-FUNCTION: void glDisableVertexAttribArray ( GLuint index ) ; +GL-FUNCTION: void glDrawBuffers ( GLsizei n, GLenum* bufs ) ; +GL-FUNCTION: void glEnableVertexAttribArray ( GLuint index ) ; +GL-FUNCTION: void glGetActiveAttrib ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ; +GL-FUNCTION: void glGetActiveUniform ( GLuint program, GLuint index, GLsizei maxLength, GLsizei* length, GLint* size, GLenum* type, GLchar* name ) ; +GL-FUNCTION: void glGetAttachedShaders ( GLuint program, GLsizei maxCount, GLsizei* count, GLuint* shaders ) ; +GL-FUNCTION: GLint glGetAttribLocation ( GLuint program, GLchar* name ) ; +GL-FUNCTION: void glGetProgramInfoLog ( GLuint program, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ; +GL-FUNCTION: void glGetProgramiv ( GLuint program, GLenum pname, GLint* param ) ; +GL-FUNCTION: void glGetShaderInfoLog ( GLuint shader, GLsizei bufSize, GLsizei* length, GLchar* infoLog ) ; +GL-FUNCTION: void glGetShaderSource ( GLint obj, GLsizei maxLength, GLsizei* length, GLchar* source ) ; +GL-FUNCTION: void glGetShaderiv ( GLuint shader, GLenum pname, GLint* param ) ; +GL-FUNCTION: GLint glGetUniformLocation ( GLint programObj, GLchar* name ) ; +GL-FUNCTION: void glGetUniformfv ( GLuint program, GLint location, GLfloat* params ) ; +GL-FUNCTION: void glGetUniformiv ( GLuint program, GLint location, GLint* params ) ; +GL-FUNCTION: void glGetVertexAttribPointerv ( GLuint index, GLenum pname, GLvoid** pointer ) ; +GL-FUNCTION: void glGetVertexAttribdv ( GLuint index, GLenum pname, GLdouble* params ) ; +GL-FUNCTION: void glGetVertexAttribfv ( GLuint index, GLenum pname, GLfloat* params ) ; +GL-FUNCTION: void glGetVertexAttribiv ( GLuint index, GLenum pname, GLint* params ) ; +GL-FUNCTION: GLboolean glIsProgram ( GLuint program ) ; +GL-FUNCTION: GLboolean glIsShader ( GLuint shader ) ; +GL-FUNCTION: void glLinkProgram ( GLuint program ) ; +GL-FUNCTION: void glShaderSource ( GLuint shader, GLsizei count, GLchar** strings, GLint* lengths ) ; +GL-FUNCTION: void glStencilFuncSeparate ( GLenum frontfunc, GLenum backfunc, GLint ref, GLuint mask ) ; +GL-FUNCTION: void glStencilMaskSeparate ( GLenum face, GLuint mask ) ; +GL-FUNCTION: void glStencilOpSeparate ( GLenum face, GLenum sfail, GLenum dpfail, GLenum dppass ) ; +GL-FUNCTION: void glUniform1f ( GLint location, GLfloat v0 ) ; +GL-FUNCTION: void glUniform1fv ( GLint location, GLsizei count, GLfloat* value ) ; +GL-FUNCTION: void glUniform1i ( GLint location, GLint v0 ) ; +GL-FUNCTION: void glUniform1iv ( GLint location, GLsizei count, GLint* value ) ; +GL-FUNCTION: void glUniform2f ( GLint location, GLfloat v0, GLfloat v1 ) ; +GL-FUNCTION: void glUniform2fv ( GLint location, GLsizei count, GLfloat* value ) ; +GL-FUNCTION: void glUniform2i ( GLint location, GLint v0, GLint v1 ) ; +GL-FUNCTION: void glUniform2iv ( GLint location, GLsizei count, GLint* value ) ; +GL-FUNCTION: void glUniform3f ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2 ) ; +GL-FUNCTION: void glUniform3fv ( GLint location, GLsizei count, GLfloat* value ) ; +GL-FUNCTION: void glUniform3i ( GLint location, GLint v0, GLint v1, GLint v2 ) ; +GL-FUNCTION: void glUniform3iv ( GLint location, GLsizei count, GLint* value ) ; +GL-FUNCTION: void glUniform4f ( GLint location, GLfloat v0, GLfloat v1, GLfloat v2, GLfloat v3 ) ; +GL-FUNCTION: void glUniform4fv ( GLint location, GLsizei count, GLfloat* value ) ; +GL-FUNCTION: void glUniform4i ( GLint location, GLint v0, GLint v1, GLint v2, GLint v3 ) ; +GL-FUNCTION: void glUniform4iv ( GLint location, GLsizei count, GLint* value ) ; +GL-FUNCTION: void glUniformMatrix2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUseProgram ( GLuint program ) ; +GL-FUNCTION: void glValidateProgram ( GLuint program ) ; +GL-FUNCTION: void glVertexAttrib1d ( GLuint index, GLdouble x ) ; +GL-FUNCTION: void glVertexAttrib1dv ( GLuint index, GLdouble* v ) ; +GL-FUNCTION: void glVertexAttrib1f ( GLuint index, GLfloat x ) ; +GL-FUNCTION: void glVertexAttrib1fv ( GLuint index, GLfloat* v ) ; +GL-FUNCTION: void glVertexAttrib1s ( GLuint index, GLshort x ) ; +GL-FUNCTION: void glVertexAttrib1sv ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttrib2d ( GLuint index, GLdouble x, GLdouble y ) ; +GL-FUNCTION: void glVertexAttrib2dv ( GLuint index, GLdouble* v ) ; +GL-FUNCTION: void glVertexAttrib2f ( GLuint index, GLfloat x, GLfloat y ) ; +GL-FUNCTION: void glVertexAttrib2fv ( GLuint index, GLfloat* v ) ; +GL-FUNCTION: void glVertexAttrib2s ( GLuint index, GLshort x, GLshort y ) ; +GL-FUNCTION: void glVertexAttrib2sv ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttrib3d ( GLuint index, GLdouble x, GLdouble y, GLdouble z ) ; +GL-FUNCTION: void glVertexAttrib3dv ( GLuint index, GLdouble* v ) ; +GL-FUNCTION: void glVertexAttrib3f ( GLuint index, GLfloat x, GLfloat y, GLfloat z ) ; +GL-FUNCTION: void glVertexAttrib3fv ( GLuint index, GLfloat* v ) ; +GL-FUNCTION: void glVertexAttrib3s ( GLuint index, GLshort x, GLshort y, GLshort z ) ; +GL-FUNCTION: void glVertexAttrib3sv ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttrib4Nbv ( GLuint index, GLbyte* v ) ; +GL-FUNCTION: void glVertexAttrib4Niv ( GLuint index, GLint* v ) ; +GL-FUNCTION: void glVertexAttrib4Nsv ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttrib4Nub ( GLuint index, GLubyte x, GLubyte y, GLubyte z, GLubyte w ) ; +GL-FUNCTION: void glVertexAttrib4Nubv ( GLuint index, GLubyte* v ) ; +GL-FUNCTION: void glVertexAttrib4Nuiv ( GLuint index, GLuint* v ) ; +GL-FUNCTION: void glVertexAttrib4Nusv ( GLuint index, GLushort* v ) ; +GL-FUNCTION: void glVertexAttrib4bv ( GLuint index, GLbyte* v ) ; +GL-FUNCTION: void glVertexAttrib4d ( GLuint index, GLdouble x, GLdouble y, GLdouble z, GLdouble w ) ; +GL-FUNCTION: void glVertexAttrib4dv ( GLuint index, GLdouble* v ) ; +GL-FUNCTION: void glVertexAttrib4f ( GLuint index, GLfloat x, GLfloat y, GLfloat z, GLfloat w ) ; +GL-FUNCTION: void glVertexAttrib4fv ( GLuint index, GLfloat* v ) ; +GL-FUNCTION: void glVertexAttrib4iv ( GLuint index, GLint* v ) ; +GL-FUNCTION: void glVertexAttrib4s ( GLuint index, GLshort x, GLshort y, GLshort z, GLshort w ) ; +GL-FUNCTION: void glVertexAttrib4sv ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttrib4ubv ( GLuint index, GLubyte* v ) ; +GL-FUNCTION: void glVertexAttrib4uiv ( GLuint index, GLuint* v ) ; +GL-FUNCTION: void glVertexAttrib4usv ( GLuint index, GLushort* v ) ; +GL-FUNCTION: void glVertexAttribPointer ( GLuint index, GLint size, GLenum type, GLboolean normalized, GLsizei stride, GLvoid* pointer ) ; + + +! OpenGL 2.1 + + +: GL_CURRENT_RASTER_SECONDARY_COLOR HEX: 845F ; inline +: GL_PIXEL_PACK_BUFFER HEX: 88EB ; inline +: GL_PIXEL_UNPACK_BUFFER HEX: 88EC ; inline +: GL_PIXEL_PACK_BUFFER_BINDING HEX: 88ED ; inline +: GL_PIXEL_UNPACK_BUFFER_BINDING HEX: 88EF ; inline +: GL_SRGB HEX: 8C40 ; inline +: GL_SRGB8 HEX: 8C41 ; inline +: GL_SRGB_ALPHA HEX: 8C42 ; inline +: GL_SRGB8_ALPHA8 HEX: 8C43 ; inline +: GL_SLUMINANCE_ALPHA HEX: 8C44 ; inline +: GL_SLUMINANCE8_ALPHA8 HEX: 8C45 ; inline +: GL_SLUMINANCE HEX: 8C46 ; inline +: GL_SLUMINANCE8 HEX: 8C47 ; inline +: GL_COMPRESSED_SRGB HEX: 8C48 ; inline +: GL_COMPRESSED_SRGB_ALPHA HEX: 8C49 ; inline +: GL_COMPRESSED_SLUMINANCE HEX: 8C4A ; inline +: GL_COMPRESSED_SLUMINANCE_ALPHA HEX: 8C4B ; inline + +GL-FUNCTION: void glUniformMatrix2x3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix2x4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix3x2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix3x4fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix4x2fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; +GL-FUNCTION: void glUniformMatrix4x3fv ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ; + + +! GL_EXT_framebuffer_object + + +: GL_INVALID_FRAMEBUFFER_OPERATION_EXT HEX: 0506 ; inline +: GL_MAX_RENDERBUFFER_SIZE_EXT HEX: 84E8 ; inline +: GL_FRAMEBUFFER_BINDING_EXT HEX: 8CA6 ; inline +: GL_RENDERBUFFER_BINDING_EXT HEX: 8CA7 ; inline +: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE_EXT HEX: 8CD0 ; inline +: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT HEX: 8CD1 ; inline +: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL_EXT HEX: 8CD2 ; inline +: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE_EXT HEX: 8CD3 ; inline +: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT HEX: 8CD4 ; inline +: GL_FRAMEBUFFER_COMPLETE_EXT HEX: 8CD5 ; inline +: GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT HEX: 8CD6 ; inline +: GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT HEX: 8CD7 ; inline +: GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT HEX: 8CD9 ; inline +: GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT HEX: 8CDA ; inline +: GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT HEX: 8CDB ; inline +: GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT HEX: 8CDC ; inline +: GL_FRAMEBUFFER_UNSUPPORTED_EXT HEX: 8CDD ; inline +: GL_MAX_COLOR_ATTACHMENTS_EXT HEX: 8CDF ; inline +: GL_COLOR_ATTACHMENT0_EXT HEX: 8CE0 ; inline +: GL_COLOR_ATTACHMENT1_EXT HEX: 8CE1 ; inline +: GL_COLOR_ATTACHMENT2_EXT HEX: 8CE2 ; inline +: GL_COLOR_ATTACHMENT3_EXT HEX: 8CE3 ; inline +: GL_COLOR_ATTACHMENT4_EXT HEX: 8CE4 ; inline +: GL_COLOR_ATTACHMENT5_EXT HEX: 8CE5 ; inline +: GL_COLOR_ATTACHMENT6_EXT HEX: 8CE6 ; inline +: GL_COLOR_ATTACHMENT7_EXT HEX: 8CE7 ; inline +: GL_COLOR_ATTACHMENT8_EXT HEX: 8CE8 ; inline +: GL_COLOR_ATTACHMENT9_EXT HEX: 8CE9 ; inline +: GL_COLOR_ATTACHMENT10_EXT HEX: 8CEA ; inline +: GL_COLOR_ATTACHMENT11_EXT HEX: 8CEB ; inline +: GL_COLOR_ATTACHMENT12_EXT HEX: 8CEC ; inline +: GL_COLOR_ATTACHMENT13_EXT HEX: 8CED ; inline +: GL_COLOR_ATTACHMENT14_EXT HEX: 8CEE ; inline +: GL_COLOR_ATTACHMENT15_EXT HEX: 8CEF ; inline +: GL_DEPTH_ATTACHMENT_EXT HEX: 8D00 ; inline +: GL_STENCIL_ATTACHMENT_EXT HEX: 8D20 ; inline +: GL_FRAMEBUFFER_EXT HEX: 8D40 ; inline +: GL_RENDERBUFFER_EXT HEX: 8D41 ; inline +: GL_RENDERBUFFER_WIDTH_EXT HEX: 8D42 ; inline +: GL_RENDERBUFFER_HEIGHT_EXT HEX: 8D43 ; inline +: GL_RENDERBUFFER_INTERNAL_FORMAT_EXT HEX: 8D44 ; inline +: GL_STENCIL_INDEX1_EXT HEX: 8D46 ; inline +: GL_STENCIL_INDEX4_EXT HEX: 8D47 ; inline +: GL_STENCIL_INDEX8_EXT HEX: 8D48 ; inline +: GL_STENCIL_INDEX16_EXT HEX: 8D49 ; inline +: GL_RENDERBUFFER_RED_SIZE_EXT HEX: 8D50 ; inline +: GL_RENDERBUFFER_GREEN_SIZE_EXT HEX: 8D51 ; inline +: GL_RENDERBUFFER_BLUE_SIZE_EXT HEX: 8D52 ; inline +: GL_RENDERBUFFER_ALPHA_SIZE_EXT HEX: 8D53 ; inline +: GL_RENDERBUFFER_DEPTH_SIZE_EXT HEX: 8D54 ; inline +: GL_RENDERBUFFER_STENCIL_SIZE_EXT HEX: 8D55 ; inline + +GL-FUNCTION: void glBindFramebufferEXT ( GLenum target, GLuint framebuffer ) ; +GL-FUNCTION: void glBindRenderbufferEXT ( GLenum target, GLuint renderbuffer ) ; +GL-FUNCTION: GLenum glCheckFramebufferStatusEXT ( GLenum target ) ; +GL-FUNCTION: void glDeleteFramebuffersEXT ( GLsizei n, GLuint* framebuffers ) ; +GL-FUNCTION: void glDeleteRenderbuffersEXT ( GLsizei n, GLuint* renderbuffers ) ; +GL-FUNCTION: void glFramebufferRenderbufferEXT ( GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer ) ; +GL-FUNCTION: void glFramebufferTexture1DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ; +GL-FUNCTION: void glFramebufferTexture2DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ; +GL-FUNCTION: void glFramebufferTexture3DEXT ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ; +GL-FUNCTION: void glGenFramebuffersEXT ( GLsizei n, GLuint* framebuffers ) ; +GL-FUNCTION: void glGenRenderbuffersEXT ( GLsizei n, GLuint* renderbuffers ) ; +GL-FUNCTION: void glGenerateMipmapEXT ( GLenum target ) ; +GL-FUNCTION: void glGetFramebufferAttachmentParameterivEXT ( GLenum target, GLenum attachment, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glGetRenderbufferParameterivEXT ( GLenum target, GLenum pname, GLint* params ) ; +GL-FUNCTION: GLboolean glIsFramebufferEXT ( GLuint framebuffer ) ; +GL-FUNCTION: GLboolean glIsRenderbufferEXT ( GLuint renderbuffer ) ; +GL-FUNCTION: void glRenderbufferStorageEXT ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ; + + +! GL_ARB_texture_float + + +: GL_RGBA32F_ARB HEX: 8814 ; inline +: GL_RGB32F_ARB HEX: 8815 ; inline +: GL_ALPHA32F_ARB HEX: 8816 ; inline +: GL_INTENSITY32F_ARB HEX: 8817 ; inline +: GL_LUMINANCE32F_ARB HEX: 8818 ; inline +: GL_LUMINANCE_ALPHA32F_ARB HEX: 8819 ; inline +: GL_RGBA16F_ARB HEX: 881A ; inline +: GL_RGB16F_ARB HEX: 881B ; inline +: GL_ALPHA16F_ARB HEX: 881C ; inline +: GL_INTENSITY16F_ARB HEX: 881D ; inline +: GL_LUMINANCE16F_ARB HEX: 881E ; inline +: GL_LUMINANCE_ALPHA16F_ARB HEX: 881F ; inline +: GL_TEXTURE_RED_TYPE_ARB HEX: 8C10 ; inline +: GL_TEXTURE_GREEN_TYPE_ARB HEX: 8C11 ; inline +: GL_TEXTURE_BLUE_TYPE_ARB HEX: 8C12 ; inline +: GL_TEXTURE_ALPHA_TYPE_ARB HEX: 8C13 ; inline +: GL_TEXTURE_LUMINANCE_TYPE_ARB HEX: 8C14 ; inline +: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15 ; inline +: GL_TEXTURE_DEPTH_TYPE_ARB HEX: 8C16 ; inline +: GL_UNSIGNED_NORMALIZED_ARB HEX: 8C17 ; inline + diff --git a/extra/opengl/gl/unix/authors.txt b/extra/opengl/gl/unix/authors.txt new file mode 100755 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/opengl/gl/unix/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/opengl/gl/unix/unix.factor b/extra/opengl/gl/unix/unix.factor new file mode 100644 index 0000000000..16cd38f92f --- /dev/null +++ b/extra/opengl/gl/unix/unix.factor @@ -0,0 +1,5 @@ +USING: alien.syntax kernel syntax words ; + +IN: opengl.gl.unix + +: GL-FUNCTION: POSTPONE: FUNCTION: ; parsing diff --git a/extra/opengl/gl/windows/authors.txt b/extra/opengl/gl/windows/authors.txt new file mode 100755 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/opengl/gl/windows/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/opengl/gl/windows/windows.factor b/extra/opengl/gl/windows/windows.factor new file mode 100755 index 0000000000..186f17206c --- /dev/null +++ b/extra/opengl/gl/windows/windows.factor @@ -0,0 +1,34 @@ +USING: alien alien.syntax arrays assocs hashtables init kernel + libc math namespaces parser sequences syntax system vectors + windows.opengl32 ; + +IN: opengl.gl.windows + + gl-function-pointers set ] "opengl.gl.windows init hook" add-init-hook + +: gl-function-number ( -- n ) + gl-function-number-counter get + dup 1+ gl-function-number-counter set ; + +: gl-function-pointer ( name n -- funptr ) + wglGetCurrentContext 2array dup gl-function-pointers get at + [ -rot 2drop ] + [ >r wglGetProcAddress dup r> gl-function-pointers get set-at ] + if* ; + +PRIVATE> + +: GL-FUNCTION: + "stdcall" + scan + scan + dup gl-function-number [ gl-function-pointer ] 2curry swap + ";" parse-tokens [ "()" subseq? not ] subset + define-indirect + ; parsing diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor index f9a491aba6..cc8221baa1 100644 --- a/extra/opengl/opengl-docs.factor +++ b/extra/opengl/opengl-docs.factor @@ -37,6 +37,10 @@ HELP: gl-rect { $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } } { $description "Draws the outline of a rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ; +HELP: rect-vertices +{ $values { "lower-left" "A pair of numbers indicating the lower-left coordinates of the rectangle." } { "upper-right" "The upper-right coordinates of the rectangle." } } +{ $description "Emits" { $link glVertex2d } " calls outlining the axis-aligned rectangle from " { $snippet "lower-left" } " to " { $snippet "upper-right" } " on the z=0 plane in counterclockwise order." } ; + HELP: gl-fill-poly { $values { "points" "a sequence of pairs of integers" } } { $description "Draws a filled polygon." } ; @@ -53,6 +57,58 @@ HELP: gen-texture { $values { "id" integer } } { $description "Wrapper for " { $link glGenTextures } " to handle the common case of generating a single texture ID." } ; +HELP: gen-framebuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ; + +HELP: gen-renderbuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ; + +HELP: gen-buffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glGenBuffers } " to handle the common case of generating a single buffer ID." } ; + +HELP: delete-texture +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteTextures } " to handle the common case of deleting a single texture ID." } ; + +HELP: delete-framebuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ; + +HELP: delete-renderbuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ; + +HELP: delete-buffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteBuffers } " to handle the common case of deleting a single buffer ID." } ; + +{ gen-texture delete-texture } related-words +{ gen-framebuffer delete-framebuffer } related-words +{ gen-renderbuffer delete-renderbuffer } related-words +{ gen-buffer delete-buffer } related-words + +HELP: framebuffer-incomplete? +{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } } +{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ; + +HELP: check-framebuffer +{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ; + +HELP: with-framebuffer +{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } } +{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ; + +HELP: bind-texture-unit +{ $values { "id" "The id of a texture object." } { "target" "The texture target (e.g., " { $snippet "GL_TEXTURE_2D" } ")" } { "unit" "The texture unit to bind (e.g., " { $snippet "GL_TEXTURE0" } ")" } } +{ $description "Binds texture " { $snippet "id" } " to texture target " { $snippet "target" } " of texture unit " { $snippet "unit" } ". Equivalent to " { $snippet "unit glActiveTexture target id glBindTexture" } "." } ; + +HELP: set-draw-buffers +{ $values { "buffers" "A sequence of buffer words (e.g. " { $snippet "GL_BACK" } ", " { $snippet "GL_COLOR_ATTACHMENT0_EXT" } ")"} } +{ $description "Wrapper for " { $link glDrawBuffers } ". Sets up the buffers named in the sequence for simultaneous drawing." } ; + HELP: do-attribs { $values { "bits" integer } { "quot" quotation } } { $description "Wraps a quotation in " { $link glPushAttrib } "/" { $link glPopAttrib } " calls." } ; @@ -92,19 +148,174 @@ HELP: with-translation { $values { "loc" "a pair of integers" } { "quot" quotation } } { $description "Calls the quotation with a translation by " { $snippet "loc" } " pixels applied to the current " { $link GL_MODELVIEW } " matrix, restoring the matrix when the quotation is done." } ; +HELP: gl-shader +{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:" + { $list + { { $link } " - Compile GLSL code into a shader object" } + { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" } + { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" } + { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" } + { { $link delete-gl-shader } " - Invalidate a shader object" } + } + "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ; + +HELP: vertex-shader +{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:" + { $list + { { $link } " - Compile GLSL code into a vertex shader object "} + } +} ; + +HELP: fragment-shader +{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:" + { $list + { { $link } " - Compile GLSL code into a fragment shader object "} + } +} ; + +HELP: +{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } } +{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ; + +HELP: +{ $values { "source" "The GLSL source code to compile" } } +{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER " } "." } ; + +HELP: +{ $values { "source" "The GLSL source code to compile" } } +{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER " } "." } ; + +HELP: gl-shader-ok? +{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ; + +HELP: check-gl-shader +{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ; + +HELP: delete-gl-shader +{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ; + +HELP: gl-shader-info-log +{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ; + +HELP: gl-program +{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:" + { $list + { { $link } ", " { $link } " - Link a set of shaders into a GLSL program" } + { { $link gl-program-ok? } " - Check whether a program object linked successfully" } + { { $link check-gl-program } " - Throw an error unless a program object linked successfully" } + { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" } + { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" } + { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" } + { { $link with-gl-program } " - Use a program object" } + } +} ; + +HELP: +{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } } +{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ; + +HELP: +{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } } +{ $description "Wrapper for " { $link } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ; + +{ } related-words + +HELP: gl-program-ok? +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ; + +HELP: check-gl-program +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ; + +HELP: gl-program-info-log +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ; + +HELP: delete-gl-program +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ; + +HELP: with-gl-program +{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation" } } +{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ; + +HELP: gl-version +{ $values { "version" "The version string from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; + +HELP: gl-vendor-version +{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; + +HELP: has-gl-version? +{ $values { "version" "A version string" } { "?" "A boolean value" } } +{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; + +HELP: require-gl-version +{ $values { "version" "A version string" } } +{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ; + +HELP: glsl-version +{ $values { "version" "The GLSL version string from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; + +HELP: glsl-vendor-version +{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; + +HELP: has-glsl-version? +{ $values { "version" "A version string" } { "?" "A boolean value" } } +{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; + +HELP: require-glsl-version +{ $values { "version" "A version string" } } +{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ; + +HELP: gl-extensions +{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } } +{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ; + +HELP: has-gl-extensions? +{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } +{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ; + +HELP: require-gl-extensions +{ $values { "extensions" "A sequence of extension name strings" } } +{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ; + +HELP: require-gl-version-or-extensions +{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } +{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version, or a set of equivalent extensions." } ; + +{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? gl-version glsl-version gl-extensions } related-words + ARTICLE: "gl-utilities" "OpenGL utility words" "In addition to the full OpenGL API, the " { $vocab-link "opengl" } " vocabulary includes some utility words to give OpenGL a more Factor-like feel." $nl +"Checking implementation capabilities:" +{ $subsection require-gl-version } +{ $subsection require-gl-extensions } +{ $subsection require-glsl-version } +{ $subsection require-gl-version-or-extensions } "Wrappers:" { $subsection gl-color } { $subsection gl-vertex } { $subsection gl-translate } +{ $subsection gen-texture } +{ $subsection bind-texture-unit } "Combinators:" { $subsection do-state } { $subsection do-enabled } { $subsection do-attribs } { $subsection do-matrix } { $subsection with-translation } +{ $subsection with-framebuffer } +{ $subsection with-gl-program } { $subsection make-dlist } "Rendering geometric shapes:" { $subsection gl-line } @@ -112,6 +323,10 @@ $nl { $subsection gl-rect } { $subsection gl-fill-poly } { $subsection gl-poly } -{ $subsection gl-gradient } ; +{ $subsection gl-gradient } +"Compiling, linking, and using GLSL programs:" +{ $subsection gl-shader } +{ $subsection gl-program } +; ABOUT: "gl-utilities" diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor old mode 100644 new mode 100755 index f611c97209..4ea91b867b --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! Portions copyright (C) 2007 Eduardo Cavazos. +! Portions copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types kernel math namespaces sequences -math.vectors math.constants math.functions opengl.gl opengl.glu -combinators arrays ; +USING: alien alien.c-types continuations kernel libc math macros +namespaces math.vectors math.constants math.functions +math.parser opengl.gl opengl.glu combinators arrays sequences +splitting words byte-arrays ; IN: opengl : coordinates [ first2 ] 2apply ; @@ -20,7 +22,7 @@ IN: opengl : gl-error ( -- ) glGetError dup zero? [ - "GL error: " dup gluErrorString append throw + "GL error: " over gluErrorString append throw ] unless drop ; : do-state ( what quot -- ) @@ -93,8 +95,62 @@ IN: opengl ] 2each 2drop ] do-state ; +: (gen-gl-object) ( quot -- id ) + >r 1 0 r> keep *uint ; inline : gen-texture ( -- id ) - 1 0 [ glGenTextures ] keep *uint ; + [ glGenTextures ] (gen-gl-object) ; +: gen-framebuffer ( -- id ) + [ glGenFramebuffersEXT ] (gen-gl-object) ; +: gen-renderbuffer ( -- id ) + [ glGenRenderbuffersEXT ] (gen-gl-object) ; +: gen-buffer ( -- id ) + [ glGenBuffers ] (gen-gl-object) ; + +: (delete-gl-object) ( id quot -- ) + >r 1 swap r> call ; inline +: delete-texture ( id -- ) + [ glDeleteTextures ] (delete-gl-object) ; +: delete-framebuffer ( id -- ) + [ glDeleteFramebuffersEXT ] (delete-gl-object) ; +: delete-renderbuffer ( id -- ) + [ glDeleteRenderbuffersEXT ] (delete-gl-object) ; +: delete-buffer ( id -- ) + [ glDeleteBuffers ] (delete-gl-object) ; + +: framebuffer-incomplete? ( -- status/f ) + GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT + dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ; + +: framebuffer-error ( status -- * ) + { { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] } + { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] } + { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] } + [ drop gl-error "unknown framebuffer error" ] } case throw ; + +: check-framebuffer ( -- ) + framebuffer-incomplete? [ framebuffer-error ] when* ; + +: with-framebuffer ( id quot -- ) + GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT + [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline + +: bind-texture-unit ( id target unit -- ) + glActiveTexture swap glBindTexture gl-error ; + +: framebuffer-attachment ( attachment -- id ) + GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT + 0 [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ; + +: (set-draw-buffers) ( buffers -- ) + dup length swap >c-uint-array glDrawBuffers ; + +MACRO: set-draw-buffers ( buffers -- ) + [ dup word? [ execute ] [ ] if ] map [ (set-draw-buffers) ] curry ; : do-attribs ( bits quot -- ) swap glPushAttrib call glPopAttrib ; inline @@ -120,7 +176,7 @@ TUPLE: sprite loc dim dim2 dlist texture ; GL_UNSIGNED_BYTE r> glTexImage2D ] do-attribs ] keep ; - + : gen-dlist ( -- id ) 1 glGenLists ; : make-dlist ( type quot -- id ) @@ -154,6 +210,14 @@ TUPLE: sprite loc dim dim2 dlist texture ; swap sprite-loc v- gl-translate GL_TEXTURE_2D 0 glBindTexture ; +: rect-vertices ( lower-left upper-right -- ) + GL_QUADS [ + over first2 glVertex2d + dup first pick second glVertex2d + dup first2 glVertex2d + swap first swap second glVertex2d + ] do-state ; + : make-sprite-dlist ( sprite -- id ) GL_MODELVIEW [ GL_COMPILE [ draw-sprite ] make-dlist @@ -167,7 +231,7 @@ TUPLE: sprite loc dim dim2 dlist texture ; : free-sprite ( sprite -- ) dup sprite-dlist delete-dlist - sprite-texture 1 swap glDeleteTextures ; + sprite-texture delete-texture ; : free-sprites ( sprites -- ) [ [ free-sprite ] when* ] each ; @@ -185,3 +249,178 @@ TUPLE: sprite loc dim dim2 dlist texture ; glLoadIdentity GL_MODELVIEW glMatrixMode glLoadIdentity ; + +! Shaders + +: c-true? ( int -- ? ) zero? not ; inline + +: with-gl-shader-source-ptr ( string quot -- ) + swap >byte-array malloc-byte-array [ + swap call + ] keep free ; inline + +: ( source kind -- shader ) + glCreateShader dup rot + [ 1 swap f glShaderSource ] with-gl-shader-source-ptr + [ glCompileShader ] keep + gl-error ; + +: (gl-shader?) ( object -- ? ) + dup integer? [ glIsShader c-true? ] [ drop f ] if ; + +: gl-shader-get-int ( shader enum -- value ) + 0 [ glGetShaderiv ] keep *int ; + +: gl-shader-ok? ( shader -- ? ) + GL_COMPILE_STATUS gl-shader-get-int c-true? ; + +: ( source -- vertex-shader ) + GL_VERTEX_SHADER ; inline + +: (vertex-shader?) ( object -- ? ) + dup (gl-shader?) + [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ] + [ drop f ] if ; + +: ( source -- fragment-shader ) + GL_FRAGMENT_SHADER ; inline + +: (fragment-shader?) ( object -- ? ) + dup (gl-shader?) + [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ] + [ drop f ] if ; + +: gl-shader-info-log-length ( shader -- log-length ) + GL_INFO_LOG_LENGTH gl-shader-get-int ; inline + +: gl-shader-info-log ( shader -- log ) + dup gl-shader-info-log-length + dup [ + 0 over glGetShaderInfoLog + alien>char-string + ] with-malloc ; + +: check-gl-shader ( shader -- shader* ) + dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ; + +: delete-gl-shader ( shader -- ) glDeleteShader ; inline + +PREDICATE: integer gl-shader (gl-shader?) ; +PREDICATE: gl-shader vertex-shader (vertex-shader?) ; +PREDICATE: gl-shader fragment-shader (fragment-shader?) ; + +! Programs + +: ( shaders -- program ) + glCreateProgram swap + [ dupd glAttachShader ] each + [ glLinkProgram ] keep + gl-error ; + +: (gl-program?) ( object -- ? ) + dup integer? [ glIsProgram c-true? ] [ drop f ] if ; + +: gl-program-get-int ( program enum -- value ) + 0 [ glGetProgramiv ] keep *int ; + +: gl-program-ok? ( program -- ? ) + GL_LINK_STATUS gl-program-get-int c-true? ; + +: gl-program-info-log-length ( program -- log-length ) + GL_INFO_LOG_LENGTH gl-program-get-int ; inline + +: gl-program-info-log ( program -- log ) + dup gl-program-info-log-length + dup [ [ 0 swap glGetProgramInfoLog ] keep + alien>char-string ] with-malloc ; + +: check-gl-program ( program -- program* ) + dup gl-program-ok? [ dup gl-program-info-log throw ] unless ; + +: gl-program-shaders-length ( program -- shaders-length ) + GL_ATTACHED_SHADERS gl-program-get-int ; inline + +: gl-program-shaders ( program -- shaders ) + dup gl-program-shaders-length [ + dup "GLuint" 0 over glGetAttachedShaders + ] keep c-uint-array> ; + +: delete-gl-program-only ( program -- ) + glDeleteProgram ; inline + +: detach-gl-program-shader ( program shader -- ) + glDetachShader ; inline + +: delete-gl-program ( program -- ) + dup gl-program-shaders [ + 2dup detach-gl-program-shader delete-gl-shader + ] each delete-gl-program-only ; + +: with-gl-program ( program quot -- ) + swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline + +PREDICATE: integer gl-program (gl-program?) ; + +: ( vertex-shader-source fragment-shader-source -- program ) + >r check-gl-shader + r> check-gl-shader + 2array check-gl-program ; + +: (require-gl) ( thing require-quot make-error-quot -- ) + >r dupd call + [ r> 2drop ] + [ r> " " make throw ] + if ; inline + +: gl-extensions ( -- seq ) + GL_EXTENSIONS glGetString " " split ; +: has-gl-extensions? ( extensions -- ? ) + gl-extensions subseq? ; +: (make-gl-extensions-error) ( required-extensions -- ) + gl-extensions swap seq-diff + "Required OpenGL extensions not supported:\n" % + [ " " % % "\n" % ] each ; +: require-gl-extensions ( extensions -- ) + [ has-gl-extensions? ] + [ (make-gl-extensions-error) ] + (require-gl) ; + +: version-seq ( version-string -- version-seq ) + "." split [ string>number ] map ; + +: version<=> ( version1 version2 -- n ) + swap version-seq swap version-seq <=> ; + +: (gl-version) ( -- version vendor ) + GL_VERSION glGetString " " split1 ; +: gl-version ( -- version ) + (gl-version) drop ; +: gl-vendor-version ( -- version ) + (gl-version) nip ; +: has-gl-version? ( version -- ? ) + gl-version version<=> 0 <= ; +: (make-gl-version-error) ( required-version -- ) + "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ; +: require-gl-version ( version -- ) + [ has-gl-version? ] + [ (make-gl-version-error) ] + (require-gl) ; + +: (glsl-version) ( -- version vendor ) + GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ; +: glsl-version ( -- version ) + (glsl-version) drop ; +: glsl-vendor-version ( -- version ) + (glsl-version) nip ; +: has-glsl-version? ( version -- ? ) + glsl-version version<=> 0 <= ; +: require-glsl-version ( version -- ) + [ has-glsl-version? ] + [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ] + (require-gl) ; + +: require-gl-version-or-extensions ( version extensions -- ) + 2array [ first2 has-gl-extensions? swap has-gl-version? or ] + [ dup first (make-gl-version-error) "\n" % + second (make-gl-extensions-error) "\n" % ] + (require-gl) ; diff --git a/extra/opengl/tags.txt b/extra/opengl/tags.txt index bb863cf9a0..5e477dbcb3 100644 --- a/extra/opengl/tags.txt +++ b/extra/opengl/tags.txt @@ -1 +1,4 @@ +opengl.glu +opengl.gl +opengl bindings diff --git a/extra/openssl/summary.txt b/extra/openssl/summary.txt new file mode 100755 index 0000000000..42db29f294 --- /dev/null +++ b/extra/openssl/summary.txt @@ -0,0 +1 @@ +OpenSSL binding diff --git a/extra/optimizer/debugger/authors.txt b/extra/optimizer/debugger/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/optimizer/debugger/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/oracle/liboci/authors.txt b/extra/oracle/liboci/authors.txt new file mode 100755 index 0000000000..7c29e7c401 --- /dev/null +++ b/extra/oracle/liboci/authors.txt @@ -0,0 +1 @@ +Elie Chaftari diff --git a/extra/pack/pack-tests.factor b/extra/pack/pack-tests.factor old mode 100644 new mode 100755 index b2fdc8ab0d..7a88881189 --- a/extra/pack/pack-tests.factor +++ b/extra/pack/pack-tests.factor @@ -43,5 +43,5 @@ USING: io io.streams.string kernel namespaces pack strings tools.test ; [ "FRAM" ] [ "FRAM\0" [ read-c-string ] string-in ] unit-test [ f ] [ "" [ read-c-string ] string-in ] unit-test -[ 5 ] [ "FRAM\0\u0005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] string-in ] unit-test +[ 5 ] [ "FRAM\0\u000005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] string-in ] unit-test diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index 8d55cc5770..fc8cec770b 100644 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2005 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -! USING: kernel lazy-lists tools.test strings math -sequences parser-combinators arrays math.parser ; +sequences parser-combinators arrays math.parser unicode.categories ; IN: scratchpad ! Testing <&> diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 4376aed95a..b7b62b3c2e 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: lazy-lists promises kernel sequences strings math -arrays splitting quotations combinators namespaces ; +arrays splitting quotations combinators namespaces +unicode.case unicode.categories ; IN: parser-combinators ! Parser combinator protocol diff --git a/extra/parser-combinators/simple/simple.factor b/extra/parser-combinators/simple/simple.factor index 3b59068dd6..763f823348 100755 --- a/extra/parser-combinators/simple/simple.factor +++ b/extra/parser-combinators/simple/simple.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel strings math sequences lazy-lists words -math.parser promises parser-combinators ; +math.parser promises parser-combinators unicode.categories ; IN: parser-combinators.simple : 'digit' ( -- parser ) diff --git a/extra/parser-combinators/simple/tags.txt b/extra/parser-combinators/simple/tags.txt new file mode 100755 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/parser-combinators/simple/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/parser-combinators/tags.txt b/extra/parser-combinators/tags.txt new file mode 100755 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/parser-combinators/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 520bf82c32..d134f3316f 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel parser words arrays strings math.parser sequences - quotations vectors namespaces math assocs continuations peg ; + quotations vectors namespaces math assocs continuations peg + unicode.categories ; IN: peg.ebnf TUPLE: ebnf-non-terminal symbol ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 3d9128fec9..41df8735e5 100644 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings namespaces math assocs shuffle - vectors arrays combinators.lib memoize math.parser match ; + vectors arrays combinators.lib memoize math.parser match + unicode.categories ; IN: peg TUPLE: parse-result remaining ast ; diff --git a/extra/peg/tags.txt b/extra/peg/tags.txt index 9da56880c0..5af5dba748 100644 --- a/extra/peg/tags.txt +++ b/extra/peg/tags.txt @@ -1 +1,2 @@ +text parsing diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index b9375b7d1e..0b8f773887 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -1,6 +1,6 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007 Aaron Schaefer, Alexander Solovyov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences ; +USING: kernel math sequences shuffle ; IN: project-euler.002 ! http://projecteuler.net/index.php?section=problems&id=2 @@ -22,12 +22,12 @@ IN: project-euler.002 r add dup 2 tail* sum r> (fib-upto) ] [ 2drop ] if ; + 2dup <= [ [ over push dup 2 tail* sum ] dip (fib-upto) ] [ 2drop ] if ; PRIVATE> : fib-upto ( n -- seq ) - { 0 } 1 rot (fib-upto) ; + V{ 0 } clone 1 rot (fib-upto) ; : euler002 ( -- answer ) 1000000 fib-upto [ even? ] subset sum ; @@ -35,4 +35,18 @@ PRIVATE> ! [ euler002 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials -MAIN: euler002 + +! ALTERNATE SOLUTIONS +! ------------------- + +: fib-upto* ( n -- seq ) + 0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip + 1 head-slice* { 0 1 } swap append ; + +: euler002a ( -- answer ) + 1000000 fib-upto* [ even? ] subset sum ; + +! [ euler002a ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler002a diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor index 0db0c6f2cb..d7984a4991 100644 --- a/extra/project-euler/004/004.factor +++ b/extra/project-euler/004/004.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators.lib hashtables kernel math math.parser math.ranges +USING: hashtables kernel math math.parser math.ranges project-euler.common sequences sorting ; IN: project-euler.004 @@ -21,9 +21,6 @@ IN: project-euler.004 : palindrome? ( n -- ? ) number>string dup reverse = ; -: cartesian-product ( seq1 seq2 -- seq1xseq2 ) - swap [ swap [ 2array ] map-with ] map-with concat ; - permutation) ( seq n -- seq ) - [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ; - -PRIVATE> - -: >permutation ( factoradic -- permutation ) - reverse 1 cut [ (>permutation) ] each ; - -: factoradic ( k order -- factoradic ) - [ [1,b] [ 2dup mod , /i ] each ] { } make reverse nip ; - -: permutation ( k seq -- seq ) - dup length swapd factoradic >permutation - [ [ dupd swap nth , ] each drop ] { } make ; - : euler024 ( -- answer ) 999999 10 permutation 10 swap digits>integer ; diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor index 2819e210a7..2786d9f0e6 100644 --- a/extra/project-euler/025/025.factor +++ b/extra/project-euler/025/025.factor @@ -1,7 +1,7 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel math math.functions math.parser math.ranges memoize - project-euler.common sequences ; +USING: alien.syntax kernel math math.constants math.functions math.parser + math.ranges memoize project-euler.common sequences ; IN: project-euler.025 ! http://projecteuler.net/index.php?section=problems&id=25 @@ -67,9 +67,6 @@ PRIVATE> integer ; diff --git a/extra/project-euler/026/026.factor b/extra/project-euler/026/026.factor index d79effed02..3ad1908aa6 100644 --- a/extra/project-euler/026/026.factor +++ b/extra/project-euler/026/026.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions math.primes math.ranges sequences ; IN: project-euler.026 diff --git a/extra/project-euler/027/027.factor b/extra/project-euler/027/027.factor new file mode 100644 index 0000000000..2bc7894684 --- /dev/null +++ b/extra/project-euler/027/027.factor @@ -0,0 +1,75 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.primes project-euler.common sequences ; +IN: project-euler.027 + +! http://projecteuler.net/index.php?section=problems&id=27 + +! DESCRIPTION +! ----------- + +! Euler published the remarkable quadratic formula: + +! n² + n + 41 + +! It turns out that the formula will produce 40 primes for the consecutive +! values n = 0 to 39. However, when n = 40, 402 + 40 + 41 = 40(40 + 1) + 41 is +! divisible by 41, and certainly when n = 41, 41² + 41 + 41 is clearly +! divisible by 41. + +! Using computers, the incredible formula n² - 79n + 1601 was discovered, which +! produces 80 primes for the consecutive values n = 0 to 79. The product of the +! coefficients, -79 and 1601, is -126479. + +! Considering quadratics of the form: + +! n² + an + b, where |a| < 1000 and |b| < 1000 + +! where |n| is the modulus/absolute value of n +! e.g. |11| = 11 and |-4| = 4 + +! Find the product of the coefficients, a and b, for the quadratic expression +! that produces the maximum number of primes for consecutive values of n, +! starting with n = 0. + + +! SOLUTION +! -------- + +! b must be prime since n = 0 must return a prime +! a + b + 1 must be prime since n = 1 must return a prime +! 1 - a + b must be prime as well, hence >= 2. Therefore: +! 1 - a + b >= 2 +! b - a >= 1 +! a < b + + + +: euler027 ( -- answer ) + source-027 max-consecutive drop product ; + +! [ euler027 ] 100 ave-time +! 687 ms run / 23 ms GC ave time - 100 trials + +! TODO: generalize max-consecutive/max-product (from #26) into a new word + +MAIN: euler027 diff --git a/extra/project-euler/028/028.factor b/extra/project-euler/028/028.factor new file mode 100644 index 0000000000..c8ac19ef82 --- /dev/null +++ b/extra/project-euler/028/028.factor @@ -0,0 +1,46 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math math.ranges ; +IN: project-euler.028 + +! http://projecteuler.net/index.php?section=problems&id=28 + +! DESCRIPTION +! ----------- + +! Starting with the number 1 and moving to the right in a clockwise direction a +! 5 by 5 spiral is formed as follows: + +! 21 22 23 24 25 +! 20 7 8 9 10 +! 19 6 1 2 11 +! 18 5 4 3 12 +! 17 16 15 14 13 + +! It can be verified that the sum of both diagonals is 101. + +! What is the sum of both diagonals in a 1001 by 1001 spiral formed in the same way? + + +! SOLUTION +! -------- + +! For a square sized n by n, the sum of corners is 4n² - 6n + 6 + + [ sum-corners ] sigma ; + +PRIVATE> + +: euler028 ( -- answer ) + 1001 sum-diags ; + +! [ euler028 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler028 diff --git a/extra/project-euler/029/029.factor b/extra/project-euler/029/029.factor new file mode 100644 index 0000000000..459a3a4bd6 --- /dev/null +++ b/extra/project-euler/029/029.factor @@ -0,0 +1,37 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: hashtables kernel math.functions math.ranges project-euler.common + sequences ; +IN: project-euler.029 + +! http://projecteuler.net/index.php?section=problems&id=29 + +! DESCRIPTION +! ----------- + +! Consider all integer combinations of a^b for 2 ≤ a ≤ 5 and 2 ≤ b ≤ 5: + +! 2^2 = 4, 2^3 = 8, 2^4 = 16, 2^5 = 32 +! 3^2 = 9, 3^3 = 27, 3^4 = 81, 3^5 = 243 +! 4^2 = 16, 4^3 = 64, 4^4 = 256, 4^5 = 1024 +! 5^2 = 25, 5^3 = 125, 5^4 = 625, 5^5 = 3125 + +! If they are then placed in numerical order, with any repeats removed, we get +! the following sequence of 15 distinct terms: + +! 4, 8, 9, 16, 25, 27, 32, 64, 81, 125, 243, 256, 625, 1024, 3125 + +! How many distinct terms are in the sequence generated by a^b for 2 ≤ a ≤ 100 +! and 2 ≤ b ≤ 100? + + +! SOLUTION +! -------- + +: euler029 ( -- answer ) + 2 100 [a,b] dup cartesian-product [ first2 ^ ] map prune length ; + +! [ euler029 ] 100 ave-time +! 951 ms run / 12 ms GC ave time - 100 trials + +MAIN: euler029 diff --git a/extra/project-euler/030/030.factor b/extra/project-euler/030/030.factor new file mode 100644 index 0000000000..22d05524b2 --- /dev/null +++ b/extra/project-euler/030/030.factor @@ -0,0 +1,46 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math math.functions project-euler.common sequences ; +IN: project-euler.030 + +! http://projecteuler.net/index.php?section=problems&id=30 + +! DESCRIPTION +! ----------- + +! Surprisingly there are only three numbers that can be written as the sum of +! fourth powers of their digits: + +! 1634 = 1^4 + 6^4 + 3^4 + 4^4 +! 8208 = 8^4 + 2^4 + 0^4 + 8^4 +! 9474 = 9^4 + 4^4 + 7^4 + 4^4 + +! As 1 = 1^4 is not a sum it is not included. + +! The sum of these numbers is 1634 + 8208 + 9474 = 19316. + +! Find the sum of all the numbers that can be written as the sum of fifth +! powers of their digits. + + +! SOLUTION +! -------- + +! if n is the number of digits +! n * 9^5 = 10^n when n ≈ 5.513 +! 10^5.513 ≈ 325537 + +digits [ 5 ^ ] sigma ; + +PRIVATE> + +: euler030 ( -- answer ) + 325537 [ dup sum-fifth-powers = ] subset sum 1- ; + +! [ euler030 ] 100 ave-time +! 2537 ms run / 125 ms GC ave time - 100 trials + +MAIN: euler030 diff --git a/extra/project-euler/031/031.factor b/extra/project-euler/031/031.factor new file mode 100644 index 0000000000..4be866dc03 --- /dev/null +++ b/extra/project-euler/031/031.factor @@ -0,0 +1,63 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math ; +IN: project-euler.031 + +! http://projecteuler.net/index.php?section=problems&id=31 + +! DESCRIPTION +! ----------- + +! In England the currency is made up of pound, £, and pence, p, and there are +! eight coins in general circulation: + +! 1p, 2p, 5p, 10p, 20p, 50p, £1 (100p) and £2 (200p). + +! It is possible to make £2 in the following way: + +! 1×£1 + 1×50p + 2×20p + 1×5p + 1×2p + 3×1p + +! How many different ways can £2 be made using any number of coins? + + + +! SOLUTION +! -------- + += [ [ 2 - 2p ] keep 1p + ] [ drop 0 ] if ; + +: 5p ( m -- n ) + dup 0 >= [ [ 5 - 5p ] keep 2p + ] [ drop 0 ] if ; + +: 10p ( m -- n ) + dup 0 >= [ [ 10 - 10p ] keep 5p + ] [ drop 0 ] if ; + +: 20p ( m -- n ) + dup 0 >= [ [ 20 - 20p ] keep 10p + ] [ drop 0 ] if ; + +: 50p ( m -- n ) + dup 0 >= [ [ 50 - 50p ] keep 20p + ] [ drop 0 ] if ; + +: 100p ( m -- n ) + dup 0 >= [ [ 100 - 100p ] keep 50p + ] [ drop 0 ] if ; + +: 200p ( m -- n ) + dup 0 >= [ [ 200 - 200p ] keep 100p + ] [ drop 0 ] if ; + +PRIVATE> + +: euler031 ( -- answer ) + 200 200p ; + +! [ euler031 ] 100 ave-time +! 4 ms run / 0 ms GC ave time - 100 trials + +! TODO: generalize to eliminate duplication; use a sequence to specify denominations? + +MAIN: euler031 diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor new file mode 100644 index 0000000000..d10326a076 --- /dev/null +++ b/extra/project-euler/032/032.factor @@ -0,0 +1,81 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib hashtables kernel math math.combinatorics math.parser + math.ranges project-euler.common sequences sorting ; +IN: project-euler.032 + +! http://projecteuler.net/index.php?section=problems&id=32 + +! DESCRIPTION +! ----------- + +! The product 7254 is unusual, as the identity, 39 × 186 = 7254, containing +! multiplicand, multiplier, and product is 1 through 9 pandigital. + +! Find the sum of all products whose multiplicand/multiplier/product identity +! can be written as a 1 through 9 pandigital. + +! HINT: Some products can be obtained in more than one way so be sure to only +! include it once in your sum. + + +! SOLUTION +! -------- + +! Generate all pandigital numbers and then check if they fit the identity + +integer ] map ; + +: 1and4 ( n -- ? ) + number>string 1 cut-slice 4 cut-slice + [ 10 string>integer ] 3apply [ * ] dip = ; + +: 2and3 ( n -- ? ) + number>string 2 cut-slice 3 cut-slice + [ 10 string>integer ] 3apply [ * ] dip = ; + +: valid? ( n -- ? ) + dup 1and4 swap 2and3 or ; + +: products ( seq -- m ) + [ number>string 4 tail* 10 string>integer ] map ; + +PRIVATE> + +: euler032 ( -- answer ) + source-032 [ valid? ] subset products prune sum ; + +! [ euler032 ] 10 ave-time +! 27609 ms run / 2484 ms GC ave time - 10 trials + + +! ALTERNATE SOLUTIONS +! ------------------- + +! Generate all reasonable multiplicand/multiplier pairs, then multiply and see +! if the equation is pandigital + +string natural-sort "123456789" = ; + +! multiplicand/multiplier/product +: mmp ( pair -- n ) + first2 2dup * [ number>string ] 3apply 3append 10 string>integer ; + +PRIVATE> + +: euler032a ( -- answer ) + source-032a [ mmp ] map [ pandigital? ] subset products prune sum ; + +! [ euler032a ] 100 ave-time +! 5978 ms run / 327 ms GC ave time - 100 trials + +MAIN: euler032a diff --git a/extra/project-euler/033/033.factor b/extra/project-euler/033/033.factor new file mode 100644 index 0000000000..6f29c3519e --- /dev/null +++ b/extra/project-euler/033/033.factor @@ -0,0 +1,55 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.ranges project-euler.common sequences ; +IN: project-euler.033 + +! http://projecteuler.net/index.php?section=problems&id=33 + +! DESCRIPTION +! ----------- + +! The fraction 49/98 is a curious fraction, as an inexperienced mathematician +! in attempting to simplify it may incorrectly believe that 49/98 = 4/8, which +! is correct, is obtained by cancelling the 9s. + +! We shall consider fractions like, 30/50 = 3/5, to be trivial examples. + +! There are exactly four non-trivial examples of this type of fraction, less +! than one in value, and containing two digits in the numerator and +! denominator. + +! If the product of these four fractions is given in its lowest common terms, +! find the value of the denominator. + + +! SOLUTION +! -------- + +! Through analysis, you only need to check fractions fitting the pattern ax/xb + + + +: euler033 ( -- answer ) + source-033 curious-fractions product denominator ; + +! [ euler033 ] 100 ave-time +! 5 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler033 diff --git a/extra/project-euler/034/034.factor b/extra/project-euler/034/034.factor new file mode 100644 index 0000000000..83cffeb248 --- /dev/null +++ b/extra/project-euler/034/034.factor @@ -0,0 +1,47 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math.ranges project-euler.common sequences ; +IN: project-euler.034 + +! http://projecteuler.net/index.php?section=problems&id=34 + +! DESCRIPTION +! ----------- + +! 145 is a curious number, as 1! + 4! + 5! = 1 + 24 + 120 = 145. + +! Find the sum of all numbers which are equal to the sum of the factorial of +! their digits. + +! Note: as 1! = 1 and 2! = 2 are not sums they are not included. + + +! SOLUTION +! -------- + +! We can reduce the upper bound a little by calculating 7 * 9! = 2540160, and +! then reducing one of the 9! to 2! (since the 7th digit cannot exceed 2), so we +! get 2! + 6 * 9! = 2177282 as an upper bound. + +! We can then take that one more step, and notice that the largest factorial +! sum a 7 digit number starting with 21 or 20 is 2! + 1! + 5 * 9! or 1814403. +! So there can't be any 7 digit solutions starting with 21 or 20, and therefore +! our numbers must be less that 2000000. + +digits [ digit-factorial ] sigma = ; + +PRIVATE> + +: euler034 ( -- answer ) + 3 2000000 [a,b] [ factorion? ] subset sum ; + +! [ euler034 ] 10 ave-time +! 15089 ms run / 725 ms GC ave time - 10 trials + +MAIN: euler034 diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor new file mode 100644 index 0000000000..867bbc44ac --- /dev/null +++ b/extra/project-euler/035/035.factor @@ -0,0 +1,61 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math math.combinatorics math.parser math.primes + project-euler.common sequences ; +IN: project-euler.035 + +! http://projecteuler.net/index.php?section=problems&id=35 + +! DESCRIPTION +! ----------- + +! The number, 197, is called a circular prime because all rotations of the +! digits: 197, 971, and 719, are themselves prime. + +! There are thirteen such primes below 100: +! 2, 3, 5, 7, 11, 13, 17, 31, 37, 71, 73, 79, and 97. + +! How many circular primes are there below one million? + + +! SOLUTION +! -------- + +digits ] map ; + +: possible? ( seq -- ? ) + dup length 1 > [ + dup { 0 2 4 5 6 8 } swap seq-diff = + ] [ + drop t + ] if ; + +: rotate ( seq n -- seq ) + cut* swap append ; + +: (circular?) ( seq n -- ? ) + dup 0 > [ + 2dup rotate 10 swap digits>integer + prime? [ 1- (circular?) ] [ 2drop f ] if + ] [ + 2drop t + ] if ; + +: circular? ( seq -- ? ) + dup length 1- (circular?) ; + +PRIVATE> + +: euler035 ( -- answer ) + source-035 [ possible? ] subset [ circular? ] count ; + +! [ euler035 ] 100 ave-time +! 904 ms run / 86 ms GC ave time - 100 trials + +! TODO: try using bit arrays or other methods outlined here: +! http://home.comcast.net/~babdulbaki/Circular_Primes.html + +MAIN: euler035 diff --git a/extra/project-euler/036/036.factor b/extra/project-euler/036/036.factor new file mode 100644 index 0000000000..00fc8c2682 --- /dev/null +++ b/extra/project-euler/036/036.factor @@ -0,0 +1,42 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math.parser math.ranges sequences ; +IN: project-euler.036 + +! http://projecteuler.net/index.php?section=problems&id=36 + +! DESCRIPTION +! ----------- + +! The decimal number, 585 = 1001001001 (binary), is palindromic in both bases. + +! Find the sum of all numbers, less than one million, which are palindromic in +! base 10 and base 2. + +! (Please note that the palindromic number, in either base, may not include +! leading zeros.) + + +! SOLUTION +! -------- + +! Only check odd numbers since the binary number must begin and end with 1 + +string palindrome? ] + [ dup >bin palindrome? ] } && nip ; + +PRIVATE> + +: euler036 ( -- answer ) + 1 1000000 2 [ both-bases? ] subset sum ; + +! [ euler036 ] 100 ave-time +! 3891 ms run / 173 ms GC ave time - 100 trials + +MAIN: euler036 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 2bd2b7ec0b..2e718ab5a2 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,5 +1,5 @@ -USING: kernel math math.functions math.miller-rabin math.parser - math.primes.factors math.ranges namespaces sequences ; +USING: arrays combinators.lib kernel math math.functions math.miller-rabin + math.parser math.primes.factors math.ranges namespaces sequences ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution @@ -7,10 +7,11 @@ IN: project-euler.common ! Problems using each public word ! ------------------------------- +! cartesian-product - #4, #27, #29, #32, #33 ! collect-consecutive - #8, #11 ! log10 - #25, #134 ! max-path - #18, #67 -! number>digits - #16, #20 +! number>digits - #16, #20, #30, #34 ! propagate-all - #18, #67 ! sum-proper-divisors - #21 ! tau* - #12 @@ -45,6 +46,9 @@ IN: project-euler.common PRIVATE> +: cartesian-product ( seq1 seq2 -- seq1xseq2 ) + swap [ swap [ 2array ] map-with ] map-with concat ; + : collect-consecutive ( seq width -- seq ) [ 2dup count-shifts [ 2dup head shift-3rd , ] times diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 6abb056d28..feef9dbfa8 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. USING: definitions io io.files kernel math.parser sequences vocabs vocabs.loader project-euler.ave-time project-euler.common math @@ -8,8 +8,11 @@ USING: definitions io io.files kernel math.parser sequences vocabs project-euler.013 project-euler.014 project-euler.015 project-euler.016 project-euler.017 project-euler.018 project-euler.019 project-euler.020 project-euler.021 project-euler.022 project-euler.023 project-euler.024 - project-euler.025 project-euler.026 project-euler.067 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.025 project-euler.026 project-euler.027 project-euler.028 + project-euler.029 project-euler.030 project-euler.031 project-euler.032 + project-euler.033 project-euler.034 project-euler.035 project-euler.036 + project-euler.067 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler matches? ] unit-test [ t ] [ "x" "\\x78" f matches? ] unit-test [ f ] [ "y" "\\x78" f matches? ] unit-test -[ t ] [ "x" "\\u0078" f matches? ] unit-test -[ f ] [ "y" "\\u0078" f matches? ] unit-test +[ t ] [ "x" "\\u000078" f matches? ] unit-test +[ f ] [ "y" "\\u000078" f matches? ] unit-test [ t ] [ "ab" "a+b" f matches? ] unit-test [ f ] [ "b" "a+b" f matches? ] unit-test diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index c4b60e76e4..ef88e84f05 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -1,7 +1,7 @@ USING: arrays combinators kernel lazy-lists math math.parser namespaces parser parser-combinators parser-combinators.simple promises quotations sequences combinators.lib strings -assocs prettyprint.backend memoize ; +assocs prettyprint.backend memoize unicode.case unicode.categories ; USE: io IN: regexp diff --git a/extra/regexp/tags.txt b/extra/regexp/tags.txt new file mode 100755 index 0000000000..65bc471f6b --- /dev/null +++ b/extra/regexp/tags.txt @@ -0,0 +1,2 @@ +parsing +text diff --git a/extra/roman/roman.factor b/extra/roman/roman.factor index 130dfb127d..7466883c5f 100644 --- a/extra/roman/roman.factor +++ b/extra/roman/roman.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel math math.vectors namespaces -quotations sequences sequences.lib sequences.private strings ; +quotations sequences sequences.lib sequences.private strings unicode.case ; IN: roman string create-in ] keep - shuffle>quot dupd define-compound put-effect + shuffle>quot dupd define put-effect ] with each out-shuffle ; : SHUFFLE: diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index ba423699c3..a0065d6fe3 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -33,7 +33,7 @@ IN: slides { list-style H{ { table-gap { 10 20 } } } } - { bullet "\u00b7" } + { bullet "\u0000b7" } } ; : $title ( string -- ) diff --git a/extra/slides/summary.txt b/extra/slides/summary.txt new file mode 100755 index 0000000000..c3be28003e --- /dev/null +++ b/extra/slides/summary.txt @@ -0,0 +1 @@ +Bare-bones tools for giving presentations and demonstrations with the Factor UI diff --git a/extra/space-invaders/resources/invaders.rom b/extra/space-invaders/resources/invaders.rom new file mode 100644 index 0000000000..606ec01945 Binary files /dev/null and b/extra/space-invaders/resources/invaders.rom differ diff --git a/extra/springies/models/2snake/authors.txt b/extra/springies/models/2snake/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/springies/models/2snake/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/springies/models/2x2snake/authors.txt b/extra/springies/models/2x2snake/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/springies/models/2x2snake/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/springies/models/3snake/authors.txt b/extra/springies/models/3snake/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/springies/models/3snake/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/springies/models/ball/authors.txt b/extra/springies/models/ball/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/springies/models/ball/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/springies/models/belt-tire/authors.txt b/extra/springies/models/belt-tire/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/springies/models/belt-tire/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/springies/models/nifty/authors.txt b/extra/springies/models/nifty/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/springies/models/nifty/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/springies/models/urchin/authors.txt b/extra/springies/models/urchin/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/springies/models/urchin/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/springies/ui/authors.txt b/extra/springies/ui/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/springies/ui/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/sqlite/authors.txt b/extra/sqlite/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/sqlite/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/sqlite/lib/authors.txt b/extra/sqlite/lib/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/sqlite/lib/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/sqlite/tuple-db/authors.txt b/extra/sqlite/tuple-db/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/sqlite/tuple-db/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/state-machine/authors.txt b/extra/state-machine/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/state-machine/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor index 85f4812d9a..ac0bdc81c7 100644 --- a/extra/state-machine/state-machine.factor +++ b/extra/state-machine/state-machine.factor @@ -7,7 +7,7 @@ IN: state-machine ";" parse-tokens [ length ] keep unclip add - [ create-in swap 1quotation define-compound ] 2each ; parsing + [ create-in swap 1quotation define ] 2each ; parsing TUPLE: state place data ; @@ -27,7 +27,7 @@ M: missing-state error. : define-machine ( word state-class -- ) execute make-machine - >r over r> define-compound + >r over r> define "state-table" set-word-prop ; : MACHINE: diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index c0e6318403..19a4af44cc 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: io io.streams.string kernel math namespaces sequences -strings circular prettyprint debugger ; +strings circular prettyprint debugger unicode.categories ; IN: state-parser ! * Basic underlying words diff --git a/extra/store/blob/blob.factor b/extra/store/blob/blob.factor deleted file mode 100644 index 9cec77c6c2..0000000000 --- a/extra/store/blob/blob.factor +++ /dev/null @@ -1,22 +0,0 @@ -! Copyright (C) 2006 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel io io.files namespaces serialize ; -IN: store.blob - -: (save-blob) serialize ; - -: save-blob ( obj path -- ) - [ (save-blob) ] with-stream ; - -: (load-blob) ( path -- seq/f ) - dup exists? [ - [ - deserialize-sequence - ] with-stream - ] [ - drop f - ] if ; - -: load-blob ( path -- seq/f ) - resource-path (load-blob) ; - diff --git a/extra/store/store-tests.factor b/extra/store/store-tests.factor deleted file mode 100644 index 6f33d66101..0000000000 --- a/extra/store/store-tests.factor +++ /dev/null @@ -1,35 +0,0 @@ -USING: assocs continuations debugger io.files kernel -namespaces store tools.test ; -IN: temporary - -SYMBOL: store -SYMBOL: foo - -: the-store ( -- path ) - "store-test.store" resource-path ; - -: delete-the-store ( -- ) - [ the-store delete-file ] catch drop ; - -: load-the-store ( -- ) - the-store load-store store set-global ; - -: save-the-store ( -- ) - store save-store ; - -delete-the-store -load-the-store - -[ f ] [ foo store get-persistent ] unit-test - -USE: prettyprint -store get-global store-data . - -[ ] [ 100 foo store set-persistent ] unit-test - -[ ] [ save-the-store ] unit-test - -[ 100 ] [ foo store get-persistent ] unit-test - -delete-the-store -f store set-global diff --git a/extra/store/store.factor b/extra/store/store.factor deleted file mode 100644 index 46b1a09568..0000000000 --- a/extra/store/store.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (C) 2006, 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs io io.files kernel namespaces serialize init ; -IN: store - -TUPLE: store path data ; - -C: store - -: save-store ( store -- ) - get-global dup store-data swap store-path - [ serialize ] with-stream ; - -: load-store ( path -- store ) - dup exists? [ - dup [ deserialize ] with-stream - ] [ - H{ } clone - ] if ; - -: define-store ( path id -- ) - over >r - [ >r resource-path load-store r> set-global ] 2curry - r> add-init-hook ; - -: get-persistent ( key store -- value ) - get-global store-data at ; - -: set-persistent ( value key store -- ) - [ get-global store-data set-at ] keep save-store ; - -: init-persistent ( value key store -- ) - 2dup get-persistent [ 3drop ] [ set-persistent ] if ; diff --git a/extra/strings/lib/authors.txt b/extra/strings/lib/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/strings/lib/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor index 223fdb2090..719881b768 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -1,14 +1,14 @@ USING: math arrays sequences kernel splitting strings ; IN: strings.lib -: char>digit ( c -- i ) 48 - ; +! : char>digit ( c -- i ) 48 - ; -: string>digits ( s -- seq ) [ char>digit ] { } map-as ; +! : string>digits ( s -- seq ) [ char>digit ] { } map-as ; -: >Upper ( str -- str ) - dup empty? [ - unclip ch>upper 1string swap append - ] unless ; +! : >Upper ( str -- str ) +! dup empty? [ +! unclip ch>upper 1string swap append +! ] unless ; -: >Upper-dashes ( str -- str ) - "-" split [ >Upper ] map "-" join ; +! : >Upper-dashes ( str -- str ) +! "-" split [ >Upper ] map "-" join ; diff --git a/extra/structs/authors.txt b/extra/structs/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/structs/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/structs/structs.factor b/extra/structs/structs.factor index c0792ed317..f54917dc47 100644 --- a/extra/structs/structs.factor +++ b/extra/structs/structs.factor @@ -10,4 +10,3 @@ C-STRUCT: timeval "timeval" [ set-timeval-usec ] keep [ set-timeval-sec ] keep ; - diff --git a/extra/tar/authors.txt b/extra/tar/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/tar/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor old mode 100644 new mode 100755 index 4a737f06c2..363ce6b412 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,5 +1,6 @@ +<<<<<<< HEAD:extra/tar/tar.factor USING: combinators io io.files io.streams.duplex -io.streams.string kernel math math.parser +io.streams.string kernel math math.parser continuations namespaces pack prettyprint sequences strings system ; USING: hexdump tools.interpreter ; IN: tar @@ -95,7 +96,7 @@ TUPLE: unimplemented-typeflag header ; ! Normal file : typeflag-0 tar-header-name tar-path+ - [ read-data-blocks ] keep stream-close ; + [ read-data-blocks ] keep dispose ; ! Hard link : typeflag-1 ( header -- ) @@ -221,7 +222,7 @@ TUPLE: unimplemented-typeflag header ; [ throw ] } case ! dup tar-header-size zero? [ - ! out-stream get [ stream-close ] when + ! out-stream get [ dispose ] when ! out-stream off ! drop ! ] [ diff --git a/extra/tetris/board/authors.txt b/extra/tetris/board/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tetris/board/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tetris/game/authors.txt b/extra/tetris/game/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tetris/game/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tetris/gl/authors.txt b/extra/tetris/gl/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tetris/gl/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tetris/piece/authors.txt b/extra/tetris/piece/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tetris/piece/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tetris/tetromino/authors.txt b/extra/tetris/tetromino/authors.txt new file mode 100755 index 0000000000..e9c193bac7 --- /dev/null +++ b/extra/tetris/tetromino/authors.txt @@ -0,0 +1 @@ +Alex Chapman diff --git a/extra/tools/browser/authors.txt b/extra/tools/browser/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tools/browser/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tools/completion/completion.factor b/extra/tools/completion/completion.factor old mode 100644 new mode 100755 index bb15a3fa87..e44c3c401e --- a/extra/tools/completion/completion.factor +++ b/extra/tools/completion/completion.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: tools.completion USING: kernel arrays sequences math namespaces strings io -vectors words assocs combinators sorting ; +vectors words assocs combinators sorting unicode.case +unicode.categories ; : (fuzzy) ( accum ch i full -- accum i ? ) index* @@ -60,13 +61,14 @@ vectors words assocs combinators sorting ; dupd fuzzy score max ; : completion ( short candidate -- result ) - [ second swap complete ] keep first 2array ; + [ second >lower swap complete ] keep first 2array ; : completions ( short candidates -- seq ) over empty? [ nip [ first ] map ] [ - >r >lower r> [ completion ] with map rank-completions + >r >lower r> [ completion ] with map + rank-completions ] if ; : string-completions ( short strs -- seq ) diff --git a/extra/tools/deploy/backend/authors.txt b/extra/tools/deploy/backend/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tools/deploy/backend/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index b7b3da7411..f2bd03475f 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -9,50 +9,78 @@ quotations io.launcher words.private tools.deploy.config bootstrap.image ; IN: tools.deploy.backend +: (copy-lines) ( stream -- ) + dup stream-readln dup + [ print flush (copy-lines) ] [ 2drop ] if ; + +: copy-lines ( stream -- ) + [ (copy-lines) ] with-disposal ; + +: run-with-output ( descriptor -- ) + + dup duplex-stream-out dispose + copy-lines ; + : boot-image-name ( -- string ) "boot." my-arch ".image" 3append ; -: stage1 ( -- ) +: make-boot-image ( -- ) #! If stage1 image doesn't exist, create one. boot-image-name resource-path exists? [ my-arch make-image ] unless ; -: (copy-lines) ( stream -- stream ) - dup stream-readln [ print flush (copy-lines) ] when* ; +: ?, [ , ] [ drop ] if ; -: copy-lines ( stream -- ) - [ (copy-lines) ] [ stream-close ] [ ] cleanup ; - -: ?append swap [ append ] [ drop ] if ; - -: profile-string ( config -- string ) +: bootstrap-profile ( config -- profile ) [ - "" - deploy-math? get " math" ?append - deploy-compiler? get " compiler" ?append - deploy-ui? get " ui" ?append - native-io? " io" ?append + [ + "math" deploy-math? get ?, + "compiler" deploy-compiler? get ?, + "ui" deploy-ui? get ?, + "io" native-io? ?, + ] { } make ] bind ; -: deploy-command-line ( vm image vocab config -- vm flags ) +: staging-image-name ( profile -- name ) + "staging." swap bootstrap-profile "-" join ".image" 3append ; + +: staging-command-line ( config -- flags ) [ - "-include=" swap profile-string append , + "-i=" boot-image-name append , - "-deploy-vocab=" swap append , + "-output-image=" over staging-image-name append , - "-output-image=" swap append , + "-include=" swap bootstrap-profile " " join append , "-no-stack-traces" , "-no-user-init" , ] { } make ; -: stage2 ( vm image vocab config -- ) - deploy-command-line - >r "-i=" boot-image-name append 2array r> append dup . - - dup duplex-stream-out stream-close - copy-lines ; +: run-factor ( vm flags -- ) + dup . swap add* run-with-output ; inline + +: make-staging-image ( vm config -- ) + staging-command-line run-factor ; + +: deploy-command-line ( image vocab config -- flags ) + [ + "-i=" swap staging-image-name append , + + "-run=tools.deploy.shaker" , + + "-deploy-vocab=" swap append , + + "-output-image=" swap append , + + "-no-stack-traces" , + ] { } make ; + +: make-deploy-image ( vm image vocab config -- ) + dup staging-image-name exists? [ + >r pick r> tuck make-staging-image + ] unless + deploy-command-line run-factor ; SYMBOL: deploy-implementation diff --git a/extra/tools/deploy/config/authors.txt b/extra/tools/deploy/config/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tools/deploy/config/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tools/deploy/macosx/authors.txt b/extra/tools/deploy/macosx/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tools/deploy/macosx/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 7b44703013..1bbf198ea0 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -8,10 +8,10 @@ QUALIFIED: unix IN: tools.deploy.macosx : touch ( path -- ) - { "touch" } swap add run-process ; + { "touch" } swap add run-process drop ; : rm ( path -- ) - { "rm" "-rf" } swap add run-process ; + { "rm" "-rf" } swap add run-process drop ; : bundle-dir ( -- dir ) vm parent-directory parent-directory ; @@ -72,13 +72,12 @@ T{ macosx-deploy-implementation } deploy-implementation set-global -> selectFile:inFileViewerRootedAtPath: drop ; M: macosx-deploy-implementation deploy* ( vocab -- ) - stage1 ".app deploy tool" assert.app "." resource-path cd dup deploy-config [ bundle-name rm [ bundle-name create-app-dir ] keep [ bundle-name deploy.app-image ] keep - namespace stage2 + namespace make-deploy-image bundle-name show-in-finder ] bind ; diff --git a/extra/tools/deploy/shaker/authors.txt b/extra/tools/deploy/shaker/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tools/deploy/shaker/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index d157571757..f2b951ad16 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -5,13 +5,13 @@ assocs kernel vocabs words sequences memory io system arrays continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.streams.duplex io.files io.backend -quotations words.private tools.deploy.config ; +quotations words.private tools.deploy.config compiler.units ; IN: tools.deploy.shaker : show ( msg -- ) #! Use primitives directly so that we can print stuff even #! after most of the image has been stripped away - "\r\n" append stdout fwrite stdout fflush ; + "\r\n" append stdout-handle fwrite stdout-handle fflush ; : strip-init-hooks ( -- ) "Stripping startup hooks" show diff --git a/extra/tools/deploy/windows/authors.txt b/extra/tools/deploy/windows/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tools/deploy/windows/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor index 01a7009ecd..00dbc2e4df 100755 --- a/extra/tools/deploy/windows/windows.factor +++ b/extra/tools/deploy/windows/windows.factor @@ -34,11 +34,10 @@ TUPLE: windows-deploy-implementation ; T{ windows-deploy-implementation } deploy-implementation set-global M: windows-deploy-implementation deploy* - stage1 "." resource-path cd dup deploy-config [ [ deploy-name get create-exe-dir ] keep [ deploy-name get image-name ] keep - [ namespace stage2 ] keep + [ namespace make-deploy-image ] keep open-in-explorer ] bind ; diff --git a/extra/tools/interpreter/debug/authors.txt b/extra/tools/interpreter/debug/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tools/interpreter/debug/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tools/test/inference/authors.txt b/extra/tools/test/inference/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tools/test/inference/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index 48a1192282..32825c965d 100644 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -6,7 +6,7 @@ ARTICLE: "tools.test" "Unit testing" $nl "For example, if you were developing a word for computing symbolic derivatives, your unit tests would apply the word to certain input functions, comparing the results against the correct values. While the passing of these tests would not guarantee the algorithm is correct, it would at least ensure that what used to work keeps working, in that as soon as something breaks due to a change in another part of your program, failing tests will let you know." $nl -"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } " -tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details." +"Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details." $nl "If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:" { $subsection unit-test } diff --git a/extra/tools/test/ui/authors.txt b/extra/tools/test/ui/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/tools/test/ui/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/tuple-syntax/tags.txt b/extra/tuple-syntax/tags.txt index 71c0ff7282..abf53a421b 100644 --- a/extra/tuple-syntax/tags.txt +++ b/extra/tuple-syntax/tags.txt @@ -1 +1 @@ -syntax +reflection diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor old mode 100644 new mode 100755 index e0d991e1b2..04f655853a --- a/extra/ui/commands/commands.factor +++ b/extra/ui/commands/commands.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions kernel sequences strings math assocs words generic namespaces assocs quotations splitting -ui.gestures ; +ui.gestures unicode.case unicode.categories ; IN: ui.commands SYMBOL: +nullary+ @@ -51,7 +51,7 @@ GENERIC: command-word ( command -- word ) update-gestures ; : (command-name) ( string -- newstring ) - "-" split " " join unclip ch>upper add* ; + "-" split " " join >title ; M: word command-name ( word -- str ) word-name diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor old mode 100644 new mode 100755 index 48164c08f6..0d7522332f --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays io kernel libc math -math.vectors namespaces opengl opengl.gl prettyprint assocs +USING: alien alien.accessors alien.c-types arrays io kernel libc +math math.vectors namespaces opengl opengl.gl prettyprint assocs sequences io.files io.styles continuations freetype -ui.gadgets.worlds ui.render ui.backend io.mmap ; +ui.gadgets.worlds ui.render ui.backend byte-arrays ; IN: ui.freetype TUPLE: freetype-renderer ; @@ -63,18 +63,23 @@ M: freetype-renderer free-fonts ( world -- ) : ttf-path ( name -- string ) "/fonts/" swap ".ttf" 3append resource-path ; -: (open-face) ( mapped-file -- face ) +: (open-face) ( path length -- face ) #! We use FT_New_Memory_Face, not FT_New_Face, since #! FT_New_Face only takes an ASCII path name and causes #! problems on localized versions of Windows - freetype swap dup mapped-file-address swap length 0 f - [ FT_New_Memory_Face freetype-error ] keep *void* ; + freetype -rot 0 f [ + FT_New_Memory_Face freetype-error + ] keep *void* ; : open-face ( font style -- face ) - ttf-name ttf-path dup file-length - (open-face) ; + ttf-name ttf-path + dup file-contents >byte-array malloc-byte-array + swap file-length + (open-face) ; -: dpi 72 ; inline +SYMBOL: dpi + +72 dpi set-global : ft-floor -6 shift ; inline @@ -101,7 +106,8 @@ M: freetype-renderer free-fonts ( world -- ) : (open-font) ( font -- open-font ) first3 >r open-face dup 0 r> 6 shift - dpi dpi FT_Set_Char_Size freetype-error ; + dpi get-global dpi get-global FT_Set_Char_Size + freetype-error ; M: freetype-renderer open-font ( font -- open-font ) freetype drop open-fonts get [ (open-font) ] cache ; diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index a2786ea878..77dfd30d96 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -17,7 +17,7 @@ TUPLE: foo-gadget ; T{ foo-gadget } "t" set [ 2 ] [ "t" get gadget-children length ] unit-test -[ "Foo a" ] [ "t" get gadget-child gadget-child label-string ] unit-test +[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test [ ] [ 2 { diff --git a/extra/ui/gadgets/canvas/authors.txt b/extra/ui/gadgets/canvas/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/ui/gadgets/canvas/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/ui/gadgets/handler/authors.txt b/extra/ui/gadgets/handler/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/ui/gadgets/handler/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/ui/gadgets/labels/labels.factor b/extra/ui/gadgets/labels/labels.factor index 2ac0240ed1..5e5801dd02 100755 --- a/extra/ui/gadgets/labels/labels.factor +++ b/extra/ui/gadgets/labels/labels.factor @@ -40,7 +40,7 @@ M: label gadget-text* label-string % ; TUPLE: label-control ; M: label-control model-changed - swap model-value over set-label-text relayout ; + swap model-value over set-label-string relayout ; : ( model -- gadget ) ""

blah

" ] [ test-refs ] unit-test +[ "foo

" ] [ test-refs ] unit-test diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index 80a508787e..ec59d3564e 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -26,7 +26,7 @@ SYMBOL: xml-file ] unit-test [ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test [ "that" ] [ xml-file get "this" swap at ] unit-test -[ "\n" ] +[ "" ] [ "" string>xml xml>string ] unit-test [ "abcd" ] [ "

abcd
" string>xml @@ -44,7 +44,7 @@ SYMBOL: xml-file at swap "z" >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test [ "foo" ] [ "" string>xml children>string ] unit-test -[ "\nbar baz" ] +[ "bar baz" ] [ "bar" string>xml [ " baz" append ] map xml>string ] unit-test [ "\n\n bar\n" ] [ " bar " string>xml pprint-xml>string ] unit-test diff --git a/extra/xml/tokenize/authors.txt b/extra/xml/tokenize/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/xml/tokenize/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/xml/tokenize/tokenize.factor b/extra/xml/tokenize/tokenize.factor index 85a473f503..d99c306b2b 100644 --- a/extra/xml/tokenize/tokenize.factor +++ b/extra/xml/tokenize/tokenize.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: xml.errors xml.data xml.utilities xml.char-classes xml.entities kernel state-parser kernel namespaces strings math -math.parser sequences assocs arrays splitting combinators ; +math.parser sequences assocs arrays splitting combinators unicode.case ; IN: xml.tokenize ! XML namespace processing: ns = namespace diff --git a/extra/xml/utilities/authors.txt b/extra/xml/utilities/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/xml/utilities/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/xml/writer/authors.txt b/extra/xml/writer/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/xml/writer/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 7bd1cc3046..8c7b51d756 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings -io io.streams.string xml.data assocs ; +io io.streams.string xml.data assocs wrap xml.entities +unicode.categories ; IN: xml.writer SYMBOL: xml-pprint? @@ -13,10 +14,13 @@ SYMBOL: indenter : sensitive? ( tag -- ? ) sensitive-tags get swap [ names-match? ] curry contains? ; +: indent-string ( -- string ) + xml-pprint? get + [ indentation get indenter get concat ] + [ "" ] if ; + : ?indent ( -- ) - xml-pprint? get [ - nl indentation get indenter get [ write ] each - ] when ; + xml-pprint? get [ nl indent-string write ] when ; : indent ( -- ) xml-pprint? get [ 1 indentation +@ ] when ; @@ -35,30 +39,6 @@ SYMBOL: indenter [ dup empty? swap string? and not ] subset ] when ; -: entities-out - H{ - { CHAR: < "<" } - { CHAR: > ">" } - { CHAR: & "&" } - } ; - -: quoted-entities-out - H{ - { CHAR: & "&" } - { CHAR: ' "'" } - { CHAR: " """ } - } ; - -: escape-string-by ( str table -- escaped ) - #! Convert <, >, &, ' and " to HTML entities. - [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ; - -: escape-string ( str -- newstr ) - entities-out escape-string-by ; - -: escape-quoted-string ( str -- newstr ) - quoted-entities-out escape-string-by ; - : print-name ( name -- ) dup name-space f like [ write CHAR: : write1 ] when* @@ -76,10 +56,11 @@ SYMBOL: indenter GENERIC: write-item ( object -- ) M: string write-item - escape-string write ; + escape-string dup empty? not xml-pprint? get and + [ nl 80 indent-string indented-break ] when write ; : write-tag ( tag -- ) - CHAR: < write1 + ?indent CHAR: < write1 dup print-name tag-attrs print-attrs ; M: contained-tag write-item @@ -87,7 +68,7 @@ M: contained-tag write-item : write-children ( tag -- ) indent tag-children ?filter-children - [ ?indent write-item ] each unindent ; + [ write-item ] each unindent ; : write-end-tag ( tag -- ) ?indent " write1 ; @@ -112,7 +93,7 @@ M: instruction write-item "\n" write ; + "\"?>" write ; : write-chunk ( seq -- ) [ write-item ] each ; diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor index 826b16b213..65a8e28dea 100644 --- a/extra/xml/xml.factor +++ b/extra/xml/xml.factor @@ -3,7 +3,7 @@ USING: io io.streams.string io.files kernel math namespaces prettyprint sequences arrays generic strings vectors xml.char-classes xml.data xml.errors xml.tokenize xml.writer -xml.utilities state-parser assocs ; +xml.utilities state-parser assocs unicode.categories ; IN: xml ! -- Overall parser with data tree diff --git a/extra/xmode/README.txt b/extra/xmode/README.txt index 57d9f42b22..07d56dd877 100755 --- a/extra/xmode/README.txt +++ b/extra/xmode/README.txt @@ -36,6 +36,9 @@ to depend on: find a mode file which depends on this flaw, please fix it and submit the changes to the jEdit project. +- References to non-existent rule sets in IMPORT tags and DELEGATE + attributes were ignored in jEdit. They raise an error in Factor. + If you wish to contribute a new or improved mode file, please contact the jEdit project. Updated mode files in jEdit will be periodically imported into the Factor source tree. diff --git a/extra/xmode/catalog/authors.txt b/extra/xmode/catalog/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/xmode/catalog/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index 6a0efa072e..9c7e6a1ee7 100644 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -42,9 +42,12 @@ MEMO: (load-mode) ( name -- rule-sets ) SYMBOL: rule-sets +: no-such-rule-set ( name -- * ) + "No such rule set: " swap append throw ; + : get-rule-set ( name -- rule-sets rules ) - "::" split1 [ swap (load-mode) ] [ rule-sets get ] if* - tuck at ; + dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if* + dup -roll at* [ nip ] [ drop no-such-rule-set ] if ; : resolve-delegate ( rule -- ) dup rule-delegate dup string? @@ -68,14 +71,11 @@ SYMBOL: rule-sets : resolve-imports ( ruleset -- ) dup rule-set-imports [ - get-rule-set dup [ - swap rule-sets [ - 2dup import-keywords - import-rules - ] with-variable - ] [ - 3drop - ] if + get-rule-set swap rule-sets [ + dup resolve-delegates + 2dup import-keywords + import-rules + ] with-variable ] with each ; : finalize-rule-set ( ruleset -- ) @@ -99,7 +99,7 @@ SYMBOL: rule-sets (load-mode) dup finalize-mode ; : reset-modes ( -- ) - \ load-mode "memoize" word-prop clear-assoc ; + \ (load-mode) "memoize" word-prop clear-assoc ; : ?glob-matches ( string glob/f -- ? ) dup [ glob-matches? ] [ 2drop f ] if ; diff --git a/extra/xmode/code2html/authors.txt b/extra/xmode/code2html/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/xmode/code2html/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/xmode/keyword-map/authors.txt b/extra/xmode/keyword-map/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/xmode/keyword-map/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/xmode/keyword-map/keyword-map.factor b/extra/xmode/keyword-map/keyword-map.factor index 350d8572a0..4e97e597b2 100644 --- a/extra/xmode/keyword-map/keyword-map.factor +++ b/extra/xmode/keyword-map/keyword-map.factor @@ -1,4 +1,5 @@ -USING: kernel strings assocs sequences hashtables sorting ; +USING: kernel strings assocs sequences hashtables sorting + unicode.case unicode.categories ; IN: xmode.keyword-map ! Based on org.gjt.sp.jedit.syntax.KeywordMap diff --git a/extra/xmode/loader/authors.txt b/extra/xmode/loader/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/xmode/loader/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/xmode/loader/syntax/authors.txt b/extra/xmode/loader/syntax/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/xmode/loader/syntax/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/xmode/marker/authors.txt b/extra/xmode/marker/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/xmode/marker/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/xmode/marker/context/authors.txt b/extra/xmode/marker/context/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/xmode/marker/context/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/xmode/marker/context/context.factor b/extra/xmode/marker/context/context.factor index 8023e1d321..72ac3f2a3f 100644 --- a/extra/xmode/marker/context/context.factor +++ b/extra/xmode/marker/context/context.factor @@ -10,6 +10,7 @@ end ; : ( ruleset parent -- line-context ) + over [ "no context" throw ] unless { set-line-context-in-rule-set set-line-context-parent } line-context construct ; diff --git a/extra/xmode/marker/marker-tests.factor b/extra/xmode/marker/marker-tests.factor index b9621a112a..6bcba91c84 100755 --- a/extra/xmode/marker/marker-tests.factor +++ b/extra/xmode/marker/marker-tests.factor @@ -133,3 +133,11 @@ IN: temporary ] [ f "font:75%/1.6em \"Lucida Grande\", \"Lucida Sans Unicode\", verdana, geneva, sans-serif;" "css" load-mode tokenize-line 2drop ] unit-test + +[ + { + T{ token f "<" MARKUP } + T{ token f "aaa" MARKUP } + T{ token f ">" MARKUP } + } +] [ f "" "html" load-mode tokenize-line nip ] unit-test diff --git a/extra/xmode/marker/marker.factor b/extra/xmode/marker/marker.factor index b8331fe6b6..91ccd43907 100755 --- a/extra/xmode/marker/marker.factor +++ b/extra/xmode/marker/marker.factor @@ -2,7 +2,7 @@ IN: xmode.marker USING: kernel namespaces xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities xmode.catalog sequences math assocs combinators combinators.lib -strings regexp splitting parser-combinators ; +strings regexp splitting parser-combinators ascii unicode.case ; ! Based on org.gjt.sp.jedit.syntax.TokenMarker diff --git a/extra/xmode/marker/state/authors.txt b/extra/xmode/marker/state/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/xmode/marker/state/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/xmode/modes/bcel.xml b/extra/xmode/modes/bcel.xml index 19ab3cfd67..628911f431 100644 --- a/extra/xmode/modes/bcel.xml +++ b/extra/xmode/modes/bcel.xml @@ -19,7 +19,7 @@ /**/ - + /** */ diff --git a/extra/xmode/modes/clips.xml b/extra/xmode/modes/clips.xml index ce2efcabab..51d89d05eb 100644 --- a/extra/xmode/modes/clips.xml +++ b/extra/xmode/modes/clips.xml @@ -33,7 +33,7 @@ - + [ ] diff --git a/extra/xmode/modes/objective-c.xml b/extra/xmode/modes/objective-c.xml index c6c52c8211..7496838938 100644 --- a/extra/xmode/modes/objective-c.xml +++ b/extra/xmode/modes/objective-c.xml @@ -89,7 +89,7 @@ elif\b if\b - + diff --git a/extra/xmode/modes/powerdynamo.xml b/extra/xmode/modes/powerdynamo.xml index 7babf3dc74..f5eb29e49c 100644 --- a/extra/xmode/modes/powerdynamo.xml +++ b/extra/xmode/modes/powerdynamo.xml @@ -200,11 +200,11 @@ for the other tags (data, document, etc). more support planned for future. */ - + " " - + ' ' @@ -413,11 +413,11 @@ for the other tags (data, document, etc). more support planned for future. - + " " - + ' ' @@ -428,11 +428,11 @@ for the other tags (data, document, etc). more support planned for future. - + " " - + ' ' @@ -444,11 +444,11 @@ for the other tags (data, document, etc). more support planned for future. - + " " - + ' ' diff --git a/extra/xmode/modes/rview.xml b/extra/xmode/modes/rview.xml index 9747465814..2ca2fdf36a 100644 --- a/extra/xmode/modes/rview.xml +++ b/extra/xmode/modes/rview.xml @@ -23,7 +23,7 @@ /**/ - + /** */ diff --git a/extra/xmode/modes/tthtml.xml b/extra/xmode/modes/tthtml.xml index 24d9667c6c..37bfa2fb17 100644 --- a/extra/xmode/modes/tthtml.xml +++ b/extra/xmode/modes/tthtml.xml @@ -101,7 +101,7 @@ HIGHLIGHT_DIGITS="TRUE" DIGIT_RE="(0x[\p{XDigit}]+[lL]?|[\p{Digit}]+(e[\p{Digit}]*)?[lLdDfF]?)"> - + ${ } diff --git a/extra/xmode/rules/authors.txt b/extra/xmode/rules/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/xmode/rules/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor index acc6308c6f..28237a7b2c 100755 --- a/extra/xmode/rules/rules.factor +++ b/extra/xmode/rules/rules.factor @@ -1,5 +1,5 @@ USING: xmode.tokens xmode.keyword-map kernel -sequences vectors assocs strings memoize regexp ; +sequences vectors assocs strings memoize regexp unicode.case ; IN: xmode.rules TUPLE: string-matcher string ignore-case? ; diff --git a/extra/xmode/tokens/authors.txt b/extra/xmode/tokens/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/xmode/tokens/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/xmode/utilities/authors.txt b/extra/xmode/utilities/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/xmode/utilities/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand b/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand new file mode 100644 index 0000000000..37867a2737 --- /dev/null +++ b/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand @@ -0,0 +1,27 @@ + + + + + beforeRunningCommand + nop + command + #!/usr/bin/env ruby + +require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" +puts factor_eval(STDIN.read) + fallbackInput + line + input + selection + keyEquivalent + ^E + name + Eval Selection/Line + output + replaceSelectedText + scope + source.factor + uuid + 8E01DDAF-959B-4237-ADB9-C133A4ACCE90 + + diff --git a/misc/Factor.tmbundle/Commands/Help for Word.tmCommand b/misc/Factor.tmbundle/Commands/Help for Word.tmCommand new file mode 100644 index 0000000000..0ff133c891 --- /dev/null +++ b/misc/Factor.tmbundle/Commands/Help for Word.tmCommand @@ -0,0 +1,30 @@ + + + + + beforeRunningCommand + nop + command + #!/usr/bin/env ruby + +require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" + +doc = STDIN.read +word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i) +factor_run(%Q(#{doc_using_statements(doc)} USE: ui.tools.workspace\n \\ #{word} help-window)) + fallbackInput + word + input + document + keyEquivalent + ^H + name + Help for Word + output + showAsTooltip + scope + source.factor + uuid + BC5BE120-734B-40DF-8B6B-5D3243614B27 + + diff --git a/misc/Factor.tmbundle/Commands/Infer Effect of Selection.tmCommand b/misc/Factor.tmbundle/Commands/Infer Effect of Selection.tmCommand new file mode 100644 index 0000000000..378294e6c1 --- /dev/null +++ b/misc/Factor.tmbundle/Commands/Infer Effect of Selection.tmCommand @@ -0,0 +1,27 @@ + + + + + beforeRunningCommand + nop + command + #!/usr/bin/env ruby + +require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" + +doc = STDIN.read +puts factor_eval(%Q(#{doc_using_statements(doc)} USE: inference\n [ #{ENV["TM_SELECTED_TEXT"]} ] infer.)) + fallbackInput + word + input + document + name + Infer Effect of Selection + output + showAsTooltip + scope + source.factor + uuid + B619FCC0-2DF2-4657-82A8-0E5676A10254 + + diff --git a/misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand b/misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand new file mode 100644 index 0000000000..f28e062541 --- /dev/null +++ b/misc/Factor.tmbundle/Commands/Run File in Listener.tmCommand @@ -0,0 +1,25 @@ + + + + + beforeRunningCommand + nop + command + #!/usr/bin/env ruby + +require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" +factor_run(%Q(USE: parser\n "#{ENV["TM_FILEPATH"]}" run-file)) + input + none + keyEquivalent + @r + name + Run File in Listener + output + discard + scope + source.factor + uuid + CAD3BB10-C480-4C0E-9518-94D61F7A0C0B + + diff --git a/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand b/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand new file mode 100644 index 0000000000..5028bd8db3 --- /dev/null +++ b/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand @@ -0,0 +1,27 @@ + + + + + beforeRunningCommand + nop + command + #!/usr/bin/env ruby + +require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" +factor_run(STDIN.read) + fallbackInput + line + input + selection + keyEquivalent + ^~e + name + Run Selection/Line in Listener + output + discard + scope + source.factor + uuid + 15A984BD-BC65-43E8-878A-267788C8DA70 + + diff --git a/misc/Factor.tmbundle/Commands/See Word.tmCommand b/misc/Factor.tmbundle/Commands/See Word.tmCommand new file mode 100644 index 0000000000..4502e235be --- /dev/null +++ b/misc/Factor.tmbundle/Commands/See Word.tmCommand @@ -0,0 +1,30 @@ + + + + + beforeRunningCommand + nop + command + #!/usr/bin/env ruby + +require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" + +doc = STDIN.read +word = line_current_word(ENV["TM_CURRENT_LINE"], ENV["TM_LINE_INDEX"].to_i) +puts factor_eval(%Q(#{doc_using_statements(doc)} USE: prettyprint\n \\ #{word} see)) + fallbackInput + word + input + document + keyEquivalent + ^h + name + See Word + output + showAsTooltip + scope + source.factor + uuid + 35484754-DBF9-4381-BB25-00CAB64DF4A1 + + diff --git a/misc/Factor.tmbundle/Support/lib/tm_factor.rb b/misc/Factor.tmbundle/Support/lib/tm_factor.rb new file mode 100644 index 0000000000..54272e5e36 --- /dev/null +++ b/misc/Factor.tmbundle/Support/lib/tm_factor.rb @@ -0,0 +1,38 @@ +require 'osx/cocoa' + +def _wait_for_return_value(pb) + origCount = pb.changeCount + sleep 0.125 while pb.changeCount == origCount +end + +def perform_service(service, in_string, wait_for_return_value=false) + p = OSX::NSPasteboard.pasteboardWithUniqueName + p.declareTypes_owner([OSX::NSStringPboardType], nil) + p.setString_forType(in_string, OSX::NSStringPboardType) + raise "Unable to call service #{service}" unless OSX::NSPerformService(service, p) + _wait_for_return_value(p) if wait_for_return_value + p.stringForType(OSX::NSStringPboardType) +end + +def textmate_front() + system %Q{osascript -e 'tell app "TextMate" to activate'}; +end + +def factor_run(code) + perform_service("Factor/Evaluate in Listener", code) +end + +def factor_eval(code) + r = perform_service("Factor/Evaluate Selection", code, true) + textmate_front + r +end + +def doc_using_statements(document) + document.scan(/\b(USING:\s[^;]*\s;|USE:\s+\S+|IN:\s\S+)/).join("\n") << "\n" +end + +def line_current_word(line, point) + left = line.rindex(/\s|^/, point - 1) + 1; right = line.index(/\s|$/, point) - 1 + line[left..right] +end diff --git a/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage b/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage index ec4961f312..199185c93d 100644 --- a/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage +++ b/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage @@ -1,5 +1,5 @@ - + fileTypes @@ -139,7 +139,7 @@ match - (^|(?<=\s))(drop|2drop|3drop|keep|2keep|3keep|nip|2nip|dup|2dup|3dup|dupd|over|pick|tuck|swap|rot|-rot|slip|2swap|swapd|>r|r>)(\s|$) + (^|(?<=\s))(drop|2drop|3drop|keep|2keep|3keep|nip|2nip|dup|2dup|3dup|dupd|over|pick|tuck|swap|rot|-rot|roll|-roll|slip|2swap|swapd|>r|r>)(\s|$) name keyword.control.stack.factor @@ -240,6 +240,44 @@ + + begin + <" + end + "> + name + string.quoted.double.multiline.factor + patterns + + + include + #escaped_characters + + + + + begin + (^|(?<=\s))(STRING:)\s+(\S+) + captures + + 2 + + name + keyword.colon.factor + + 3 + + name + entity.name.heredoc.factor + + + contentName + string.unquoted.heredoc.factor + end + ^;$ + name + definition.word.heredoc.factor + match inline|foldable @@ -254,9 +292,9 @@ begin - \(\s + \((?=\s) end - \s\) + (^|(?<=\s))\) name comment.parens.factor diff --git a/misc/Factor.tmbundle/Syntaxes/HTML (Factor).tmLanguage b/misc/Factor.tmbundle/Syntaxes/HTML (Factor).tmLanguage index 89c0f191b9..03394b933c 100644 --- a/misc/Factor.tmbundle/Syntaxes/HTML (Factor).tmLanguage +++ b/misc/Factor.tmbundle/Syntaxes/HTML (Factor).tmLanguage @@ -1,5 +1,5 @@ - + fileTypes diff --git a/misc/Factor.tmbundle/info.plist b/misc/Factor.tmbundle/info.plist index 8def3807d7..1ea756a1a5 100644 --- a/misc/Factor.tmbundle/info.plist +++ b/misc/Factor.tmbundle/info.plist @@ -1,9 +1,20 @@ - + name Factor + ordering + + 3C9C9C2A-314A-475B-A4E4-A68BAAF3F36E + 141517D7-73E0-4475-A481-71102575A175 + CAD3BB10-C480-4C0E-9518-94D61F7A0C0B + 15A984BD-BC65-43E8-878A-267788C8DA70 + 8E01DDAF-959B-4237-ADB9-C133A4ACCE90 + 35484754-DBF9-4381-BB25-00CAB64DF4A1 + BC5BE120-734B-40DF-8B6B-5D3243614B27 + B619FCC0-2DF2-4657-82A8-0E5676A10254 + uuid 8061D2F3-B603-411D-AFFE-61784A07906D diff --git a/misc/factor.sh b/misc/factor.sh index b2cbb836e6..39a15f93dc 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -13,286 +13,291 @@ WORD= NO_UI= ensure_program_installed() { - echo -n "Checking for $1..." - result=`type -p $1` - if ! [[ -n $result ]] ; then - echo "not found!" - echo "Install $1 and try again." - exit 1 - fi - echo "found!" + echo -n "Checking for $1..." + result=`type -p $1` + if ! [[ -n $result ]] ; then + echo "not found!" + echo "Install $1 and try again." + exit 1 + fi + echo "found!" } check_ret() { - RET=$? - if [[ $RET -ne 0 ]] ; then - echo $1 failed - exit 2 - fi + RET=$? + if [[ $RET -ne 0 ]] ; then + echo $1 failed + exit 2 + fi } check_gcc_version() { - echo -n "Checking gcc version..." - GCC_VERSION=`gcc --version` - check_ret gcc - if [[ $GCC_VERSION == *3.3.* ]] ; then - echo "bad!" - echo "You have a known buggy version of gcc (3.3)" - echo "Install gcc 3.4 or higher and try again." - exit 3 - fi - echo "ok." + echo -n "Checking gcc version..." + GCC_VERSION=`gcc --version` + check_ret gcc + if [[ $GCC_VERSION == *3.3.* ]] ; then + echo "bad!" + echo "You have a known buggy version of gcc (3.3)" + echo "Install gcc 3.4 or higher and try again." + exit 3 + fi + echo "ok." } check_installed_programs() { - ensure_program_installed chmod - ensure_program_installed uname - ensure_program_installed git - ensure_program_installed wget - ensure_program_installed gcc - ensure_program_installed make - check_gcc_version + ensure_program_installed sudo + ensure_program_installed chmod + ensure_program_installed uname + ensure_program_installed git + ensure_program_installed wget + ensure_program_installed gcc + ensure_program_installed make + check_gcc_version } check_library_exists() { - GCC_TEST=factor-library-test.c - GCC_OUT=factor-library-test.out - echo -n "Checking for library $1..." - echo "int main(){return 0;}" > $GCC_TEST - gcc $GCC_TEST -o $GCC_OUT -l $1 - if [[ $? -ne 0 ]] ; then - echo "not found!" - echo "Warning: library $1 not found." - echo "***Factor will compile NO_UI=1" - NO_UI=1 - fi - rm -f $GCC_TEST - check_ret rm - rm -f $GCC_OUT - check_ret rm - echo "found." + GCC_TEST=factor-library-test.c + GCC_OUT=factor-library-test.out + echo -n "Checking for library $1..." + echo "int main(){return 0;}" > $GCC_TEST + gcc $GCC_TEST -o $GCC_OUT -l $1 + if [[ $? -ne 0 ]] ; then + echo "not found!" + echo "Warning: library $1 not found." + echo "***Factor will compile NO_UI=1" + NO_UI=1 + fi + rm -f $GCC_TEST + check_ret rm + rm -f $GCC_OUT + check_ret rm + echo "found." } check_X11_libraries() { - check_library_exists freetype - check_library_exists GLU - check_library_exists GL - check_library_exists X11 + check_library_exists freetype + check_library_exists GLU + check_library_exists GL + check_library_exists X11 } check_libraries() { - case $OS in - linux) check_X11_libraries;; - esac + case $OS in + linux) check_X11_libraries;; + esac } check_factor_exists() { - if [[ -d "factor" ]] ; then - echo "A directory called 'factor' already exists." - echo "Rename or delete it and try again." - exit 4 - fi + if [[ -d "factor" ]] ; then + echo "A directory called 'factor' already exists." + echo "Rename or delete it and try again." + exit 4 + fi } find_os() { - echo "Finding OS..." - uname_s=`uname -s` - check_ret uname - case $uname_s in - CYGWIN_NT-5.2-WOW64) OS=windows-nt;; - *CYGWIN_NT*) OS=windows-nt;; - *CYGWIN*) OS=windows-nt;; - *darwin*) OS=macosx;; - *Darwin*) OS=macosx;; - *linux*) OS=linux;; - *Linux*) OS=linux;; - esac + echo "Finding OS..." + uname_s=`uname -s` + check_ret uname + case $uname_s in + CYGWIN_NT-5.2-WOW64) OS=windows-nt;; + *CYGWIN_NT*) OS=windows-nt;; + *CYGWIN*) OS=windows-nt;; + *darwin*) OS=macosx;; + *Darwin*) OS=macosx;; + *linux*) OS=linux;; + *Linux*) OS=linux;; + esac } find_architecture() { - echo "Finding ARCH..." - uname_m=`uname -m` - check_ret uname - case $uname_m in - i386) ARCH=x86;; - i686) ARCH=x86;; - *86) ARCH=x86;; - *86_64) ARCH=x86;; - "Power Macintosh") ARCH=ppc;; - esac + echo "Finding ARCH..." + uname_m=`uname -m` + check_ret uname + case $uname_m in + i386) ARCH=x86;; + i686) ARCH=x86;; + *86) ARCH=x86;; + *86_64) ARCH=x86;; + "Power Macintosh") ARCH=ppc;; + esac } write_test_program() { - echo "#include " > $C_WORD.c - echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c + echo "#include " > $C_WORD.c + echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c } find_word_size() { - echo "Finding WORD..." - C_WORD=factor-word-size - write_test_program - gcc -o $C_WORD $C_WORD.c - WORD=$(./$C_WORD) - check_ret $C_WORD - rm -f $C_WORD* + echo "Finding WORD..." + C_WORD=factor-word-size + write_test_program + gcc -o $C_WORD $C_WORD.c + WORD=$(./$C_WORD) + check_ret $C_WORD + rm -f $C_WORD* } set_factor_binary() { - case $OS in - windows-nt) FACTOR_BINARY=factor-nt;; - macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; - *) FACTOR_BINARY=factor;; - esac + case $OS in + windows-nt) FACTOR_BINARY=factor-nt;; + macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; + *) FACTOR_BINARY=factor;; + esac } echo_build_info() { - echo OS=$OS - echo ARCH=$ARCH - echo WORD=$WORD - echo FACTOR_BINARY=$FACTOR_BINARY - echo MAKE_TARGET=$MAKE_TARGET - echo BOOT_IMAGE=$BOOT_IMAGE - echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET + echo OS=$OS + echo ARCH=$ARCH + echo WORD=$WORD + echo FACTOR_BINARY=$FACTOR_BINARY + echo MAKE_TARGET=$MAKE_TARGET + echo BOOT_IMAGE=$BOOT_IMAGE + echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET } set_build_info() { - if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then - echo "OS: $OS" - echo "ARCH: $ARCH" - echo "WORD: $WORD" - echo "OS, ARCH, or WORD is empty. Please report this" - exit 5 - fi + if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then + echo "OS: $OS" + echo "ARCH: $ARCH" + echo "WORD: $WORD" + echo "OS, ARCH, or WORD is empty. Please report this" + exit 5 + fi - MAKE_TARGET=$OS-$ARCH-$WORD - MAKE_IMAGE_TARGET=$ARCH.$WORD - BOOT_IMAGE=boot.$ARCH.$WORD.image - if [[ $OS == macosx && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.macosx-ppc.image - fi - if [[ $OS == linux && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.linux-ppc.image - fi + MAKE_TARGET=$OS-$ARCH-$WORD + MAKE_IMAGE_TARGET=$ARCH.$WORD + BOOT_IMAGE=boot.$ARCH.$WORD.image + if [[ $OS == macosx && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.macosx-ppc.image + fi + if [[ $OS == linux && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.linux-ppc.image + fi } find_build_info() { - find_os - find_architecture - find_word_size - set_factor_binary - set_build_info - echo_build_info + find_os + find_architecture + find_word_size + set_factor_binary + set_build_info + echo_build_info } git_clone() { - echo "Downloading the git repository from factorcode.org..." - git clone git://factorcode.org/git/factor.git - check_ret git + echo "Downloading the git repository from factorcode.org..." + git clone git://factorcode.org/git/factor.git + check_ret git } git_pull_factorcode() { - echo "Updating the git repository from factorcode.org..." - git pull git://factorcode.org/git/factor.git - check_ret git + echo "Updating the git repository from factorcode.org..." + git pull git://factorcode.org/git/factor.git + check_ret git } cd_factor() { - cd factor - check_ret cd + cd factor + check_ret cd } make_clean() { - make clean - check_ret make + make clean + check_ret make } make_factor() { - make NO_UI=$NO_UI $MAKE_TARGET -j5 - check_ret make + make NO_UI=$NO_UI $MAKE_TARGET -j5 + check_ret make } delete_boot_images() { - echo "Deleting old images..." - rm $BOOT_IMAGE > /dev/null 2>&1 - rm $BOOT_IMAGE.* > /dev/null 2>&1 + echo "Deleting old images..." + rm $BOOT_IMAGE > /dev/null 2>&1 + rm $BOOT_IMAGE.* > /dev/null 2>&1 } get_boot_image() { - wget http://factorcode.org/images/latest/$BOOT_IMAGE - check_ret wget + wget http://factorcode.org/images/latest/$BOOT_IMAGE + check_ret wget } maybe_download_dlls() { - if [[ $OS == windows-nt ]] ; then - wget http://factorcode.org/dlls/freetype6.dll - check_ret wget - wget http://factorcode.org/dlls/zlib1.dll - check_ret wget - chmod 777 *.dll - check_ret chmod - fi + if [[ $OS == windows-nt ]] ; then + wget http://factorcode.org/dlls/freetype6.dll + check_ret wget + wget http://factorcode.org/dlls/zlib1.dll + check_ret wget + chmod 777 *.dll + check_ret chmod + fi +} + +get_config_info() { + check_installed_programs + find_build_info + check_libraries } bootstrap() { - ./$FACTOR_BINARY -i=$BOOT_IMAGE -} - -usage() { - echo "usage: $0 install|install-x11|update|quick-update" + ./$FACTOR_BINARY -i=$BOOT_IMAGE } install() { - check_factor_exists - check_installed_programs - find_build_info - check_libraries - git_clone - cd_factor - make_factor - get_boot_image - maybe_download_dlls - bootstrap + check_factor_exists + get_config_info + git_clone + cd_factor + make_factor + get_boot_image + maybe_download_dlls + bootstrap } update() { - check_installed_programs - find_build_info - check_libraries - git_pull_factorcode - make_clean - make_factor + get_config_info + git_pull_factorcode + make_clean + make_factor } update_bootstrap() { - delete_boot_images - get_boot_image - bootstrap + delete_boot_images + get_boot_image + bootstrap } refresh_image() { - ./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit" + check_ret factor } make_boot_image() { - ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" + check_ret factor } install_libraries() { - sudo apt-get install libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap + yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make + check_ret sudo +} + +usage() { + echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap" } case "$1" in - install) install ;; - install-x11) install_libraries; install ;; - self-update) update; make_boot_image; bootstrap;; - quick-update) update; refresh_image ;; - update) update; update_bootstrap ;; - *) usage ;; + install) install ;; + install-x11) install_libraries; install ;; + self-update) update; make_boot_image; bootstrap;; + quick-update) update; refresh_image ;; + update) update; update_bootstrap ;; + bootstrap) get_config_info; bootstrap ;; + *) usage ;; esac diff --git a/unmaintained/cabal/authors.txt b/unmaintained/cabal/authors.txt new file mode 100644 index 0000000000..6cfd5da273 --- /dev/null +++ b/unmaintained/cabal/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/cabal/cabal.factor b/unmaintained/cabal/cabal.factor old mode 100644 new mode 100755 similarity index 96% rename from extra/cabal/cabal.factor rename to unmaintained/cabal/cabal.factor index cc51bcf308..0ad8465498 --- a/extra/cabal/cabal.factor +++ b/unmaintained/cabal/cabal.factor @@ -41,7 +41,7 @@ VARS: input user ; : ((send-input)) ( other -- ) [ input> print flush ] with-stream* ; : (send-input) ( other -- ) -[ ((send-input)) ] catch [ print dup stream-close users> delete ] when ; +[ ((send-input)) ] catch [ print dup dispose users> delete ] when ; : send-input ( other -- ) dup duplex-stream-closed? [ users> delete ] [ (send-input) ] if ; diff --git a/extra/cabal/summary.txt b/unmaintained/cabal/summary.txt similarity index 100% rename from extra/cabal/summary.txt rename to unmaintained/cabal/summary.txt diff --git a/extra/cabal/ui/authors.txt b/unmaintained/cabal/ui/authors.txt similarity index 100% rename from extra/cabal/ui/authors.txt rename to unmaintained/cabal/ui/authors.txt diff --git a/extra/cabal/ui/summary.txt b/unmaintained/cabal/ui/summary.txt similarity index 100% rename from extra/cabal/ui/summary.txt rename to unmaintained/cabal/ui/summary.txt diff --git a/extra/cabal/ui/ui.factor b/unmaintained/cabal/ui/ui.factor similarity index 100% rename from extra/cabal/ui/ui.factor rename to unmaintained/cabal/ui/ui.factor diff --git a/extra/lisp/README b/unmaintained/lisp/README similarity index 100% rename from extra/lisp/README rename to unmaintained/lisp/README diff --git a/unmaintained/lisp/authors.txt b/unmaintained/lisp/authors.txt new file mode 100644 index 0000000000..6cfd5da273 --- /dev/null +++ b/unmaintained/lisp/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/lisp/lexer/lexer.factor b/unmaintained/lisp/lexer/lexer.factor similarity index 100% rename from extra/lisp/lexer/lexer.factor rename to unmaintained/lisp/lexer/lexer.factor diff --git a/extra/lisp/lisp.factor b/unmaintained/lisp/lisp.factor similarity index 100% rename from extra/lisp/lisp.factor rename to unmaintained/lisp/lisp.factor diff --git a/extra/lisp/listener/listener.factor b/unmaintained/lisp/listener/listener.factor similarity index 100% rename from extra/lisp/listener/listener.factor rename to unmaintained/lisp/listener/listener.factor diff --git a/extra/lisp/listener/mod/mod.factor b/unmaintained/lisp/listener/mod/mod.factor similarity index 100% rename from extra/lisp/listener/mod/mod.factor rename to unmaintained/lisp/listener/mod/mod.factor diff --git a/extra/lisp/parser/mod/mod.factor b/unmaintained/lisp/parser/mod/mod.factor similarity index 100% rename from extra/lisp/parser/mod/mod.factor rename to unmaintained/lisp/parser/mod/mod.factor diff --git a/extra/lisp/summary.txt b/unmaintained/lisp/summary.txt similarity index 100% rename from extra/lisp/summary.txt rename to unmaintained/lisp/summary.txt diff --git a/extra/lisp/syntax/syntax.factor b/unmaintained/lisp/syntax/syntax.factor similarity index 100% rename from extra/lisp/syntax/syntax.factor rename to unmaintained/lisp/syntax/syntax.factor diff --git a/extra/lisp/tags.txt b/unmaintained/lisp/tags.txt similarity index 100% rename from extra/lisp/tags.txt rename to unmaintained/lisp/tags.txt diff --git a/vm/Config.netbsd b/vm/Config.netbsd new file mode 100644 index 0000000000..5fb5966b1e --- /dev/null +++ b/vm/Config.netbsd @@ -0,0 +1,5 @@ +include vm/Config.unix +PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o +CFLAGS += -export-dynamic +LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib +LIBS = -lm $(X11_UI_LIBS) diff --git a/vm/Config.netbsd.x86.32 b/vm/Config.netbsd.x86.32 new file mode 100644 index 0000000000..849bd65732 --- /dev/null +++ b/vm/Config.netbsd.x86.32 @@ -0,0 +1,2 @@ +include vm/Config.netbsd +include vm/Config.x86.32 diff --git a/vm/Config.netbsd.x86.64 b/vm/Config.netbsd.x86.64 new file mode 100644 index 0000000000..24f86d0118 --- /dev/null +++ b/vm/Config.netbsd.x86.64 @@ -0,0 +1,2 @@ +include vm/Config.netbsd +include vm/Config.x86.64 diff --git a/vm/alien.c b/vm/alien.c old mode 100644 new mode 100755 diff --git a/vm/alien.h b/vm/alien.h old mode 100644 new mode 100755 index a3ca0753a4..3357b0a3c0 --- a/vm/alien.h +++ b/vm/alien.h @@ -41,11 +41,7 @@ DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size); DLLEXPORT void box_value_struct(void *src, CELL size); DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size); -INLINE F_DLL *untag_dll(CELL tagged) -{ - type_check(DLL_TYPE,tagged); - return (F_DLL*)UNTAG(tagged); -} +DEFINE_UNTAG(F_DLL,DLL_TYPE,dll) DECLARE_PRIMITIVE(dlopen); DECLARE_PRIMITIVE(dlsym); diff --git a/vm/code_heap.c b/vm/code_heap.c index 5771725f9d..f449445eb9 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -176,7 +176,7 @@ void deposit_integers(CELL here, F_ARRAY *array, CELL format) { F_FIXNUM value = to_fixnum(array_nth(array,i)); if(format == 1) - cput(here + i,value); + bput(here + i,value); else if(format == sizeof(unsigned int)) *(unsigned int *)(here + format * i) = value; else if(format == CELLS) diff --git a/vm/data_gc.c b/vm/data_gc.c index 4826c1d1ea..601a677920 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -177,12 +177,6 @@ CELL unaligned_object_size(CELL pointer) return sizeof(F_QUOTATION); case WORD_TYPE: return sizeof(F_WORD); - case HASHTABLE_TYPE: - return sizeof(F_HASHTABLE); - case VECTOR_TYPE: - return sizeof(F_VECTOR); - case SBUF_TYPE: - return sizeof(F_SBUF); case RATIO_TYPE: return sizeof(F_RATIO); case FLOAT_TYPE: @@ -511,7 +505,6 @@ CELL binary_payload_start(CELL pointer) switch(untag_header(get(pointer))) { /* these objects do not refer to other objects at all */ - case STRING_TYPE: case FLOAT_TYPE: case BYTE_ARRAY_TYPE: case BIT_ARRAY_TYPE: @@ -528,6 +521,8 @@ CELL binary_payload_start(CELL pointer) return CELLS * 2; case QUOTATION_TYPE: return sizeof(F_QUOTATION) - CELLS * 2; + case STRING_TYPE: + return sizeof(F_STRING); /* everything else consists entirely of pointers */ default: return unaligned_object_size(pointer); diff --git a/vm/debug.c b/vm/debug.c index 2692bdf59c..5b4320b5e9 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -4,7 +4,7 @@ void print_chars(F_STRING* str) { CELL i; for(i = 0; i < string_capacity(str); i++) - putchar(cget(SREF(str,i))); + putchar(string_nth(str,i)); } void print_word(F_WORD* word, CELL nesting) diff --git a/vm/errors.h b/vm/errors.h index 5fe5b08e0d..747a3415ba 100755 --- a/vm/errors.h +++ b/vm/errors.h @@ -39,6 +39,13 @@ INLINE void type_check(CELL type, CELL tagged) if(type_of(tagged) != type) type_error(type,tagged); } +#define DEFINE_UNTAG(type,check,name) \ + INLINE type *untag_##name(CELL obj) \ + { \ + type_check(check,obj); \ + return untag_object(obj); \ + } + /* Global variables used to pass fault handler state from signal handler to user-space */ CELL signal_number; diff --git a/vm/io.c b/vm/io.c index bc7d057abf..d3a29abe72 100755 --- a/vm/io.c +++ b/vm/io.c @@ -13,8 +13,9 @@ normal operation. */ void init_c_io(void) { - userenv[IN_ENV] = allot_alien(F,(CELL)stdin); - userenv[OUT_ENV] = allot_alien(F,(CELL)stdout); + userenv[STDIN_ENV] = allot_alien(F,(CELL)stdin); + userenv[STDOUT_ENV] = allot_alien(F,(CELL)stdout); + userenv[STDERR_ENV] = allot_alien(F,(CELL)stderr); } void io_error(void) diff --git a/vm/layouts.h b/vm/layouts.h index 302a4497b4..ef6fb3d4ac 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -19,9 +19,6 @@ typedef signed long long s64; #define CELLS ((signed)sizeof(CELL)) -/* must always be 16 bits */ -#define CHARS ((signed)sizeof(u16)) - #define WORD_SIZE (CELLS*8) #define HALF_WORD_SIZE (CELLS*4) #define HALF_WORD_MASK (((unsigned long)1< + +#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap)) +#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap) + +#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) +#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) + +extern char **environ; diff --git a/vm/platform.h b/vm/platform.h index 40324cc330..b0641176bc 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -58,6 +58,9 @@ #else #error "Unsupported OpenBSD flavor" #endif + #elif defined(__NetBSD__) + #define FACTOR_OS_STRING "netbsd" + #include "os-netbsd.h" #elif defined(linux) #define FACTOR_OS_STRING "linux" #include "os-linux.h" diff --git a/vm/primitives.c b/vm/primitives.c index dd96ee1495..f2f8ccf18d 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -4,7 +4,6 @@ void *primitives[] = { primitive_execute, primitive_call, primitive_uncurry, - primitive_string_to_sbuf, primitive_bignum_to_fixnum, primitive_float_to_fixnum, primitive_fixnum_to_bignum, @@ -150,16 +149,13 @@ void *primitives[] = { primitive_alien_to_u16_string, primitive_string_to_u16_alien, primitive_throw, - primitive_char_string_to_memory, - primitive_memory_to_char_string, primitive_alien_address, primitive_slot, primitive_set_slot, - primitive_char_slot, - primitive_set_char_slot, + primitive_string_nth, + primitive_set_string_nth, primitive_resize_array, primitive_resize_string, - primitive_hashtable, primitive_array, primitive_begin_scan, primitive_next_object, @@ -174,7 +170,6 @@ void *primitives[] = { primitive_fclose, primitive_wrapper, primitive_clone, - primitive_array_to_vector, primitive_string, primitive_to_tuple, primitive_array_to_quotation, @@ -194,4 +189,7 @@ void *primitives[] = { primitive_set_innermost_stack_frame_quot, primitive_call_clear, primitive_os_envs, + primitive_resize_byte_array, + primitive_resize_bit_array, + primitive_resize_float_array, }; diff --git a/vm/run.h b/vm/run.h index 6f2caa0c14..86cf1c0e1f 100755 --- a/vm/run.h +++ b/vm/run.h @@ -16,8 +16,8 @@ typedef enum { OS_ENV, /* operating system name */ ARGS_ENV = 10, /* command line arguments */ - IN_ENV, /* stdin FILE* handle */ - OUT_ENV, /* stdout FILE* handle */ + STDIN_ENV, /* stdin FILE* handle */ + STDOUT_ENV, /* stdout FILE* handle */ IMAGE_ENV = 13, /* image path name */ EXECUTABLE_ENV, /* runtime executable path name */ @@ -51,6 +51,9 @@ typedef enum { STACK_TRACES_ENV = 36, UNDEFINED_ENV = 37, /* default quotation for undefined words */ + + STDERR_ENV = 38, /* stderr FILE* handle */ + STAGE2_ENV = 39 /* have we bootstrapped? */ } F_ENVTYPE; @@ -71,14 +74,24 @@ INLINE void put(CELL where, CELL what) *((CELL*)where) = what; } -INLINE u16 cget(CELL where) +INLINE CELL cget(CELL where) { - return *((u16*)where); + return *((u16 *)where); } -INLINE void cput(CELL where, u16 what) +INLINE void cput(CELL where, CELL what) { - *((u16*)where) = what; + *((u16 *)where) = what; +} + +INLINE CELL bget(CELL where) +{ + return *((u8 *)where); +} + +INLINE void bput(CELL where, CELL what) +{ + *((u8 *)where) = what; } INLINE CELL align(CELL a, CELL b) diff --git a/vm/types.c b/vm/types.c index d70c1623f4..24b5e7ff07 100755 --- a/vm/types.c +++ b/vm/types.c @@ -12,6 +12,80 @@ bool to_boolean(CELL value) return value != F; } +CELL clone(CELL object) +{ + CELL size = object_size(object); + if(size == 0) + return object; + else + { + REGISTER_ROOT(object); + void *new_obj = allot_object(type_of(object),size); + UNREGISTER_ROOT(object); + + CELL tag = TAG(object); + memcpy(new_obj,(void*)UNTAG(object),size); + return RETAG(new_obj,tag); + } +} + +DEFINE_PRIMITIVE(clone) +{ + drepl(clone(dpeek())); +} + +F_WORD *allot_word(CELL vocab, CELL name) +{ + REGISTER_ROOT(vocab); + REGISTER_ROOT(name); + F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD)); + UNREGISTER_ROOT(name); + UNREGISTER_ROOT(vocab); + + word->hashcode = tag_fixnum(rand()); + word->vocabulary = vocab; + word->name = name; + word->def = userenv[UNDEFINED_ENV]; + word->props = F; + word->counter = tag_fixnum(0); + word->compiledp = F; + word->profiling = NULL; + + REGISTER_UNTAGGED(word); + default_word_code(word,true); + UNREGISTER_UNTAGGED(word); + + REGISTER_UNTAGGED(word); + update_word_xt(word); + UNREGISTER_UNTAGGED(word); + + return word; +} + +/* ( name vocabulary -- word ) */ +DEFINE_PRIMITIVE(word) +{ + CELL vocab = dpop(); + CELL name = dpop(); + dpush(tag_object(allot_word(vocab,name))); +} + +/* word-xt ( word -- xt ) */ +DEFINE_PRIMITIVE(word_xt) +{ + F_WORD *word = untag_word(dpeek()); + drepl(allot_cell((CELL)word->xt)); +} + +DEFINE_PRIMITIVE(wrapper) +{ + F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER)); + wrapper->object = dpeek(); + drepl(tag_object(wrapper)); +} + +/* Arrays */ + /* the array is full of undefined data, and must be correctly filled before the next GC. size is in cells */ F_ARRAY *allot_array_internal(CELL type, CELL capacity) @@ -38,41 +112,6 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill) return array; } -/* size is in bytes this time */ -F_BYTE_ARRAY *allot_byte_array(CELL size) -{ - F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE, - byte_array_size(size)); - array->capacity = tag_fixnum(size); - memset(array + 1,0,size); - return array; -} - -/* size is in bits */ -F_BIT_ARRAY *allot_bit_array(CELL size) -{ - F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE, - bit_array_size(size)); - array->capacity = tag_fixnum(size); - memset(array + 1,0,(size + 31) / 32 * 4); - return array; -} - -/* size is in 8-byte doubles */ -F_BIT_ARRAY *allot_float_array(CELL size, double initial) -{ - F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE, - float_array_size(size)); - array->capacity = tag_fixnum(size); - - double *elements = (double *)AREF(array,0); - int i; - for(i = 0; i < size; i++) - elements[i] = initial; - - return array; -} - /* push a new array on the stack */ DEFINE_PRIMITIVE(array) { @@ -81,89 +120,6 @@ DEFINE_PRIMITIVE(array) dpush(tag_object(allot_array(ARRAY_TYPE,size,initial))); } -/* push a new tuple on the stack */ -DEFINE_PRIMITIVE(tuple) -{ - CELL size = unbox_array_size(); - F_ARRAY *array = allot_array(TUPLE_TYPE,size,F); - set_array_nth(array,0,dpop()); - dpush(tag_tuple(array)); -} - -/* push a new tuple on the stack, filling its slots from the stack */ -DEFINE_PRIMITIVE(tuple_boa) -{ - CELL size = unbox_array_size(); - F_ARRAY *array = allot_array(TUPLE_TYPE,size,F); - set_array_nth(array,0,dpop()); - - CELL i; - for(i = size - 1; i >= 2; i--) - set_array_nth(array,i,dpop()); - - dpush(tag_tuple(array)); -} - -/* push a new byte array on the stack */ -DEFINE_PRIMITIVE(byte_array) -{ - CELL size = unbox_array_size(); - dpush(tag_object(allot_byte_array(size))); -} - -/* push a new bit array on the stack */ -DEFINE_PRIMITIVE(bit_array) -{ - CELL size = unbox_array_size(); - dpush(tag_object(allot_bit_array(size))); -} - -/* push a new float array on the stack */ -DEFINE_PRIMITIVE(float_array) -{ - double initial = untag_float(dpop()); - CELL size = unbox_array_size(); - dpush(tag_object(allot_float_array(size,initial))); -} - -CELL clone(CELL object) -{ - CELL size = object_size(object); - if(size == 0) - return object; - else - { - REGISTER_ROOT(object); - void *new_obj = allot_object(type_of(object),size); - UNREGISTER_ROOT(object); - - CELL tag = TAG(object); - memcpy(new_obj,(void*)UNTAG(object),size); - return RETAG(new_obj,tag); - } -} - -DEFINE_PRIMITIVE(clone) -{ - drepl(clone(dpeek())); -} - -DEFINE_PRIMITIVE(tuple_to_array) -{ - CELL object = dpeek(); - type_check(TUPLE_TYPE,object); - object = RETAG(clone(object),OBJECT_TYPE); - set_slot(object,0,tag_header(ARRAY_TYPE)); - drepl(object); -} - -DEFINE_PRIMITIVE(to_tuple) -{ - CELL object = RETAG(clone(dpeek()),TUPLE_TYPE); - set_slot(object,0,tag_header(TUPLE_TYPE)); - drepl(object); -} - CELL allot_array_1(CELL obj) { REGISTER_ROOT(obj); @@ -235,14 +191,6 @@ DEFINE_PRIMITIVE(resize_array) dpush(tag_object(reallot_array(array,capacity,F))); } -DEFINE_PRIMITIVE(array_to_vector) -{ - F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR)); - vector->top = dpop(); - vector->array = dpop(); - dpush(tag_object(vector)); -} - F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count) { REGISTER_ROOT(elt); @@ -279,33 +227,279 @@ F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count) return result; } +/* Byte arrays */ + +/* must fill out array before next GC */ +F_BYTE_ARRAY *allot_byte_array_internal(CELL size) +{ + F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE, + byte_array_size(size)); + array->capacity = tag_fixnum(size); + return array; +} + +/* size is in bytes this time */ +F_BYTE_ARRAY *allot_byte_array(CELL size) +{ + F_BYTE_ARRAY *array = allot_byte_array_internal(size); + memset(array + 1,0,size); + return array; +} + +/* push a new byte array on the stack */ +DEFINE_PRIMITIVE(byte_array) +{ + CELL size = unbox_array_size(); + dpush(tag_object(allot_byte_array(size))); +} + +F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) +{ + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + F_BYTE_ARRAY *new_array = allot_byte_array(capacity); + UNREGISTER_UNTAGGED(array); + + memcpy(new_array + 1,array + 1,to_copy); + + return new_array; +} + +DEFINE_PRIMITIVE(resize_byte_array) +{ + F_BYTE_ARRAY* array = untag_byte_array(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_byte_array(array,capacity))); +} + +/* Bit arrays */ + +/* size is in bits */ + +F_BIT_ARRAY *allot_bit_array_internal(CELL size) +{ + F_BIT_ARRAY *array = allot_object(BIT_ARRAY_TYPE,bit_array_size(size)); + array->capacity = tag_fixnum(size); + return array; +} + +F_BIT_ARRAY *allot_bit_array(CELL size) +{ + F_BIT_ARRAY *array = allot_bit_array_internal(size); + memset(array + 1,0,bit_array_size(size)); + return array; +} + +/* push a new bit array on the stack */ +DEFINE_PRIMITIVE(bit_array) +{ + CELL size = unbox_array_size(); + dpush(tag_object(allot_bit_array(size))); +} + +F_BIT_ARRAY *reallot_bit_array(F_BIT_ARRAY *array, CELL capacity) +{ + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + F_BIT_ARRAY *new_array = allot_bit_array(capacity); + UNREGISTER_UNTAGGED(array); + + memcpy(new_array + 1,array + 1,bit_array_size(to_copy)); + + return new_array; +} + +DEFINE_PRIMITIVE(resize_bit_array) +{ + F_BYTE_ARRAY* array = untag_bit_array(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_bit_array(array,capacity))); +} + +/* Float arrays */ + +/* size is in 8-byte doubles */ +F_FLOAT_ARRAY *allot_float_array_internal(CELL size) +{ + F_FLOAT_ARRAY *array = allot_object(FLOAT_ARRAY_TYPE, + float_array_size(size)); + array->capacity = tag_fixnum(size); + return array; +} + +F_FLOAT_ARRAY *allot_float_array(CELL size, double initial) +{ + F_FLOAT_ARRAY *array = allot_float_array_internal(size); + + double *elements = (double *)AREF(array,0); + int i; + for(i = 0; i < size; i++) + elements[i] = initial; + + return array; +} + +/* push a new float array on the stack */ +DEFINE_PRIMITIVE(float_array) +{ + double initial = untag_float(dpop()); + CELL size = unbox_array_size(); + dpush(tag_object(allot_float_array(size,initial))); +} + +F_ARRAY *reallot_float_array(F_FLOAT_ARRAY* array, CELL capacity) +{ + F_FLOAT_ARRAY* new_array; + + CELL to_copy = array_capacity(array); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(array); + new_array = allot_float_array(capacity,0.0); + UNREGISTER_UNTAGGED(array); + + memcpy(new_array + 1,array + 1,to_copy * sizeof(double)); + + return new_array; +} + +DEFINE_PRIMITIVE(resize_float_array) +{ + F_FLOAT_ARRAY* array = untag_float_array(dpop()); + CELL capacity = unbox_array_size(); + dpush(tag_object(reallot_float_array(array,capacity))); +} + +/* Tuples */ + +/* push a new tuple on the stack */ +DEFINE_PRIMITIVE(tuple) +{ + CELL size = unbox_array_size(); + F_ARRAY *array = allot_array(TUPLE_TYPE,size,F); + set_array_nth(array,0,dpop()); + dpush(tag_tuple(array)); +} + +/* push a new tuple on the stack, filling its slots from the stack */ +DEFINE_PRIMITIVE(tuple_boa) +{ + CELL size = unbox_array_size(); + F_ARRAY *array = allot_array(TUPLE_TYPE,size,F); + set_array_nth(array,0,dpop()); + + CELL i; + for(i = size - 1; i >= 2; i--) + set_array_nth(array,i,dpop()); + + dpush(tag_tuple(array)); +} + +DEFINE_PRIMITIVE(tuple_to_array) +{ + CELL object = dpeek(); + type_check(TUPLE_TYPE,object); + object = RETAG(clone(object),OBJECT_TYPE); + set_slot(object,0,tag_header(ARRAY_TYPE)); + drepl(object); +} + +DEFINE_PRIMITIVE(to_tuple) +{ + CELL object = RETAG(clone(dpeek()),TUPLE_TYPE); + set_slot(object,0,tag_header(TUPLE_TYPE)); + drepl(object); +} + +/* Strings */ +CELL string_nth(F_STRING* string, CELL index) +{ + CELL ch = bget(SREF(string,index)); + if(string->aux == F) + return ch; + else + { + F_BYTE_ARRAY *aux = untag_object(string->aux); + return (cget(BREF(aux,index * sizeof(u16))) << 8) | ch; + } +} + +/* allocates memory */ +void set_string_nth(F_STRING* string, CELL index, CELL value) +{ + bput(SREF(string,index),value & 0xff); + + F_BYTE_ARRAY *aux; + + if(string->aux == F) + { + if(value <= 0xff) + return; + else + { + REGISTER_UNTAGGED(string); + aux = allot_byte_array( + untag_fixnum_fast(string->length) + * sizeof(u16)); + UNREGISTER_UNTAGGED(string); + string->aux = tag_object(aux); + } + } + else + aux = untag_object(string->aux); + + cput(BREF(aux,index * sizeof(u16)),value >> 8); +} + /* untagged */ F_STRING* allot_string_internal(CELL capacity) { - F_STRING* string = allot_object(STRING_TYPE, - sizeof(F_STRING) + (capacity + 1) * CHARS); + F_STRING *string = allot_object(STRING_TYPE,string_size(capacity)); /* strings are null-terminated in memory, even though they also have a length field. The null termination allows us to add the sizeof(F_STRING) to a Factor string to get a C-style - UCS-2 string for C library calls. */ - cput(SREF(string,capacity),(u16)'\0'); + char* string for C library calls. */ string->length = tag_fixnum(capacity); string->hashcode = F; + string->aux = F; + + set_string_nth(string,capacity,0); + return string; } +/* allocates memory */ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) { if(fill == 0) - memset((void*)SREF(string,start),'\0', - (capacity - start) * CHARS); + { + memset((void *)SREF(string,start),'\0',capacity - start); + + if(string->aux != F) + { + F_BYTE_ARRAY *aux = untag_object(string->aux); + memset((void *)BREF(aux,start * sizeof(u16)),'\0', + (capacity - start) * sizeof(u16)); + } + } else { CELL i; for(i = start; i < capacity; i++) - cput(SREF(string,i),fill); + { + REGISTER_UNTAGGED(string); + set_string_nth(string,i,fill); + UNREGISTER_UNTAGGED(string); + } } } @@ -313,7 +507,9 @@ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) F_STRING *allot_string(CELL capacity, CELL fill) { F_STRING* string = allot_string_internal(capacity); + REGISTER_UNTAGGED(string); fill_string(string,0,capacity,fill); + UNREGISTER_UNTAGGED(string); return string; } @@ -324,7 +520,7 @@ DEFINE_PRIMITIVE(string) dpush(tag_object(allot_string(length,initial))); } -F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill) +F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) { CELL to_copy = string_capacity(string); if(capacity < to_copy) @@ -334,8 +530,24 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill) F_STRING *new_string = allot_string_internal(capacity); UNREGISTER_UNTAGGED(string); - memcpy(new_string + 1,string + 1,to_copy * CHARS); + memcpy(new_string + 1,string + 1,to_copy); + + if(string->aux != F) + { + REGISTER_UNTAGGED(string); + REGISTER_UNTAGGED(new_string); + F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); + new_string->aux = tag_object(new_aux); + UNREGISTER_UNTAGGED(new_string); + UNREGISTER_UNTAGGED(string); + + F_BYTE_ARRAY *aux = untag_object(string->aux); + memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); + } + + REGISTER_UNTAGGED(string); fill_string(new_string,to_copy,capacity,fill); + UNREGISTER_UNTAGGED(string); return new_string; } @@ -358,17 +570,13 @@ DEFINE_PRIMITIVE(resize_string) CELL i; \ for(i = 0; i < length; i++) \ { \ - cput(SREF(s,i),(utype)*string); \ + REGISTER_UNTAGGED(s); \ + set_string_nth(s,i,(utype)*string); \ + UNREGISTER_UNTAGGED(s); \ string++; \ } \ return s; \ } \ - DEFINE_PRIMITIVE(memory_to_##type##_string) \ - { \ - CELL length = to_cell(dpop()); \ - const type *string = unbox_alien(); \ - dpush(tag_object(memory_to_##type##_string(string,length))); \ - } \ F_STRING *from_##type##_string(const type *str) \ { \ CELL length = 0; \ @@ -387,6 +595,7 @@ DEFINE_PRIMITIVE(resize_string) MEMORY_TO_STRING(char,u8) MEMORY_TO_STRING(u16,u16) +MEMORY_TO_STRING(u32,u32) bool check_string(F_STRING *s, CELL max) { @@ -394,7 +603,7 @@ bool check_string(F_STRING *s, CELL max) CELL i; for(i = 0; i < capacity; i++) { - u16 ch = string_nth(s,i); + CELL ch = string_nth(s,i); if(ch == '\0' || ch >= (1 << (max * 8))) return false; } @@ -436,7 +645,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) } \ type *to_##type##_string(F_STRING *s, bool check) \ { \ - if(sizeof(type) == sizeof(u16)) \ + if(sizeof(type) == sizeof(char)) \ { \ if(check && !check_string(s,sizeof(type))) \ general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ @@ -461,84 +670,17 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) STRING_TO_MEMORY(char); STRING_TO_MEMORY(u16); -DEFINE_PRIMITIVE(char_slot) +DEFINE_PRIMITIVE(string_nth) { - F_STRING* string = untag_object(dpop()); + F_STRING *string = untag_object(dpop()); CELL index = untag_fixnum_fast(dpop()); dpush(tag_fixnum(string_nth(string,index))); } -DEFINE_PRIMITIVE(set_char_slot) +DEFINE_PRIMITIVE(set_string_nth) { - F_STRING* string = untag_object(dpop()); + F_STRING *string = untag_object(dpop()); CELL index = untag_fixnum_fast(dpop()); CELL value = untag_fixnum_fast(dpop()); set_string_nth(string,index,value); } - -DEFINE_PRIMITIVE(string_to_sbuf) -{ - F_SBUF *sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF)); - sbuf->top = dpop(); - sbuf->string = dpop(); - dpush(tag_object(sbuf)); -} - -DEFINE_PRIMITIVE(hashtable) -{ - F_HASHTABLE* hash = allot_object(HASHTABLE_TYPE,sizeof(F_HASHTABLE)); - hash->count = F; - hash->deleted = F; - hash->array = F; - dpush(tag_object(hash)); -} - -F_WORD *allot_word(CELL vocab, CELL name) -{ - REGISTER_ROOT(vocab); - REGISTER_ROOT(name); - F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD)); - UNREGISTER_ROOT(name); - UNREGISTER_ROOT(vocab); - - word->hashcode = tag_fixnum(rand()); - word->vocabulary = vocab; - word->name = name; - word->def = userenv[UNDEFINED_ENV]; - word->props = F; - word->counter = tag_fixnum(0); - word->compiledp = F; - word->profiling = NULL; - - REGISTER_UNTAGGED(word); - default_word_code(word,true); - UNREGISTER_UNTAGGED(word); - - REGISTER_UNTAGGED(word); - update_word_xt(word); - UNREGISTER_UNTAGGED(word); - - return word; -} - -/* ( name vocabulary -- word ) */ -DEFINE_PRIMITIVE(word) -{ - CELL vocab = dpop(); - CELL name = dpop(); - dpush(tag_object(allot_word(vocab,name))); -} - -/* word-xt ( word -- xt ) */ -DEFINE_PRIMITIVE(word_xt) -{ - F_WORD *word = untag_word(dpeek()); - drepl(allot_cell((CELL)word->xt)); -} - -DEFINE_PRIMITIVE(wrapper) -{ - F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER)); - wrapper->object = dpeek(); - drepl(tag_object(wrapper)); -} diff --git a/vm/types.h b/vm/types.h index c896b69eba..e5003ea069 100755 --- a/vm/types.h +++ b/vm/types.h @@ -11,9 +11,11 @@ INLINE CELL string_capacity(F_STRING* str) INLINE CELL string_size(CELL size) { - return sizeof(F_STRING) + (size + 1) * CHARS; + return sizeof(F_STRING) + size + 1; } +DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) + INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array) { return untag_fixnum_fast(array->capacity); @@ -24,6 +26,8 @@ INLINE CELL byte_array_size(CELL size) return sizeof(F_BYTE_ARRAY) + size; } +DEFINE_UNTAG(F_BIT_ARRAY,BIT_ARRAY_TYPE,bit_array) + INLINE CELL bit_array_capacity(F_BIT_ARRAY *array) { return untag_fixnum_fast(array->capacity); @@ -34,6 +38,8 @@ INLINE CELL bit_array_size(CELL size) return sizeof(F_BIT_ARRAY) + (size + 7) / 8; } +DEFINE_UNTAG(F_FLOAT_ARRAY,FLOAT_ARRAY_TYPE,float_array) + INLINE CELL float_array_capacity(F_FLOAT_ARRAY *array) { return untag_fixnum_fast(array->capacity); @@ -49,22 +55,14 @@ INLINE CELL callstack_size(CELL size) return sizeof(F_CALLSTACK) + size; } -INLINE F_CALLSTACK *untag_callstack(CELL obj) -{ - type_check(CALLSTACK_TYPE,obj); - return untag_object(obj); -} +DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack) INLINE CELL tag_boolean(CELL untagged) { return (untagged == false ? F : T); } -INLINE F_ARRAY* untag_array(CELL tagged) -{ - type_check(ARRAY_TYPE,tagged); - return untag_object(tagged); -} +DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array) #define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS) #define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS) @@ -85,7 +83,8 @@ INLINE CELL array_capacity(F_ARRAY* array) return array->capacity >> TAG_BITS; } -#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index * CHARS) +#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index)) +#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index)) INLINE F_STRING* untag_string(CELL tagged) { @@ -93,27 +92,9 @@ INLINE F_STRING* untag_string(CELL tagged) return untag_object(tagged); } -INLINE CELL string_nth(F_STRING* string, CELL index) -{ - return cget(SREF(string,index)); -} +DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) -INLINE void set_string_nth(F_STRING* string, CELL index, u16 value) -{ - cput(SREF(string,index),value); -} - -INLINE F_QUOTATION *untag_quotation(CELL tagged) -{ - type_check(QUOTATION_TYPE,tagged); - return untag_object(tagged); -} - -INLINE F_WORD *untag_word(CELL tagged) -{ - type_check(WORD_TYPE,tagged); - return untag_object(tagged); -} +DEFINE_UNTAG(F_WORD,WORD_TYPE,word) INLINE CELL tag_tuple(F_ARRAY *tuple) { @@ -144,47 +125,44 @@ DECLARE_PRIMITIVE(to_tuple); F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill); DECLARE_PRIMITIVE(resize_array); - -DECLARE_PRIMITIVE(array_to_vector); +DECLARE_PRIMITIVE(resize_byte_array); +DECLARE_PRIMITIVE(resize_bit_array); +DECLARE_PRIMITIVE(resize_float_array); F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); DECLARE_PRIMITIVE(string); -F_STRING *reallot_string(F_STRING *string, CELL capacity, u16 fill); +F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill); DECLARE_PRIMITIVE(resize_string); F_STRING *memory_to_char_string(const char *string, CELL length); -DECLARE_PRIMITIVE(memory_to_char_string); F_STRING *from_char_string(const char *c_string); DLLEXPORT void box_char_string(const char *c_string); DECLARE_PRIMITIVE(alien_to_char_string); F_STRING *memory_to_u16_string(const u16 *string, CELL length); -DECLARE_PRIMITIVE(memory_to_u16_string); F_STRING *from_u16_string(const u16 *c_string); DLLEXPORT void box_u16_string(const u16 *c_string); DECLARE_PRIMITIVE(alien_to_u16_string); void char_string_to_memory(F_STRING *s, char *string); -DECLARE_PRIMITIVE(char_string_to_memory); F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check); char* to_char_string(F_STRING *s, bool check); DLLEXPORT char *unbox_char_string(void); DECLARE_PRIMITIVE(string_to_char_alien); void u16_string_to_memory(F_STRING *s, u16 *string); -DECLARE_PRIMITIVE(u16_string_to_memory); F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check); u16* to_u16_string(F_STRING *s, bool check); DLLEXPORT u16 *unbox_u16_string(void); DECLARE_PRIMITIVE(string_to_u16_alien); -DECLARE_PRIMITIVE(char_slot); -DECLARE_PRIMITIVE(set_char_slot); +/* String getters and setters */ +CELL string_nth(F_STRING* string, CELL index); +void set_string_nth(F_STRING* string, CELL index, CELL value); -DECLARE_PRIMITIVE(string_to_sbuf); - -DECLARE_PRIMITIVE(hashtable); +DECLARE_PRIMITIVE(string_nth); +DECLARE_PRIMITIVE(set_string_nth); F_WORD *allot_word(CELL vocab, CELL name); DECLARE_PRIMITIVE(word);