diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 089091bec5..8fee0e8c3e 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -1,5 +1,5 @@ USING: byte-arrays arrays help.syntax help.markup -alien.syntax alien.c-types compiler definitions math libc +alien.syntax compiler definitions math libc debugger parser io io.backend system bit-arrays float-arrays ; IN: alien @@ -156,36 +156,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 +223,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/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.factor b/core/alien/c-types/c-types.factor index 6d9c2cec14..1ecfa37ee6 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -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 ; 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 75255d905d..6565ea0e2c 100755 --- a/core/alien/syntax/syntax-docs.factor +++ b/core/alien/syntax/syntax-docs.factor @@ -1,6 +1,6 @@ -USING: alien alien.c-types alien.structs help.markup help.syntax ; IN: alien.syntax -USE: alien.syntax.private +USING: alien alien.c-types alien.structs alien.syntax.private +help.markup help.syntax ; HELP: DLL" { $syntax "DLL\" path\"" } @@ -88,8 +88,6 @@ 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: POSTPONE: TYPEDEF-IF: } related-words -{ POSTPONE: TYPEDEF: typedef POSTPONE: TYPEDEF-IF: } related-words { POSTPONE: TYPEDEF-IF: POSTPONE: TYPEDEF: typedef } related-words HELP: c-struct? 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/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 7b199a5e46..43a8d9752a 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -427,32 +427,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 +450,7 @@ PRIVATE> : make-images ( -- ) { "x86.32" - ! "x86.64" + "x86.64" "linux-ppc" "macosx-ppc" ! "arm" } [ make-image ] each ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 3e93a868ca..a88729f539 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -5,22 +5,32 @@ 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 + +! Now we have ( syntax-quot arch-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 ! Create some empty vocabs where the below primitives and @@ -558,8 +568,6 @@ builtins get num-tags get tail f union-class define-class { "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" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index f9c738a8d0..0163422f47 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -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 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/core/compiler/constants/authors.txt b/core/compiler/constants/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/compiler/constants/authors.txt @@ -0,0 +1 @@ +Slava Pestov 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/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..266b331ffc 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,36 @@ 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 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/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/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/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/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/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/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/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/dlists/dlists.factor b/core/dlists/dlists.factor index a3c869efaf..84d68b28aa 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -78,7 +78,8 @@ PRIVATE> : 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 @@ -87,13 +88,13 @@ PRIVATE> : pop-front* ( dlist -- ) pop-front drop ; : 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 ; 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/generator/generator.factor b/core/generator/generator.factor index df01f9e490..0e499cf90f 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -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/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor old mode 100644 new mode 100755 index 3719c2f9e0..7b6c2d1dc9 --- 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" @@ -133,6 +135,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..e477aa59ed --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -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/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/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 2223dd56b6..72935f1405 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -475,10 +475,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 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/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/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/io-docs.factor b/core/io/io-docs.factor old mode 100644 new mode 100755 index 5c71714c64..cf867d7945 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -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 } @@ -178,10 +177,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..edd0fa938f 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -35,7 +35,8 @@ GENERIC: stream-write-table ( table-cells style stream -- ) ! 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 +54,9 @@ SYMBOL: stdio stdio swap with-variable ; inline : with-stream ( stream quot -- ) - swap [ [ close ] [ ] cleanup ] with-stream* ; inline + swap [ + [ stdio get stream-close ] [ ] cleanup + ] with-stream* ; 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..d816e08443 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -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/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/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/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/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/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.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 -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/alarms/authors.txt b/extra/alarms/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/alarms/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/arrays/lib/authors.txt b/extra/arrays/lib/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/arrays/lib/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos 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 5a277e2d8d..00f330f0fc --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -9,7 +9,7 @@ IN: assocs.lib : ref-at ( table key -- value ) swap at ; -! set-hash with alternative stack effects +! set-at with alternative stack effects : put-at* ( table key value -- ) swap rot set-at ; @@ -22,3 +22,6 @@ IN: assocs.lib : at-default ( key assoc -- value/key ) dupd at [ nip ] when* ; + +: at-peek ( key assoc -- value ? ) + at* dup >r [ peek ] when r> ; diff --git a/extra/automata/ui/authors.txt b/extra/automata/ui/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/automata/ui/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index 5cf9ccc71f..ab424cdab6 100644 --- a/extra/automata/ui/ui.factor +++ b/extra/automata/ui/ui.factor @@ -14,7 +14,7 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads ui.gadgets.packs ui.gadgets.grids ui.gadgets.theme - namespaces.lib hashtables.lib vars + namespaces.lib assocs.lib vars rewrite-closures automata ; IN: automata.ui @@ -85,4 +85,4 @@ over @center grid-add : automata-window ( -- ) [ [ automata-window* ] with-scope ] with-ui ; -MAIN: automata-window \ No newline at end of file +MAIN: automata-window 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/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/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/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 index 235ccc3914..6d04a4d623 100644 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -20,7 +20,7 @@ USING: kernel namespaces ui.gadgets.grids ui.gestures combinators.cleave - hashtables.lib vars rewrite-closures boids ; + assocs.lib vars rewrite-closures boids ; IN: boids.ui @@ -163,4 +163,4 @@ VARS: population-label cohesion-label alignment-label separation-label ; : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ; -MAIN: boids-window \ No newline at end of file +MAIN: boids-window 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/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/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 c9b62ce7aa..8c1c2fb3a6 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -4,7 +4,8 @@ USING: arrays hashtables io io.streams.string kernel math math.vectors math.functions math.parser namespaces sequences strings tuples system debugger combinators vocabs.loader -calendar.backend structs alien.c-types math.vectors ; +calendar.backend structs alien.c-types math.vectors +math.ranges shuffle ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; @@ -115,14 +116,18 @@ GENERIC: +second ( timestamp x -- timestamp ) : /rem ( f n -- q r ) #! q is positive or negative, r is positive from 0 <= r < n - [ /f floor >bignum ] 2keep rem ; + [ /f floor >integer ] 2keep rem ; : float>whole-part ( float -- int float ) - [ floor >bignum ] keep over - ; + [ floor >integer ] keep over - ; -: leap-year? ( year -- ? ) +GENERIC: leap-year? ( obj -- ? ) +M: integer leap-year? ( year -- ? ) dup 100 mod zero? 400 4 ? mod zero? ; +M: timestamp leap-year? ( timestamp -- ? ) + timestamp-year leap-year? ; + : adjust-leap-year ( timestamp -- timestamp ) dup >date< 29 = swap 2 = and swap leap-year? not and [ dup >r timestamp-year 3 1 r> [ set-date ] keep @@ -161,7 +166,7 @@ M: real +minute ( timestamp n -- timestamp ) float>whole-part rot swap 60 * +second swap +minute ; M: number +second ( timestamp n -- timestamp ) - over timestamp-second + 60 /rem >r >bignum r> + over timestamp-second + 60 /rem >r >integer r> pick set-timestamp-second +minute ; : +dt ( timestamp dt -- timestamp ) @@ -178,6 +183,9 @@ M: number +second ( timestamp n -- timestamp ) [ 0 seconds +dt ] keep [ = [ "invalid timestamp" throw ] unless ] keep ; +: make-date ( year month day -- timestamp ) + 0 0 0 gmt-offset make-timestamp ; + : array>dt ( vec -- dt ) { dt f } swap append >tuple ; : +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ; @@ -214,14 +222,14 @@ M: timestamp <=> ( ts1 ts2 -- n ) [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; -: unix-1970 +: unix-1970 ( -- timestamp ) 1970 1 1 0 0 0 0 ; : unix-time>timestamp ( n -- timestamp ) >r unix-1970 r> seconds +dt ; : timestamp>unix-time ( timestamp -- n ) - unix-1970 timestamp- >bignum ; + unix-1970 timestamp- >integer ; : timestamp>timeval ( timestamp -- timeval ) timestamp>unix-time 1000 * make-timeval ; @@ -240,14 +248,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) : from-now ( dt -- timestamp ) now swap +dt ; : ago ( dt -- timestamp ) before from-now ; -: days-in-year ( year -- n ) leap-year? 366 365 ? ; : day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; -: days-in-month ( year month -- n ) - swap leap-year? [ - [ day-counts nth ] keep 2 = [ 1+ ] when - ] [ - day-counts nth - ] if ; : zeller-congruence ( year month day -- n ) #! Zeller Congruence @@ -258,33 +259,79 @@ M: timestamp <=> ( ts1 ts2 -- n ) [ 1+ 3 * 5 /i + ] keep 2 * + r> 1+ + 7 mod ; -: day-of-week ( timestamp -- n ) +GENERIC: days-in-year ( obj -- n ) + +M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ; +M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ; + +GENERIC: days-in-month ( obj -- n ) + +M: array days-in-month ( obj -- n ) + first2 dup 2 = [ + drop leap-year? 29 28 ? + ] [ + nip day-counts nth + ] if ; + +M: timestamp days-in-month ( timestamp -- n ) + { timestamp-year timestamp-month } get-slots 2array days-in-month ; + +GENERIC: day-of-week ( obj -- n ) + +M: timestamp day-of-week ( timestamp -- n ) >date< zeller-congruence ; -: day-of-year ( timestamp -- n ) - [ - [ timestamp-year leap-year? ] keep - [ >date< 3array ] keep timestamp-year 3 1 3array <=> - 0 >= and 1 0 ? - ] keep - [ timestamp-month day-counts swap head-slice sum + ] keep - timestamp-day + ; +M: array day-of-week ( array -- n ) + first3 zeller-congruence ; -: print-day ( n -- ) +GENERIC: day-of-year ( obj -- n ) + +M: array day-of-year ( array -- n ) + first3 + 3dup day-counts rot head-slice sum + + swap leap-year? [ + -roll + pick 3 1 make-date >r make-date r> + <=> 0 >= [ 1+ ] when + ] [ + 3nip + ] if ; + +M: timestamp day-of-year ( timestamp -- n ) + { timestamp-year timestamp-month timestamp-day } get-slots + 3array day-of-year ; + +GENERIC: day. ( obj -- ) + +M: integer day. ( n -- ) number>string dup length 2 < [ bl ] when write ; -: print-month ( year month -- ) +M: timestamp day. ( timestamp -- ) + timestamp-day day. ; + +GENERIC: month. ( obj -- ) + +M: array month. ( pair -- ) + first2 [ month-names nth write bl number>string print ] 2keep [ 1 zeller-congruence ] 2keep - days-in-month day-abbreviations2 " " join print + 2array days-in-month day-abbreviations2 " " join print over " " concat write [ - [ 1+ print-day ] keep + [ 1+ day. ] keep 1+ + 7 mod zero? [ nl ] [ bl ] if ] with each nl ; -: print-year ( year -- ) - 12 [ 1+ print-month nl ] with each ; +M: timestamp month. ( timestamp -- ) + { timestamp-year timestamp-month } get-slots 2array month. ; + +GENERIC: year. ( obj -- ) + +M: integer year. ( n -- ) + 12 [ 1+ 2array month. nl ] with each ; + +M: timestamp year. ( timestamp -- ) + timestamp-year year. ; : pad-00 number>string 2 CHAR: 0 pad-left write ; @@ -298,9 +345,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) timestamp-second >fixnum pad-00 ; : timestamp>string ( timestamp -- str ) - [ - (timestamp>string) - ] string-out ; + [ (timestamp>string) ] string-out ; : timestamp>http-string ( timestamp -- str ) #! http timestamp format @@ -319,9 +364,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) timestamp-second >fixnum pad-00 CHAR: Z write1 ; : timestamp>rfc3339 ( timestamp -- str ) - >gmt [ - (timestamp>rfc3339) - ] string-out ; + >gmt [ (timestamp>rfc3339) ] string-out ; : expect read1 assert= ; @@ -340,9 +383,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) 0 ; : rfc3339>timestamp ( str -- timestamp ) - [ - (rfc3339>timestamp) - ] string-in ; + [ (rfc3339>timestamp) ] string-in ; : file-time-string ( timestamp -- string ) [ @@ -370,6 +411,23 @@ M: timestamp <=> ( ts1 ts2 -- n ) : friday ( timestamp -- timestamp ) 5 day-this-week ; : saturday ( timestamp -- timestamp ) 6 day-this-week ; +: beginning-of-day ( timestamp -- new-timestamp ) + clone dup >r 0 0 0 r> + { set-timestamp-hour set-timestamp-minute set-timestamp-second } + set-slots ; inline + +: beginning-of-month ( timestamp -- new-timestamp ) + beginning-of-day 1 over set-timestamp-day ; + +: beginning-of-week ( timestamp -- new-timestamp ) + beginning-of-day sunday ; + +: beginning-of-year ( timestamp -- new-timestamp ) + beginning-of-month 1 over set-timestamp-month ; + +: seconds-since-midnight ( timestamp -- x ) + dup beginning-of-day timestamp- ; + { { [ unix? ] [ "calendar.unix" ] } { [ windows? ] [ "calendar.windows" ] } 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/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor index 20b392195a..c89fd0e244 100644 --- a/extra/cel-shading/cel-shading.factor +++ b/extra/cel-shading/cel-shading.factor @@ -1,51 +1,15 @@ -USING: arrays bunny io io.files kernel - math math.functions math.vectors multiline - namespaces - opengl opengl.gl - prettyprint - sequences ui ui.gadgets ui.gestures ui.render ; +USING: arrays bunny combinators.lib io io.files kernel + math math.functions multiline + opengl opengl.gl opengl-demo-support + sequences ui ui.gadgets ui.render ; IN: cel-shading -: 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: cel-shading-gadget yaw pitch distance model program ; +TUPLE: cel-shading-gadget model program ; : ( -- cel-shading-gadget ) - cel-shading-gadget construct-gadget - 0.0 over set-cel-shading-gadget-yaw - 0.0 over set-cel-shading-gadget-pitch - 0.375 over set-cel-shading-gadget-distance - maybe-download read-model over set-cel-shading-gadget-model ; - -: yaw-cel-shading-gadget ( yaw gadget -- ) - [ [ cel-shading-gadget-yaw + ] keep set-cel-shading-gadget-yaw ] keep relayout-1 ; - -: pitch-cel-shading-gadget ( pitch gadget -- ) - [ [ cel-shading-gadget-pitch + ] keep set-cel-shading-gadget-pitch ] keep relayout-1 ; - -: zoom-cel-shading-gadget ( distance gadget -- ) - [ [ cel-shading-gadget-distance + ] keep set-cel-shading-gadget-distance ] keep relayout-1 ; - -M: cel-shading-gadget pref-dim* ( gadget -- dim ) - drop DIMS ; - -: -+ ( x -- -x x ) - dup neg swap ; - -: cel-shading-frustum ( -- -x x -y y near far ) - FOV-RATIO NEAR-PLANE FOV / v*n - first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ; + 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; @@ -90,11 +54,11 @@ main() ; : cel-shading-program ( -- program ) - cel-shading-vertex-shader-source check-gl-shader - cel-shading-fragment-shader-source check-gl-shader - 2array check-gl-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 @@ -104,19 +68,13 @@ M: cel-shading-gadget ungraft* ( gadget -- ) cel-shading-gadget-program delete-gl-program ; : cel-shading-draw-setup ( gadget -- gadget ) - GL_PROJECTION glMatrixMode - glLoadIdentity - cel-shading-frustum glFrustum - GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - GL_MODELVIEW glMatrixMode - glLoadIdentity - [ >r 0.0 0.0 r> cel-shading-gadget-distance neg glTranslatef ] keep - [ cel-shading-gadget-pitch 1.0 0.0 0.0 glRotatef ] keep - [ cel-shading-gadget-yaw 0.0 1.0 0.0 glRotatef ] keep - [ cel-shading-gadget-program [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ] keep - [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] keep - [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] keep - "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] keep ; + [ 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 [ @@ -125,27 +83,6 @@ M: cel-shading-gadget draw-gadget* ( gadget -- ) cel-shading-gadget-model first3 draw-bunny ] with-gl-program ; -: 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 ; - -cel-shading-gadget H{ - { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-cel-shading-gadget ] } - { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-cel-shading-gadget ] } - { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-cel-shading-gadget ] } - { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-cel-shading-gadget ] } - { T{ key-down f f "=" } [ KEY-DISTANCE-STEP neg swap zoom-cel-shading-gadget ] } - { T{ key-down f f "-" } [ KEY-DISTANCE-STEP swap zoom-cel-shading-gadget ] } - - { T{ button-down f f 1 } [ drop reset-last-drag-rel ] } - { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-cel-shading-gadget ] keep yaw-cel-shading-gadget ] } - { T{ mouse-scroll } [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-cel-shading-gadget ] } -} set-gestures - : cel-shading-window ( -- ) [ "Cel Shading" open-window ] with-ui ; 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 9356d6c9b5..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 ; @@ -191,3 +199,23 @@ MACRO: construct-slots ( assoc tuple-class -- tuple ) : either ( object first second -- ? ) >r keep swap [ r> drop ] [ r> call ] ?if ; inline + +: 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 ) + >r pick >r with r> r> swapd with ; + +: or? ( obj quot1 quot2 -- ? ) + >r keep r> rot [ 2nip ] [ call ] if* ; inline + +: and? ( obj quot1 quot2 -- ? ) + >r keep r> rot [ call ] [ 2drop f ] if ; inline + +: prepare-index ( seq quot -- seq n quot ) + >r dup length r> ; inline + +: each-index ( seq quot -- ) + #! quot: ( elt index -- ) + prepare-index 2each ; inline + +: map-index ( seq quot -- ) + #! quot: ( elt index -- obj ) + prepare-index 2map ; inline 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/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/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/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/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/notepadpp/notepadpp.factor b/extra/editors/notepadpp/notepadpp.factor old mode 100644 new mode 100755 index 4f3fde917d..f9fa95f175 --- a/extra/editors/notepadpp/notepadpp.factor +++ b/extra/editors/notepadpp/notepadpp.factor @@ -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..bc9a98a051 --- a/extra/editors/scite/scite.factor +++ b/extra/editors/scite/scite.factor @@ -18,14 +18,13 @@ SYMBOL: scite-path : scite-command ( file line -- cmd ) swap - [ scite-path get % - " \"" % - % - "\" -goto:" % - # - ] "" make ; + [ + scite-path get , + , + "-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..7da4b807ce --- 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 , [ % "/" % # "/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/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/golden-section/golden-section.factor b/extra/golden-section/golden-section.factor index 9dd3a747ed..ef6f1ca4c2 100644 --- a/extra/golden-section/golden-section.factor +++ b/extra/golden-section/golden-section.factor @@ -1,28 +1,25 @@ -USING: kernel namespaces math math.constants math.functions -arrays sequences opengl opengl.gl opengl.glu ui ui.render -ui.gadgets ui.gadgets.theme ui.gadgets.slate colors ; +USING: kernel namespaces math math.constants math.functions arrays sequences + opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme + ui.gadgets.slate colors ; IN: golden-section ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! To run: -! -! "demos.golden-section" run +! "golden-section" run ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : disk ( quadric radius center -- ) -glPushMatrix -gl-translate -dup 0 glScalef -0 1 10 10 gluDisk -glPopMatrix ; + glPushMatrix + gl-translate + dup 0 glScalef + 0 1 10 10 gluDisk + glPopMatrix ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: phi ( -- phi ) 5 sqrt 1 + 2 / 1 - ; - -: omega ( i -- omega ) phi * 2 * pi * ; +: omega ( i -- omega ) phi 1- * 2 * pi * ; : x ( i -- x ) dup omega cos * 0.5 * ; @@ -35,10 +32,10 @@ glPopMatrix ; : color ( i -- color ) 360.0 / dup 0.25 1 4array ; : rim ( quadric i -- ) -black gl-color dup radius 1.5 * swap center disk ; + black gl-color dup radius 1.5 * swap center disk ; : inner ( quadric i -- ) -dup color gl-color dup radius swap center disk ; + dup color gl-color dup radius swap center disk ; : dot ( quadric i -- ) 2dup rim inner ; @@ -47,21 +44,21 @@ dup color gl-color dup radius swap center disk ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : with-quadric ( quot -- ) -gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline + gluNewQuadric [ swap call ] keep gluDeleteQuadric ; inline : display ( -- ) -GL_PROJECTION glMatrixMode -glLoadIdentity --400 400 -400 400 -1 1 glOrtho -GL_MODELVIEW glMatrixMode -glLoadIdentity -[ golden-section ] with-quadric ; + GL_PROJECTION glMatrixMode + glLoadIdentity + -400 400 -400 400 -1 1 glOrtho + GL_MODELVIEW glMatrixMode + glLoadIdentity + [ golden-section ] with-quadric ; : golden-section-window ( -- ) -[ - [ display ] - { 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/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/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/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/hashtables/lib/lib.factor b/extra/hashtables/lib/lib.factor deleted file mode 100755 index ee35093929..0000000000 --- a/extra/hashtables/lib/lib.factor +++ /dev/null @@ -1,19 +0,0 @@ - -USING: kernel sequences assocs ; - -IN: hashtables.lib - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: ref-hash ( table key -- value ) swap at ; - -! set-hash with alternative stack effects - -: put-hash* ( table key value -- ) spin set-at ; - -: put-hash ( table key value -- table ) swap pick set-at ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: set-hash-stack ( value key seq -- ) - dupd [ key? ] with find-last nip set-at ; 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/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/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor index 57bbbe2481..6a91cd65c5 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 ; 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/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.factor b/extra/http/client/client.factor index f117a4fda1..7c385c0bb3 100644 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -9,11 +9,14 @@ IN: http.client #! Extract the host name and port number from an HTTP URL. ":" split1 [ string>number ] [ 80 ] if* ; +SYMBOL: domain + : parse-url ( url -- host resource ) - "http://" ?head [ - "URL must begin with http://" throw - ] unless - "/" split1 [ "/" swap append ] [ "/" ] if* ; + dup "https://" head? [ + "ssl not yet supported: " swap append throw + ] when "http://" ?head drop + "/" split1 [ "/" swap append ] [ "/" ] if* + >r dup empty? [ drop domain get ] [ dup domain set ] if r> ; : parse-response ( line -- code ) "HTTP/" ?head [ " " split1 nip ] when @@ -52,7 +55,9 @@ DEFER: http-get-stream : http-get ( url -- code headers string ) #! Opens a stream for reading from an HTTP URL. - http-get-stream [ stdio get contents ] with-stream ; + [ + http-get-stream [ stdio get contents ] with-stream + ] with-scope ; : download ( url file -- ) #! Downloads the contents of a URL to a file. 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/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..54198a7dcc --- 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.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..28063bae0d 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,7 +88,7 @@ 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." } ; @@ -73,22 +103,41 @@ 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 { "obj" object } { "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 { "obj" object } { "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." } +{ $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 { "obj" object } { "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 +154,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..7cf9d51ed0 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 @@ -42,17 +67,38 @@ GENERIC: >descriptor ( obj -- 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 ( obj -- process ) + >descriptor + dup run-process* + +detached+ rot at [ dup wait-for-process drop ] unless ; -HOOK: process-stream* io-backend ( desc -- stream ) +: run-detached ( obj -- process ) + >descriptor H{ { +detached+ t } } union run-process ; + +HOOK: process-stream* io-backend ( desc -- stream process ) + +TUPLE: process-stream process ; : ( obj -- stream ) - >descriptor process-stream* ; + >descriptor process-stream* + { set-delegate set-process-stream-process } + process-stream construct ; + +: with-process-stream ( obj 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/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.factor b/extra/io/monitor/monitor.factor new file mode 100755 index 0000000000..23b336c929 --- /dev/null +++ b/extra/io/monitor/monitor.factor @@ -0,0 +1,19 @@ +! 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: close-monitor io-backend ( monitor -- ) + +HOOK: next-change io-backend ( monitor -- path changes ) + +SYMBOL: +change-file+ +SYMBOL: +change-name+ +SYMBOL: +change-size+ +SYMBOL: +change-attributes+ +SYMBOL: +change-modified+ + +: with-monitor ( path recursive? quot -- ) + >r r> over [ close-monitor ] curry [ ] cleanup ; 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 index 049c3bf497..d6d619229f 100644 --- 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 ; IN: io.nonblocking ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" @@ -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..8a7e732281 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -12,38 +12,36 @@ SYMBOL: default-buffer-size ! Common delegate of native stream readers and writers TUPLE: port handle error 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> ] [ ] [ stream-close ] cleanup ; : touch-port ( port -- ) @@ -162,7 +160,7 @@ M: output-port stream-flush ( port -- ) 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 + output-port eq? [ dup port-flush ] when dup port-handle close-handle dup delegate [ buffer-free ] when* f over set-delegate @@ -170,8 +168,8 @@ M: port stream-close 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 +178,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/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..ae87c05d38 100644 --- a/extra/io/sniffer/bsd/bsd.factor +++ b/extra/io/sniffer/bsd/bsd.factor @@ -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..c697b60973 --- a/extra/io/sockets/headers/headers.factor +++ b/extra/io/sockets/headers/headers.factor @@ -9,6 +9,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.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/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 3522a2218b..6da26b5b67 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -1,22 +1,66 @@ -! 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 ; + +M: mx unregister-io-task ( task mx -- ) + fd/container delete-at drop ; ! Some general stuff : file-mode OCT: 0666 ; @@ -49,72 +93,16 @@ 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 - -! 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 -- ) +: handle-io-task ( mx task -- ) dup io-task-port touch-port - dup do-io-task [ pop-callbacks ] [ drop ] if ; + dup do-io-task [ pop-callbacks ] [ 2drop ] 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,17 +125,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 - pending-error ; + [ add-io-task stop ] callcc0 pending-error ; ! Writers : write-step ( port -- ? ) @@ -156,35 +142,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 drop ] + [ drop add-io-task ] if ; : (wait-to-write) ( port -- ) - [ swap add-write-io-task stop ] callcc0 drop ; + [ add-write-io-task stop ] callcc0 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..fcb48dd577 --- /dev/null +++ b/extra/io/unix/linux/linux.factor @@ -0,0 +1,15 @@ +! 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 ; + +TUPLE: linux-io ; + +INSTANCE: linux-io unix-io + +M: linux-io init-io ( -- ) + mx set-global + start-wait-thread ; + +T{ linux-io } set-io-backend 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/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 index 0787a1afde..35366b1d41 100644 --- 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 @@ -33,16 +33,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 stop ] callcc0 drop ; M: unix-io (client) ( addrspec -- stream ) dup make-sockaddr/size >r >r @@ -66,9 +65,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 +83,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 stop ] callcc0 drop ; USE: io.sockets @@ -99,7 +97,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 +108,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 +133,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 +147,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 stop ] callcc0 drop ; M: unix-io receive ( datagram -- packet addrspec ) dup check-datagram-port @@ -166,8 +162,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,11 +178,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 - 2drop 2drop ; + [ add-io-task stop ] callcc0 2drop 2drop ; M: unix-io send ( packet addrspec datagram -- ) 3dup check-datagram-send 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/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..5f87088804 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -38,7 +38,7 @@ 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 ) @@ -58,7 +58,7 @@ M: windows-ce-io accept ( server -- client ) 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 +78,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..7b793ef74d 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 -- ) @@ -93,10 +87,58 @@ 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 GENERIC_WRITE CREATE_ALWAYS redirect + swap inherited-stderr ?closed ; + +: 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 +146,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/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..82d609c371 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -116,25 +116,27 @@ M: windows-nt-io add-completion ( handle -- ) : lookup-callback ( GetQueuedCompletion-args -- callback ) io-hash get-global delete-at* drop ; -: 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 ; +: drain-overlapped ( timeout -- ) + handle-overlapped [ 0 drain-overlapped ] unless ; + : maybe-expire ( io-callbck -- ) io-callback-port dup timeout? [ @@ -144,10 +146,10 @@ M: windows-nt-io add-completion ( handle -- ) ] if ; : cancel-timeout ( -- ) - io-hash get-global values [ maybe-expire ] each ; + io-hash get-global [ nip maybe-expire ] assoc-each ; M: windows-nt-io io-multiplex ( ms -- ) - cancel-timeout wait-for-io [ schedule-thread ] when* ; + cancel-timeout 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/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..746b02a3cb --- /dev/null +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -0,0 +1,101 @@ +! Copyright (C) 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types destructors io.windows kernel math windows +windows.kernel32 windows.types libc assocs alien namespaces +continuations io.monitor sequences hashtables sorting arrays ; +IN: io.windows.nt.monitor + +TUPLE: monitor handle recursive? buffer 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 + ] with-destructors ; + +: buffer-size 65536 ; inline + +M: windows-nt-io ( path recursive? -- monitor ) + [ + >r open-directory r> + buffer-size malloc dup free-later f + ] with-destructors + f monitor construct-boa ; + +: check-closed ( monitor -- ) + monitor-closed? [ "Monitor closed" throw ] when ; + +M: windows-nt-io close-monitor ( monitor -- ) + dup check-closed + dup monitor-buffer free + dup monitor-handle CloseHandle drop + t swap set-monitor-closed? ; + +: fill-buffer ( monitor -- bytes ) + [ + dup monitor-handle + over monitor-buffer + buffer-size + roll monitor-recursive? 1 0 ? + FILE_NOTIFY_CHANGE_ALL + 0 [ + f + f + ReadDirectoryChangesW win32-error=0/f + ] keep *uint + ] with-destructors ; + +: parse-action-flag ( action mask symbol -- action ) + >r over bitand 0 > [ r> , ] [ r> drop ] if ; + +: parse-action ( action -- changes ) + [ + FILE_NOTIFY_CHANGE_FILE +change-file+ parse-action-flag + FILE_NOTIFY_CHANGE_DIR_NAME +change-name+ parse-action-flag + FILE_NOTIFY_CHANGE_ATTRIBUTES +change-attributes+ parse-action-flag + FILE_NOTIFY_CHANGE_SIZE +change-size+ parse-action-flag + FILE_NOTIFY_CHANGE_LAST_WRITE +change-modified+ parse-action-flag + FILE_NOTIFY_CHANGE_LAST_ACCESS +change-attributes+ parse-action-flag + FILE_NOTIFY_CHANGE_EA +change-attributes+ parse-action-flag + FILE_NOTIFY_CHANGE_CREATION +change-attributes+ parse-action-flag + FILE_NOTIFY_CHANGE_SECURITY +change-attributes+ parse-action-flag + FILE_NOTIFY_CHANGE_FILE_NAME +change-name+ parse-action-flag + drop + ] { } make ; + +: changed-file ( buffer -- changes path ) + { + FILE_NOTIFY_INFORMATION-FileName + FILE_NOTIFY_INFORMATION-FileNameLength + FILE_NOTIFY_INFORMATION-Action + } get-slots parse-action -rot memory>u16-string ; + +: (changed-files) ( buffer -- ) + dup changed-file namespace [ append ] change-at + dup FILE_NOTIFY_INFORMATION-NextEntryOffset + dup zero? [ 2drop ] [ + swap (changed-files) + ] if ; + +: changed-files ( buffer len -- assoc ) + [ + zero? [ drop ] [ (changed-files) ] if + ] H{ } make-assoc ; + +: fill-queue ( monitor -- ) + dup monitor-buffer + over fill-buffer 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..ae15e404d9 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -149,7 +149,7 @@ M: windows-nt-io ( addrspec -- server ) [ SOCK_STREAM server-fd dup listen-on-socket dup add-completion - f + ] keep ] with-destructors ; @@ -158,7 +158,7 @@ M: windows-nt-io ( addrspec -- datagram ) [ SOCK_DGRAM server-fd dup add-completion - f + ] keep ] with-destructors ; @@ -202,7 +202,7 @@ TUPLE: WSARecvFrom-args port : 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 ; 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..efac6cb1cc 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -4,7 +4,7 @@ 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 ; IN: io.windows TUPLE: windows-nt-io ; @@ -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 ; 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/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/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..054f07f63f --- /dev/null +++ b/extra/line-art/line-art.factor @@ -0,0 +1,251 @@ +USING: arrays bunny combinators.lib continuations io io.files kernel + math math.functions math.vectors multiline + namespaces + 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" } + 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 ; + +M: line-art-gadget ungraft* ( gadget -- ) + dup line-art-gadget-framebuffer [ + { [ line-art-gadget-step1-program delete-gl-program ] + [ line-art-gadget-step2-program delete-gl-program ] + [ line-art-gadget-framebuffer delete-framebuffer ] + [ line-art-gadget-color-texture delete-texture ] + [ line-art-gadget-normal-texture delete-texture ] + [ line-art-gadget-depth-texture delete-texture ] + [ 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/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/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..7e2b8842ad 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 : pi ( -- pi ) 3.14159265358979323846 ; inline +: phi ( -- phi ) 1.61803398874989484820 ; 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/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 79a4855c04..6e66119cb0 100644 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -1,8 +1,8 @@ -! USING: kernel quotations namespaces sequences hashtables.lib ; +! USING: kernel quotations namespaces sequences assocs.lib ; USING: kernel namespaces namespaces.private quotations sequences - hashtables.lib ; + assocs.lib ; IN: namespaces.lib @@ -16,4 +16,4 @@ IN: namespaces.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: set* ( val var -- ) namestack* set-hash-stack ; \ No newline at end of file +: set* ( val var -- ) namestack* set-hash-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/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/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/opengl-docs.factor b/extra/opengl/opengl-docs.factor index 58b86f09b3..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." } ; @@ -148,11 +204,11 @@ HELP: gl-shader-info-log 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 a set of shaders into a GLSL program" } + { { $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 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" } } @@ -162,6 +218,12 @@ 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 } "." } ; @@ -180,21 +242,80 @@ HELP: delete-gl-program HELP: with-gl-program { $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation" } } -{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ; +{ $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 } diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor old mode 100644 new mode 100755 index 80c9b80ea7..656c514cd1 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -1,9 +1,10 @@ ! 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 libc 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 ; IN: opengl : coordinates [ first2 ] 2apply ; @@ -93,8 +94,63 @@ 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 + [ call ] + [ 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 ; @@ -191,10 +255,13 @@ TUPLE: sprite loc dim dim2 dlist texture ; : c-true? ( int -- ? ) zero? not ; inline : with-gl-shader-source-ptr ( string quot -- ) - swap dup length 1+ [ tuck string>memory swap call ] with-malloc ; inline + 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 + glCreateShader dup rot + [ 1 swap f glShaderSource ] with-gl-shader-source-ptr [ glCompileShader ] keep gl-error ; @@ -211,19 +278,27 @@ TUPLE: sprite loc dim dim2 dlist texture ; GL_VERTEX_SHADER ; inline : (vertex-shader?) ( object -- ? ) - dup (gl-shader?) [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ] [ drop f ] if ; + 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 ; + 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 swap glGetShaderInfoLog ] keep alien>char-string ] with-malloc ; + 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 ; @@ -241,7 +316,7 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ; [ dupd glAttachShader ] each [ glLinkProgram ] keep gl-error ; - + : (gl-program?) ( object -- ? ) dup integer? [ glIsProgram c-true? ] [ drop f ] if ; @@ -266,19 +341,86 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ; GL_ATTACHED_SHADERS gl-program-get-int ; inline : gl-program-shaders ( program -- shaders ) - dup gl-program-shaders-length - [ dup "GLuint" [ 0 swap glGetAttachedShaders ] keep ] keep - c-uint-array> ; + dup gl-program-shaders-length [ + dup "GLuint" 0 over glGetAttachedShaders + ] keep c-uint-array> ; -: delete-gl-program-only ( program -- ) glDeleteProgram ; inline +: delete-gl-program-only ( program -- ) + glDeleteProgram ; inline -: detach-gl-program-shader ( program shader -- ) glDetachShader ; 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 ; + dup gl-program-shaders [ + 2dup detach-gl-program-shader delete-gl-shader + ] each delete-gl-program-only ; : with-gl-program ( program quot -- ) - swap glUseProgram call 0 glUseProgram ; inline + swap glUseProgram [ call ] [ 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/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/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 ; - 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..67a8befb0a --- /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 project-euler.024 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/common/common.factor b/extra/project-euler/common/common.factor index 2bd2b7ec0b..c875a440ba 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 ! collect-consecutive - #8, #11 ! log10 - #25, #134 ! max-path - #18, #67 -! number>digits - #16, #20 +! number>digits - #16, #20, #30 ! 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..329a1b9668 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -8,7 +8,8 @@ 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.025 project-euler.026 project-euler.027 project-euler.028 + project-euler.029 project-euler.030 project-euler.067 project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler diff --git a/extra/random-tester/authors.txt b/extra/random-tester/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/random-tester/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/random-tester/databank/authors.txt b/extra/random-tester/databank/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/random-tester/databank/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/random-tester/random/authors.txt b/extra/random-tester/random/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/random-tester/random/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/random-tester/safe-words/authors.txt b/extra/random-tester/safe-words/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/random-tester/safe-words/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/random-tester/utils/authors.txt b/extra/random-tester/utils/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/random-tester/utils/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/raptor/authors.txt b/extra/raptor/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/raptor/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/raptor/cron/authors.txt b/extra/raptor/cron/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/raptor/cron/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/regexp/authors.txt b/extra/regexp/authors.txt new file mode 100755 index 0000000000..5674120196 --- /dev/null +++ b/extra/regexp/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/extra/rss/authors.txt b/extra/rss/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/rss/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/rss/summary.txt b/extra/rss/summary.txt new file mode 100755 index 0000000000..b65787ab67 --- /dev/null +++ b/extra/rss/summary.txt @@ -0,0 +1 @@ +RSS 1.0, 2.0 and Atom feed parser diff --git a/extra/shufflers/shufflers-docs.factor b/extra/shufflers/shufflers-docs.factor index efeb4dc8a4..ac372534ae 100644 --- a/extra/shufflers/shufflers-docs.factor +++ b/extra/shufflers/shufflers-docs.factor @@ -1,4 +1,5 @@ -USING: shufflers help.syntax help.markup ; +USING: help.syntax help.markup ; +IN: shufflers HELP: SHUFFLE: { $syntax "SHUFFLE: alphabet #" } diff --git a/extra/shufflers/shufflers.factor b/extra/shufflers/shufflers.factor index 01b5133a80..172db1def1 100644 --- a/extra/shufflers/shufflers.factor +++ b/extra/shufflers/shufflers.factor @@ -29,7 +29,7 @@ IN: shufflers : define-shuffles ( names max-out -- ) in-shuffle over length make-shuffles [ [ shuffle>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/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/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/store/blob/authors.txt b/extra/store/blob/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/store/blob/authors.txt @@ -0,0 +1 @@ +Doug Coleman 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 870e72b385..223fdb2090 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -1,8 +1,14 @@ - -USING: math arrays sequences ; - +USING: math arrays sequences kernel splitting strings ; IN: strings.lib : char>digit ( c -- i ) 48 - ; : string>digits ( s -- seq ) [ char>digit ] { } map-as ; + +: >Upper ( str -- str ) + dup empty? [ + unclip ch>upper 1string swap append + ] unless ; + +: >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/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..539b348706 --- a/extra/tools/completion/completion.factor +++ b/extra/tools/completion/completion.factor @@ -60,13 +60,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/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..7efb34a6ae 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 ; 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/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/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/lib/authors.txt b/extra/ui/gadgets/lib/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/ui/gadgets/lib/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/ui/gadgets/slate/authors.txt b/extra/ui/gadgets/slate/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/ui/gadgets/slate/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/ui/tools/deploy/authors.txt b/extra/ui/tools/deploy/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/ui/tools/deploy/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index febb56e10f..4daadd2765 100755 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -120,12 +120,12 @@ SYMBOL: ui-hook [ dup update-hand draw-world ] each ; : notify ( gadget -- ) - dup gadget-graft-state { - { { f t } [ dup activate-control dup graft* ] } - { { t f } [ dup activate-control dup ungraft* ] } - } case - dup gadget-graft-state first { f f } { t t } ? - swap set-gadget-graft-state ; + dup gadget-graft-state [ dup { + { { f t } [ over activate-control over graft* ] } + { { t f } [ over activate-control over ungraft* ] } + } case ] + [ first { f f } { t t } ? + swap set-gadget-graft-state ] [ ] cleanup ; : notify-queued ( -- ) graft-queue [ notify ] dlist-slurp ; diff --git a/extra/ui/windows/authors.txt b/extra/ui/windows/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/ui/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/ui/x11/authors.txt b/extra/ui/x11/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/ui/x11/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/unicode/breaks/authors.txt b/extra/unicode/breaks/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/unicode/breaks/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/unicode/case/authors.txt b/extra/unicode/case/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/unicode/case/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/unicode/categories/authors.txt b/extra/unicode/categories/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/unicode/categories/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/unicode/data/authors.txt b/extra/unicode/data/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/unicode/data/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/unicode/normalize/authors.txt b/extra/unicode/normalize/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/unicode/normalize/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/unicode/syntax/authors.txt b/extra/unicode/syntax/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/unicode/syntax/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/units/authors.txt b/extra/units/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/units/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/units/constants/authors.txt b/extra/units/constants/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/units/constants/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/units/imperial/authors.txt b/extra/units/imperial/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/units/imperial/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/units/si/authors.txt b/extra/units/si/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/units/si/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/unix/kqueue/authors.txt b/extra/unix/kqueue/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/unix/kqueue/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/unix/kqueue/kqueue.factor b/extra/unix/kqueue/kqueue.factor new file mode 100644 index 0000000000..4e6504470d --- /dev/null +++ b/extra/unix/kqueue/kqueue.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax ; +IN: unix.kqueue + +FUNCTION: int kqueue ( ) ; + +FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ; + +C-STRUCT: kevent + { "ulong" "ident" } ! identifier for this event + { "short" "filter" } ! filter for event + { "ushort" "flags" } ! action flags for kqueue + { "uint" "fflags" } ! filter flag value + { "long" "data" } ! filter data value + { "void*" "udata" } ! opaque user data identifier +; + +: EVFILT_READ -1 ; inline +: EVFILT_WRITE -2 ; inline +: EVFILT_AIO -3 ; inline ! attached to aio requests +: EVFILT_VNODE -4 ; inline ! attached to vnodes +: EVFILT_PROC -5 ; inline ! attached to struct proc +: EVFILT_SIGNAL -6 ; inline ! attached to struct proc +: EVFILT_TIMER -7 ; inline ! timers +: EVFILT_MACHPORT -8 ; inline ! Mach ports +: EVFILT_FS -9 ; inline ! Filesystem events + +! actions +: EV_ADD HEX: 1 ; inline ! add event to kq (implies enable) +: EV_DELETE HEX: 2 ; inline ! delete event from kq +: EV_ENABLE HEX: 4 ; inline ! enable event +: EV_DISABLE HEX: 8 ; inline ! disable event (not reported) + +! flags +: EV_ONESHOT HEX: 10 ; inline ! only report one occurrence +: EV_CLEAR HEX: 20 ; inline ! clear event state after reporting + +: EV_SYSFLAGS HEX: f000 ; inline ! reserved by system +: EV_FLAG0 HEX: 1000 ; inline ! filter-specific flag +: EV_FLAG1 HEX: 2000 ; inline ! filter-specific flag + +! returned values +: EV_EOF HEX: 8000 ; inline ! EOF detected +: EV_ERROR HEX: 4000 ; inline ! error, data contains errno + +: EV_POLL EV_FLAG0 ; inline +: EV_OOBAND EV_FLAG1 ; inline + +: NOTE_LOWAT HEX: 00000001 ; inline ! low water mark + +: NOTE_DELETE HEX: 00000001 ; inline ! vnode was removed +: NOTE_WRITE HEX: 00000002 ; inline ! data contents changed +: NOTE_EXTEND HEX: 00000004 ; inline ! size increased +: NOTE_ATTRIB HEX: 00000008 ; inline ! attributes changed +: NOTE_LINK HEX: 00000010 ; inline ! link count changed +: NOTE_RENAME HEX: 00000020 ; inline ! vnode was renamed +: NOTE_REVOKE HEX: 00000040 ; inline ! vnode access was revoked + +: NOTE_EXIT HEX: 80000000 ; inline ! process exited +: NOTE_FORK HEX: 40000000 ; inline ! process forked +: NOTE_EXEC HEX: 20000000 ; inline ! process exec'd +: NOTE_PCTRLMASK HEX: f0000000 ; inline ! mask for hint bits +: NOTE_PDATAMASK HEX: 000fffff ; inline ! mask for pid + +: NOTE_SECONDS HEX: 00000001 ; inline ! data is seconds +: NOTE_USECONDS HEX: 00000002 ; inline ! data is microseconds +: NOTE_NSECONDS HEX: 00000004 ; inline ! data is nanoseconds +: NOTE_ABSOLUTE HEX: 00000008 ; inline ! absolute timeout + +: NOTE_TRACK HEX: 00000001 ; inline ! follow across forks +: NOTE_TRACKERR HEX: 00000002 ; inline ! could not track child +: NOTE_CHILD HEX: 00000004 ; inline ! am a child process diff --git a/extra/unix/linux/authors.txt b/extra/unix/linux/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/unix/linux/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/unix/linux/epoll/authors.txt b/extra/unix/linux/epoll/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/unix/linux/epoll/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/unix/linux/epoll/epoll.factor b/extra/unix/linux/epoll/epoll.factor new file mode 100644 index 0000000000..c18fa2ee6c --- /dev/null +++ b/extra/unix/linux/epoll/epoll.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: unix.linux.epoll +USING: alien.syntax math ; + +FUNCTION: int epoll_create ( int size ) ; + +FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ; + +C-STRUCT: epoll-event + { "uint" "events" } + { "uint" "fd" } + { "uint" "padding" } ; + +FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ; + +: EPOLL_CTL_ADD 1 ; inline ! Add a file decriptor to the interface. +: EPOLL_CTL_DEL 2 ; inline ! Remove a file decriptor from the interface. +: EPOLL_CTL_MOD 3 ; inline ! Change file decriptor epoll_event structure. + +: EPOLLIN HEX: 001 ; inline +: EPOLLPRI HEX: 002 ; inline +: EPOLLOUT HEX: 004 ; inline +: EPOLLRDNORM HEX: 040 ; inline +: EPOLLRDBAND HEX: 080 ; inline +: EPOLLWRNORM HEX: 100 ; inline +: EPOLLWRBAND HEX: 200 ; inline +: EPOLLMSG HEX: 400 ; inline +: EPOLLERR HEX: 008 ; inline +: EPOLLHUP HEX: 010 ; inline +: EPOLLET 31 2^ ; inline diff --git a/extra/unix/linux/fs/authors.txt b/extra/unix/linux/fs/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/unix/linux/fs/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/unix/linux/if/authors.txt b/extra/unix/linux/if/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/unix/linux/if/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/unix/linux/ifreq/authors.txt b/extra/unix/linux/ifreq/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/unix/linux/ifreq/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/unix/linux/route/authors.txt b/extra/unix/linux/route/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/unix/linux/route/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/unix/linux/sockios/authors.txt b/extra/unix/linux/sockios/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/unix/linux/sockios/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/unix/linux/swap/authors.txt b/extra/unix/linux/swap/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/unix/linux/swap/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/unix/process/authors.txt b/extra/unix/process/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/unix/process/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor old mode 100644 new mode 100755 index a99611aba6..fb4271ea23 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -1,53 +1,35 @@ - -USING: kernel alien.c-types sequences math unix combinators.cleave ; +USING: kernel alien.c-types sequences math unix +combinators.cleave vectors kernel namespaces continuations +threads assocs vectors ; IN: unix.process -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Low-level Unix process launching utilities. These are used +! to implement io.launcher on Unix. User code should use +! io.launcher instead. : >argv ( seq -- alien ) [ malloc-char-string ] map f add >c-void*-array ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : exec ( pathname argv -- int ) - [ malloc-char-string ] [ >argv ] bi* execv ; + [ malloc-char-string ] [ >argv ] bi* execv ; : exec-with-path ( filename argv -- int ) - [ malloc-char-string ] [ >argv ] bi* execvp ; + [ malloc-char-string ] [ >argv ] bi* execvp ; : exec-with-env ( filename argv envp -- int ) - [ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ; + [ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: exec-args ( seq -- int ) + [ first ] [ ] bi exec ; -: exec-args ( seq -- int ) [ first ] [ ] bi exec ; -: exec-args-with-path ( seq -- int ) [ first ] [ ] bi exec-with-path ; +: exec-args-with-path ( seq -- int ) + [ first ] [ ] bi exec-with-path ; -: exec-args-with-env ( seq seq -- int ) >r [ first ] [ ] bi r> exec-with-env ; +: exec-args-with-env ( seq seq -- int ) + >r [ first ] [ ] bi r> exec-with-env ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: with-fork ( child parent -- ) + fork dup zero? -roll swap curry if ; inline -: with-fork ( child parent -- ) fork dup zero? -roll swap curry if ; inline - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USING: kernel alien.c-types namespaces continuations threads assocs unix - combinators.cleave ; - -SYMBOL: pid-wait - -! KEY | VALUE -! ----------- -! pid | continuation - -: init-pid-wait ( -- ) H{ } clone pid-wait set-global ; - -: wait-for-pid ( pid -- status ) [ pid-wait get set-at stop ] curry callcc1 ; - -: wait-loop ( -- ) - -1 0 tuck WNOHANG waitpid ! &status return - [ *int ] [ pid-wait get delete-at* drop ] bi* ! status ? - dup [ schedule-thread-with ] [ 2drop ] if - 250 sleep wait-loop ; - -: start-wait-loop ( -- ) init-pid-wait [ wait-loop ] in-thread ; \ No newline at end of file +: wait-for-pid ( pid -- status ) + 0 [ 0 waitpid drop ] keep *int ; \ No newline at end of file diff --git a/extra/unix/solaris/authors.txt b/extra/unix/solaris/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/unix/solaris/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 94bb598c25..f5c484568e 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -13,7 +13,7 @@ TYPEDEF: longlong quad_t TYPEDEF: uint gid_t TYPEDEF: uint in_addr_t TYPEDEF: uint ino_t -TYPEDEF: uint pid_t +TYPEDEF: int pid_t TYPEDEF: uint socklen_t TYPEDEF: uint time_t TYPEDEF: uint uid_t @@ -41,6 +41,12 @@ C-STRUCT: timespec { "time_t" "sec" } { "long" "nsec" } ; +: make-timespec ( ms -- timespec ) + 1000 /mod 1000000 * + "timespec" + [ set-timespec-nsec ] keep + [ set-timespec-sec ] keep ; + ! ! ! Unix constants ! File type diff --git a/extra/webapps/article-manager/database/authors.txt b/extra/webapps/article-manager/database/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/webapps/article-manager/database/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/webapps/callback/authors.txt b/extra/webapps/callback/authors.txt new file mode 100755 index 0000000000..a8fb961d36 --- /dev/null +++ b/extra/webapps/callback/authors.txt @@ -0,0 +1,2 @@ +Chris Double +Slava Pestov diff --git a/extra/webapps/cgi/authors.txt b/extra/webapps/cgi/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/webapps/cgi/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/webapps/continuation/authors.txt b/extra/webapps/continuation/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/webapps/continuation/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/webapps/continuation/examples/authors.txt b/extra/webapps/continuation/examples/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/webapps/continuation/examples/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/webapps/file/authors.txt b/extra/webapps/file/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/webapps/file/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/webapps/help/authors.txt b/extra/webapps/help/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/webapps/help/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/webapps/numbers/authors.txt b/extra/webapps/numbers/authors.txt new file mode 100755 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/webapps/numbers/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/webapps/pastebin/authors.txt b/extra/webapps/pastebin/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/webapps/pastebin/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/webapps/planet/authors.txt b/extra/webapps/planet/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/webapps/planet/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/webapps/source/authors.txt b/extra/webapps/source/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/webapps/source/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/windows/advapi32/authors.txt b/extra/windows/advapi32/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/advapi32/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/windows/ce/authors.txt b/extra/windows/ce/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/ce/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/windows/errors/authors.txt b/extra/windows/errors/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/errors/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/windows/gdi32/authors.txt b/extra/windows/gdi32/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/gdi32/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/windows/kernel32/authors.txt b/extra/windows/kernel32/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/kernel32/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 5e0f4ddc65..15bdcd3e37 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -87,7 +87,7 @@ C-STRUCT: FILE_NOTIFY_INFORMATION { "DWORD" "NextEntryOffset" } { "DWORD" "Action" } { "DWORD" "FileNameLength" } - { "WCHAR*" "FileName" } ; + { "WCHAR[1]" "FileName" } ; TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION : STD_INPUT_HANDLE -10 ; inline @@ -898,7 +898,7 @@ FUNCTION: HANDLE GetCurrentThread ( ) ; ! FUNCTION: GetEnvironmentStringsW ! FUNCTION: GetEnvironmentVariableA ! FUNCTION: GetEnvironmentVariableW -! FUNCTION: GetExitCodeProcess +FUNCTION: BOOL GetExitCodeProcess ( HANDLE hProcess, LPDWORD lpExitCode ) ; ! FUNCTION: GetExitCodeThread ! FUNCTION: GetExpandedNameA ! FUNCTION: GetExpandedNameW @@ -1496,7 +1496,7 @@ FUNCTION: BOOL VirtualQueryEx ( HANDLE hProcess, void* lpAddress, MEMORY_BASIC_I ! FUNCTION: VirtualUnlock ! FUNCTION: WaitCommEvent ! FUNCTION: WaitForDebugEvent -! FUNCTION: WaitForMultipleObjects +FUNCTION: DWORD WaitForMultipleObjects ( DWORD nCount, HANDLE* lpHandles, BOOL bWaitAll, DWORD dwMilliseconds ) ; ! FUNCTION: WaitForMultipleObjectsEx FUNCTION: BOOL WaitForSingleObject ( HANDLE hHandle, DWORD dwMilliseconds ) ; ! FUNCTION: WaitForSingleObjectEx diff --git a/extra/windows/messages/authors.txt b/extra/windows/messages/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/messages/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/windows/nt/authors.txt b/extra/windows/nt/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/nt/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/windows/opengl32/authors.txt b/extra/windows/opengl32/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/opengl32/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/windows/shell32/authors.txt b/extra/windows/shell32/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/shell32/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/windows/time/authors.txt b/extra/windows/time/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/time/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/calendar/windows/windows-tests.factor b/extra/windows/time/time-tests.factor similarity index 100% rename from extra/calendar/windows/windows-tests.factor rename to extra/windows/time/time-tests.factor diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor new file mode 100755 index 0000000000..3ccb4cfa67 --- /dev/null +++ b/extra/windows/time/time.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types kernel math windows windows.kernel32 +namespaces calendar.backend ; +IN: windows.time + +: >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/windows/types/authors.txt b/extra/windows/types/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/types/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/windows/user32/authors.txt b/extra/windows/user32/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/user32/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/windows/winsock/authors.txt b/extra/windows/winsock/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/windows/winsock/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/x/font/authors.txt b/extra/x/font/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/font/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/gc/authors.txt b/extra/x/gc/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/gc/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/keysym-table/authors.txt b/extra/x/keysym-table/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/keysym-table/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/pen/authors.txt b/extra/x/pen/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/pen/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/authors.txt b/extra/x/widgets/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/button/authors.txt b/extra/x/widgets/button/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/button/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/keymenu/authors.txt b/extra/x/widgets/keymenu/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/keymenu/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/label/authors.txt b/extra/x/widgets/label/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/label/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/wm/child/authors.txt b/extra/x/widgets/wm/child/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/wm/child/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/wm/frame/authors.txt b/extra/x/widgets/wm/frame/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/wm/frame/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/wm/frame/drag/authors.txt b/extra/x/widgets/wm/frame/drag/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/wm/frame/drag/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/wm/frame/drag/move/authors.txt b/extra/x/widgets/wm/frame/drag/move/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/wm/frame/drag/move/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/wm/frame/drag/size/authors.txt b/extra/x/widgets/wm/frame/drag/size/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/wm/frame/drag/size/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/wm/menu/authors.txt b/extra/x/widgets/wm/menu/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/wm/menu/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/wm/root/authors.txt b/extra/x/widgets/wm/root/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/wm/root/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/wm/unmapped-frames-menu/authors.txt b/extra/x/widgets/wm/unmapped-frames-menu/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/wm/unmapped-frames-menu/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/x/widgets/wm/workspace/authors.txt b/extra/x/widgets/wm/workspace/authors.txt new file mode 100755 index 0000000000..6cfd5da273 --- /dev/null +++ b/extra/x/widgets/wm/workspace/authors.txt @@ -0,0 +1 @@ +Eduardo Cavazos diff --git a/extra/xml/char-classes/authors.txt b/extra/xml/char-classes/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/xml/char-classes/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/xml/data/authors.txt b/extra/xml/data/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/xml/data/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/xml/entities/authors.txt b/extra/xml/entities/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/xml/entities/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/xml/errors/authors.txt b/extra/xml/errors/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/xml/errors/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/xml/generator/authors.txt b/extra/xml/generator/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/xml/generator/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/xml/test/authors.txt b/extra/xml/test/authors.txt new file mode 100755 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/xml/test/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg 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/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/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/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/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/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/Help for Word.tmCommand b/misc/Factor.tmbundle/Commands/Help for Word.tmCommand index 350c01d344..0ff133c891 100644 --- a/misc/Factor.tmbundle/Commands/Help for Word.tmCommand +++ b/misc/Factor.tmbundle/Commands/Help for Word.tmCommand @@ -11,7 +11,7 @@ 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: help\n \\ #{word} help)) +factor_run(%Q(#{doc_using_statements(doc)} USE: ui.tools.workspace\n \\ #{word} help-window)) fallbackInput word input diff --git a/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage b/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage index 8df0179fd1..199185c93d 100644 --- a/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage +++ b/misc/Factor.tmbundle/Syntaxes/Factor.tmLanguage @@ -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 diff --git a/misc/factor.sh b/misc/factor.sh index b2cbb836e6..8dca786846 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -237,19 +237,19 @@ maybe_download_dlls() { 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" -} - install() { check_factor_exists - check_installed_programs - find_build_info - check_libraries + get_config_info git_clone cd_factor make_factor @@ -259,9 +259,7 @@ install() { } update() { - check_installed_programs - find_build_info - check_libraries + get_config_info git_pull_factorcode make_clean make_factor @@ -288,11 +286,16 @@ install_libraries() { sudo apt-get install libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap } +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 ;; + bootstrap) get_config_info; bootstrap ;; *) usage ;; esac 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/os-macosx.m b/vm/os-macosx.m index 07695b77fb..d14e6ceb23 100644 --- a/vm/os-macosx.m +++ b/vm/os-macosx.m @@ -30,7 +30,7 @@ void early_init(void) const char *vm_executable_path(void) { - return [[[NSBundle mainBundle] executablePath] cString]; + return [[[NSBundle mainBundle] executablePath] UTF8String]; } const char *default_image_path(void) @@ -55,7 +55,7 @@ const char *default_image_path(void) else returnVal = [path stringByAppendingPathComponent:image]; - return [returnVal cString]; + return [returnVal UTF8String]; } void init_signals(void) diff --git a/vm/primitives.c b/vm/primitives.c index dd96ee1495..7151d139bf 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -150,8 +150,6 @@ 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, diff --git a/vm/run.h b/vm/run.h index 6f2caa0c14..976fa36337 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; diff --git a/vm/types.c b/vm/types.c index d70c1623f4..51dd4c3da4 100755 --- a/vm/types.c +++ b/vm/types.c @@ -363,12 +363,6 @@ DEFINE_PRIMITIVE(resize_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; \ diff --git a/vm/types.h b/vm/types.h index c896b69eba..356b944133 100755 --- a/vm/types.h +++ b/vm/types.h @@ -154,26 +154,22 @@ F_STRING *reallot_string(F_STRING *string, CELL capacity, u16 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);