diff --git a/core/alien/alien.factor b/core/alien/alien.factor index f664e1175a..cc37b85103 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -28,12 +28,6 @@ M: f expired? drop t ; : ( address -- alien ) f { simple-c-ptr } declare ; inline -: alien>native-string ( alien -- string ) - os windows? [ alien>u16-string ] [ alien>char-string ] if ; - -: dll-path ( dll -- string ) - (dll-path) alien>native-string ; - M: alien equal? over alien? [ 2dup [ expired? ] either? [ diff --git a/core/alien/arrays/arrays-docs.factor b/core/alien/arrays/arrays-docs.factor index f3f27d0739..09a09cdc6f 100755 --- a/core/alien/arrays/arrays-docs.factor +++ b/core/alien/arrays/arrays-docs.factor @@ -18,7 +18,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays" { $subsection >c-ushort-array } { $subsection >c-void*-array } { $subsection c-bool-array> } -{ $subsection c-char*-array> } { $subsection c-char-array> } { $subsection c-double-array> } { $subsection c-float-array> } @@ -30,7 +29,6 @@ ARTICLE: "c-arrays-factor" "Converting C arrays to and from Factor arrays" { $subsection c-uint-array> } { $subsection c-ulong-array> } { $subsection c-ulonglong-array> } -{ $subsection c-ushort*-array> } { $subsection c-ushort-array> } { $subsection c-void*-array> } ; @@ -61,9 +59,7 @@ ARTICLE: "c-arrays-get/set" "Reading and writing elements in C arrays" { $subsection double-nth } { $subsection set-double-nth } { $subsection void*-nth } -{ $subsection set-void*-nth } -{ $subsection char*-nth } -{ $subsection ushort*-nth } ; +{ $subsection set-void*-nth } ; ARTICLE: "c-arrays" "C arrays" "C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "." diff --git a/core/alien/arrays/arrays.factor b/core/alien/arrays/arrays.factor index 402b01550b..0f756e0ad0 100644 --- a/core/alien/arrays/arrays.factor +++ b/core/alien/arrays/arrays.factor @@ -1,8 +1,7 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays alien.c-types alien.structs -sequences math kernel generator.registers -namespaces libc ; +sequences math kernel namespaces libc cpu.architecture ; IN: alien.arrays UNION: value-type array struct-type ; @@ -27,7 +26,9 @@ M: array stack-size drop "void*" stack-size ; M: value-type c-type-reg-class drop int-regs ; -M: value-type c-type-prep drop f ; +M: value-type c-type-boxer-quot drop f ; + +M: value-type c-type-unboxer-quot drop f ; M: value-type c-type-getter drop [ swap ] ; diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index 8d2b03467b..3cd5afef33 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -62,28 +62,6 @@ HELP: { malloc-object } related-words -HELP: string>char-alien ( string -- array ) -{ $values { "string" string } { "array" byte-array } } -{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." } -{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." } ; - -{ string>char-alien alien>char-string malloc-char-string } related-words - -HELP: alien>char-string ( c-ptr -- string ) -{ $values { "c-ptr" c-ptr } { "string" string } } -{ $description "Reads a null-terminated 8-bit C string from the specified address." } ; - -HELP: string>u16-alien ( string -- array ) -{ $values { "string" string } { "array" byte-array } } -{ $description "Copies the string to a new byte array in UCS-2 format with a trailing null byte." } -{ $errors "Throws an error if the string contains null characters." } ; - -{ string>u16-alien alien>u16-string malloc-u16-string } related-words - -HELP: alien>u16-string ( c-ptr -- string ) -{ $values { "c-ptr" c-ptr } { "string" string } } -{ $description "Reads a null-terminated UCS-2 string from the specified address." } ; - HELP: memory>byte-array { $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } } { $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ; @@ -111,18 +89,6 @@ HELP: malloc-byte-array { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } { $errors "Throws an error if memory allocation fails." } ; -HELP: malloc-char-string -{ $values { "string" string } { "alien" c-ptr } } -{ $description "Allocates an unmanaged memory block, and stores a string in 8-bit ASCII encoding with a trailing null byte to the block." } -{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } -{ $errors "Throws an error if memory allocation fails." } ; - -HELP: malloc-u16-string -{ $values { "string" string } { "alien" c-ptr } } -{ $description "Allocates an unmanaged memory block, and stores a string in UCS2 encoding with a trailing null character to the block." } -{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } -{ $errors "Throws an error if memory allocation fails." } ; - HELP: define-nth { $values { "name" "a word name" } { "vocab" "a vocabulary name" } } { $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." } @@ -202,8 +168,6 @@ $nl { $subsection *float } { $subsection *double } { $subsection *void* } -{ $subsection *char* } -{ $subsection *ushort* } "Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link } " and " { $link *void* } " may be used." ; ARTICLE: "c-types-specs" "C type specifiers" @@ -267,26 +231,6 @@ $nl "A wrapper for temporarily allocating a block of memory:" { $subsection with-malloc } ; -ARTICLE: "c-strings" "C strings" -"The C library interface defines two types of C strings:" -{ $table - { "C type" "Notes" } - { { $snippet "char*" } "8-bit per character null-terminated ASCII" } - { { $snippet "ushort*" } "16-bit per character null-terminated UCS-2" } -} -"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." -"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" -{ $subsection string>char-alien } -{ $subsection string>u16-alien } -{ $subsection malloc-char-string } -{ $subsection malloc-u16-string } -"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." -$nl -"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:" -{ $subsection alien>char-string } -{ $subsection alien>u16-string } -"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ; - ARTICLE: "c-data" "Passing data between Factor and C" "Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers." $nl diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 843b0a826b..5f57068bab 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -1,30 +1,6 @@ IN: alien.c-types.tests USING: alien alien.syntax alien.c-types kernel tools.test -sequences system libc ; - -[ "\u0000ff" ] -[ "\u0000ff" string>char-alien alien>char-string ] -unit-test - -[ "hello world" ] -[ "hello world" string>char-alien alien>char-string ] -unit-test - -[ "hello\u00abcdworld" ] -[ "hello\u00abcdworld" string>u16-alien alien>u16-string ] -unit-test - -[ t ] [ f expired? ] unit-test - -[ "hello world" ] [ - "hello world" malloc-char-string - dup alien>char-string swap free -] unit-test - -[ "hello world" ] [ - "hello world" malloc-u16-string - dup alien>u16-string swap free -] unit-test +sequences system libc alien.strings io.encodings.utf8 ; : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ; @@ -67,7 +43,7 @@ TYPEDEF: int* MyIntArray TYPEDEF: uchar* MyLPBYTE -[ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test +[ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test [ 0 B{ 1 2 3 4 } diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index c97c760695..f67fc78259 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bit-arrays byte-arrays float-arrays arrays -generator.registers assocs kernel kernel.private libc math +assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary @@ -14,7 +14,7 @@ DEFER: *char : little-endian? ( -- ? ) 1 *char 1 = ; foldable TUPLE: c-type -boxer prep unboxer +boxer boxer-quot unboxer unboxer-quot getter setter reg-class size align stack-align? ; @@ -149,23 +149,12 @@ M: float-array byte-length length "double" heap-size * ; : malloc-byte-array ( byte-array -- alien ) dup length dup malloc [ -rot memcpy ] keep ; -: malloc-char-string ( string -- alien ) - string>char-alien malloc-byte-array ; - -: malloc-u16-string ( string -- alien ) - string>u16-alien malloc-byte-array ; - : memory>byte-array ( alien len -- byte-array ) dup [ -rot memcpy ] keep ; : byte-array>memory ( byte-array base -- ) swap dup length memcpy ; -DEFER: >c-ushort-array - -: string>u16-memory ( string base -- ) - >r >c-ushort-array r> byte-array>memory ; - : (define-nth) ( word type quot -- ) >r heap-size [ rot * ] swap prefix r> append define-inline ; @@ -378,7 +367,7 @@ M: long-long-type box-return ( type -- ) "box_float" >>boxer "to_float" >>unboxer single-float-regs >>reg-class - [ >float ] >>prep + [ >float ] >>unboxer-quot "float" define-primitive-type @@ -389,30 +378,8 @@ M: long-long-type box-return ( type -- ) "box_double" >>boxer "to_double" >>unboxer double-float-regs >>reg-class - [ >float ] >>prep + [ >float ] >>unboxer-quot "double" define-primitive-type - - [ alien-cell alien>char-string ] >>getter - [ set-alien-cell ] >>setter - bootstrap-cell >>size - bootstrap-cell >>align - "box_char_string" >>boxer - "alien_offset" >>unboxer - [ string>char-alien ] >>prep - "char*" define-primitive-type - - "char*" "uchar*" typedef - - - [ alien-cell alien>u16-string ] >>getter - [ set-alien-cell ] >>setter - 4 >>size - 4 >>align - "box_u16_string" >>boxer - "alien_offset" >>unboxer - [ string>u16-alien ] >>prep - "ushort*" define-primitive-type - os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef ] with-compilation-unit diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index d1a14dd758..3d0f36e415 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -364,6 +364,10 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; + + 1+ ] alien-callback ; +FUNCTION: void ffi_test_36_point_5 ( ) ; + +[ ] [ ffi_test_36_point_5 ] unit-test + FUNCTION: int ffi_test_37 ( void* func ) ; [ 1 ] [ callback-9 ffi_test_37 ] unit-test diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 9bd65aa0bc..3de4c61291 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -3,10 +3,11 @@ USING: arrays generator generator.registers generator.fixup hashtables kernel math namespaces sequences words inference.state inference.backend inference.dataflow system -math.parser classes alien.arrays alien.c-types alien.structs -alien.syntax cpu.architecture alien inspector quotations assocs -kernel.private threads continuations.private libc combinators -compiler.errors continuations layouts accessors ; +math.parser classes alien.arrays alien.c-types alien.strings +alien.structs alien.syntax cpu.architecture alien inspector +quotations assocs kernel.private threads continuations.private +libc combinators compiler.errors continuations layouts accessors +; IN: alien.compiler TUPLE: #alien-node < node return parameters abi ; @@ -20,9 +21,7 @@ TUPLE: #alien-invoke < #alien-node library function ; : large-struct? ( ctype -- ? ) dup c-struct? [ heap-size struct-small-enough? not - ] [ - drop f - ] if ; + ] [ drop f ] if ; : alien-node-parameters* ( node -- seq ) dup parameters>> @@ -162,17 +161,16 @@ M: long-long-type flatten-value-type ( type -- ) dup return>> "void" = 0 1 ? swap produce-values ; -: (make-prep-quot) ( parameters -- ) +: (param-prep-quot) ( parameters -- ) dup empty? [ drop ] [ - unclip c-type c-type-prep % - \ >r , (make-prep-quot) \ r> , + unclip c-type c-type-unboxer-quot % + \ >r , (param-prep-quot) \ r> , ] if ; -: make-prep-quot ( node -- quot ) - parameters>> - [ (make-prep-quot) ] [ ] make ; +: param-prep-quot ( node -- quot ) + parameters>> [ (param-prep-quot) ] [ ] make ; : unbox-parameters ( offset node -- ) parameters>> [ @@ -200,6 +198,20 @@ M: long-long-type flatten-value-type ( type -- ) : box-return* ( node -- ) return>> [ ] [ box-return ] if-void ; +: (return-prep-quot) ( parameters -- ) + dup empty? [ + drop + ] [ + unclip c-type c-type-boxer-quot % + \ >r , (return-prep-quot) \ r> , + ] if ; + +: callback-prep-quot ( node -- quot ) + parameters>> [ (return-prep-quot) ] [ ] make ; + +: return-prep-quot ( node -- quot ) + [ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ; + M: alien-invoke-error summary drop "Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ; @@ -258,15 +270,15 @@ M: no-such-symbol compiler-error-type pop-literal nip >>library pop-literal nip >>return ! Quotation which coerces parameters to required types - dup make-prep-quot recursive-state get infer-quot + dup param-prep-quot f infer-quot ! Set ABI - dup library>> - library [ abi>> ] [ "cdecl" ] if* - >>abi + dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi ! Add node to IR dup node, ! Magic #: consume exactly the number of inputs - 0 alien-invoke-stack + dup 0 alien-invoke-stack + ! Quotation which coerces return value to required type + return-prep-quot f infer-quot ] "infer" set-word-prop M: #alien-invoke generate-node @@ -294,11 +306,13 @@ M: alien-indirect-error summary pop-parameters >>parameters pop-literal nip >>return ! Quotation which coerces parameters to required types - dup make-prep-quot [ dip ] curry recursive-state get infer-quot + dup param-prep-quot [ dip ] curry f infer-quot ! Add node to IR dup node, ! Magic #: consume the function pointer, too - 1 alien-invoke-stack + dup 1 alien-invoke-stack + ! Quotation which coerces return value to required type + return-prep-quot f infer-quot ] "infer" set-word-prop M: #alien-indirect generate-node @@ -331,7 +345,7 @@ M: alien-callback-error summary : callback-bottom ( node -- ) xt>> [ word-xt drop ] curry - recursive-state get infer-quot ; + f infer-quot ; \ alien-callback [ 4 ensure-values @@ -371,16 +385,18 @@ TUPLE: callback-context ; slip wait-to-return ; inline -: prepare-callback-return ( ctype -- quot ) +: callback-return-quot ( ctype -- quot ) return>> { { [ dup "void" = ] [ drop [ ] ] } { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } - [ c-type c-type-prep ] + [ c-type c-type-unboxer-quot ] } cond ; : wrap-callback-quot ( node -- quot ) [ - [ quot>> ] [ prepare-callback-return ] bi append , + [ callback-prep-quot ] + [ quot>> ] + [ callback-return-quot ] tri 3append , [ callback-context new do-callback ] % ] [ ] make ; @@ -405,9 +421,10 @@ TUPLE: callback-context ; init-templates %prologue-later dup alien-stack-frame [ - dup registers>objects - dup wrap-callback-quot %alien-callback - %callback-return + [ registers>objects ] + [ wrap-callback-quot %alien-callback ] + [ %callback-return ] + tri ] with-stack-frame ] with-generator ; diff --git a/core/alien/remote-control/remote-control.factor b/core/alien/remote-control/remote-control.factor index b7700c0ff1..1d713f6edd 100755 --- a/core/alien/remote-control/remote-control.factor +++ b/core/alien/remote-control/remote-control.factor @@ -1,12 +1,12 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types parser threads words kernel.private -kernel ; +USING: alien alien.c-types alien.strings parser threads words +kernel.private kernel io.encodings.utf8 ; IN: alien.remote-control : eval-callback "void*" { "char*" } "cdecl" - [ eval>string malloc-char-string ] alien-callback ; + [ eval>string utf8 malloc-string ] alien-callback ; : yield-callback "void" { } "cdecl" [ yield ] alien-callback ; diff --git a/core/alien/strings/strings-docs.factor b/core/alien/strings/strings-docs.factor new file mode 100644 index 0000000000..0dbb4ffd38 --- /dev/null +++ b/core/alien/strings/strings-docs.factor @@ -0,0 +1,52 @@ +USING: help.markup help.syntax strings byte-arrays alien libc +debugger ; +IN: alien.strings + +HELP: string>alien +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "array" byte-array } } +{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." } +{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ; + +{ string>alien alien>string malloc-string } related-words + +HELP: alien>string +{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string" string } } +{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ; + +HELP: malloc-string +{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } } +{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." } +{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } +{ $errors "Throws an error if one of the following conditions occurs:" + { $list + "the string contains null code points" + "the string contains characters not representable using the encoding specified" + "memory allocation fails" + } +} ; + +HELP: string>symbol +{ $values { "str" string } { "alien" alien } } +{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory." +$nl +"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ; + +HELP: utf16n +{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" } +{ $see-also "encodings-introduction" } ; + +ARTICLE: "c-strings" "C strings" +"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." +$nl +"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." +$nl +"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" +{ $subsection string>alien } +{ $subsection malloc-string } +"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." +$nl +"A word to read strings from arbitrary addresses:" +{ $subsection alien>string } +"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ; + +ABOUT: "c-strings" diff --git a/core/alien/strings/strings-tests.factor b/core/alien/strings/strings-tests.factor new file mode 100644 index 0000000000..484809469f --- /dev/null +++ b/core/alien/strings/strings-tests.factor @@ -0,0 +1,30 @@ +USING: alien.strings tools.test kernel libc +io.encodings.8-bit io.encodings.utf8 io.encodings.utf16 +io.encodings.ascii alien ; +IN: alien.strings.tests + +[ "\u0000ff" ] +[ "\u0000ff" latin1 string>alien latin1 alien>string ] +unit-test + +[ "hello world" ] +[ "hello world" latin1 string>alien latin1 alien>string ] +unit-test + +[ "hello\u00abcdworld" ] +[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ] +unit-test + +[ t ] [ f expired? ] unit-test + +[ "hello world" ] [ + "hello world" ascii malloc-string + dup ascii alien>string swap free +] unit-test + +[ "hello world" ] [ + "hello world" utf16n malloc-string + dup utf16n alien>string swap free +] unit-test + +[ f ] [ f utf8 alien>string ] unit-test diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor new file mode 100644 index 0000000000..463fc11e0d --- /dev/null +++ b/core/alien/strings/strings.factor @@ -0,0 +1,111 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays sequences kernel accessors math alien.accessors +alien.c-types byte-arrays words io io.encodings +io.streams.byte-array io.streams.memory io.encodings.utf8 +io.encodings.utf16 system alien strings cpu.architecture ; +IN: alien.strings + +GENERIC# alien>string 1 ( alien encoding -- string/f ) + +M: c-ptr alien>string + >r r> + "\0" swap stream-read-until drop ; + +M: f alien>string + drop ; + +ERROR: invalid-c-string string ; + +: check-string ( string -- ) + 0 over memq? [ invalid-c-string ] [ drop ] if ; + +GENERIC# string>alien 1 ( string encoding -- byte-array ) + +M: c-ptr string>alien drop ; + +M: string string>alien + over check-string + + [ stream-write ] + [ 0 swap stream-write1 ] + [ stream>> >byte-array ] + tri ; + +: malloc-string ( string encoding -- alien ) + string>alien malloc-byte-array ; + +PREDICATE: string-type < pair + first2 [ "char*" = ] [ word? ] bi* and ; + +M: string-type c-type ; + +M: string-type heap-size + drop "void*" heap-size ; + +M: string-type c-type-align + drop "void*" c-type-align ; + +M: string-type c-type-stack-align? + drop "void*" c-type-stack-align? ; + +M: string-type unbox-parameter + drop "void*" unbox-parameter ; + +M: string-type unbox-return + drop "void*" unbox-return ; + +M: string-type box-parameter + drop "void*" box-parameter ; + +M: string-type box-return + drop "void*" box-return ; + +M: string-type stack-size + drop "void*" stack-size ; + +M: string-type c-type-reg-class + drop int-regs ; + +M: string-type c-type-boxer + drop "void*" c-type-boxer ; + +M: string-type c-type-unboxer + drop "void*" c-type-unboxer ; + +M: string-type c-type-boxer-quot + second [ alien>string ] curry [ ] like ; + +M: string-type c-type-unboxer-quot + second [ string>alien ] curry [ ] like ; + +M: string-type c-type-getter + drop [ alien-cell ] ; + +M: string-type c-type-setter + drop [ set-alien-cell ] ; + +TUPLE: utf16n ; + +! Native-order UTF-16 + +: utf16n ( -- descriptor ) + little-endian? utf16le utf16be ? ; foldable + +M: utf16n drop utf16n ; + +M: utf16n drop utf16n ; + +: alien>native-string ( alien -- string ) + os windows? [ utf16n ] [ utf8 ] if alien>string ; + +: dll-path ( dll -- string ) + (dll-path) alien>native-string ; + +: string>symbol ( str -- alien ) + [ os wince? [ utf16n ] [ utf8 ] if string>alien ] + over string? [ call ] [ map ] if ; + +{ "char*" utf8 } "char*" typedef +{ "char*" utf16n } "wchar_t*" typedef +"char*" "uchar*" typedef diff --git a/core/alien/structs/structs-tests.factor b/core/alien/structs/structs-tests.factor index a33a86d4b5..bfdcd31b99 100644 --- a/core/alien/structs/structs-tests.factor +++ b/core/alien/structs/structs-tests.factor @@ -1,6 +1,6 @@ IN: alien.structs.tests USING: alien alien.syntax alien.c-types kernel tools.test -sequences system libc words vocabs namespaces ; +sequences system libc words vocabs namespaces layouts ; C-STRUCT: bar { "int" "x" } @@ -9,20 +9,20 @@ C-STRUCT: bar [ 36 ] [ "bar" heap-size ] unit-test [ t ] [ \ "bar" c-type c-type-getter memq? ] unit-test -! This was actually only correct on Windows/x86: +C-STRUCT: align-test + { "int" "x" } + { "double" "y" } ; -! C-STRUCT: align-test -! { "int" "x" } -! { "double" "y" } ; -! -! [ 16 ] [ "align-test" heap-size ] unit-test -! -! cell 4 = [ -! C-STRUCT: one -! { "long" "a" } { "double" "b" } { "int" "c" } ; -! -! [ 24 ] [ "one" heap-size ] unit-test -! ] when +os winnt? cpu x86? and [ + [ 16 ] [ "align-test" heap-size ] unit-test + + cell 4 = [ + C-STRUCT: one + { "long" "a" } { "double" "b" } { "int" "c" } ; + + [ 24 ] [ "one" heap-size ] unit-test + ] when +] when : MAX_FOOS 30 ; diff --git a/core/alien/structs/structs.factor b/core/alien/structs/structs.factor index 6d98d31790..bc5fa5a3f1 100755 --- a/core/alien/structs/structs.factor +++ b/core/alien/structs/structs.factor @@ -20,14 +20,19 @@ IN: alien.structs : define-getter ( type spec -- ) [ set-reader-props ] keep - dup slot-spec-reader - over slot-spec-type c-getter + [ ] + [ slot-spec-reader ] + [ + slot-spec-type + [ c-getter ] [ c-type c-type-boxer-quot ] bi append + ] tri define-struct-slot-word ; : define-setter ( type spec -- ) [ set-writer-props ] keep - dup slot-spec-writer - over slot-spec-type c-setter + [ ] + [ slot-spec-writer ] + [ slot-spec-type c-setter ] tri define-struct-slot-word ; : define-field ( type spec -- ) diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 67ea30f379..f0f495cac9 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays alien alien.c-types alien.structs alien.arrays -kernel math namespaces parser sequences words quotations -math.parser splitting effects prettyprint prettyprint.sections -prettyprint.backend assocs combinators ; +alien.strings kernel math namespaces parser sequences words +quotations math.parser splitting effects prettyprint +prettyprint.sections prettyprint.backend assocs combinators ; IN: alien.syntax char-string" "alien" } - { "string>char-alien" "alien" } - { "alien>u16-string" "alien" } - { "string>u16-alien" "alien" } { "(throw)" "kernel.private" } { "alien-address" "alien" } { "slot" "slots.private" } diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index ce6fd9367c..2932187152 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -3,7 +3,8 @@ math.constants parser sequences tools.test words assocs namespaces quotations sequences.private classes continuations generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra -calendar prettyprint io.streams.string splitting inspector ; +calendar prettyprint io.streams.string splitting inspector +columns ; IN: classes.tuple.tests TUPLE: rect x y w h ; diff --git a/core/compiler/tests/intrinsics.factor b/core/compiler/tests/intrinsics.factor index fadc57dc8d..7d473871fe 100755 --- a/core/compiler/tests/intrinsics.factor +++ b/core/compiler/tests/intrinsics.factor @@ -4,8 +4,8 @@ math.constants math.private sequences strings tools.test words continuations sequences.private hashtables.private byte-arrays strings.private system random layouts vectors.private sbufs.private strings.private slots.private alien -alien.accessors alien.c-types alien.syntax namespaces libc -sequences.private ; +alien.accessors alien.c-types alien.syntax alien.strings +namespaces libc sequences.private io.encodings.ascii ; ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test @@ -361,11 +361,11 @@ cell 8 = [ [ ] [ "b" get free ] unit-test ] when -[ ] [ "hello world" malloc-char-string "s" set ] unit-test +[ ] [ "hello world" ascii malloc-string "s" set ] unit-test "s" get [ - [ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test - [ "hello world" ] [ "s" get [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test + [ "hello world" ] [ "s" get [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test + [ "hello world" ] [ "s" get [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test [ ] [ "s" get free ] unit-test ] when diff --git a/core/compiler/tests/templates-early.factor b/core/compiler/tests/templates-early.factor index 004d088343..5a08ed0b5b 100755 --- a/core/compiler/tests/templates-early.factor +++ b/core/compiler/tests/templates-early.factor @@ -2,7 +2,8 @@ IN: compiler.tests USING: compiler generator generator.registers generator.registers.private tools.test namespaces sequences -words kernel math effects definitions compiler.units accessors ; +words kernel math effects definitions compiler.units accessors +cpu.architecture ; : ( n -- vreg ) int-regs ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 4e939bddb8..338c5341bc 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -1,10 +1,17 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic kernel kernel.private math memory namespaces sequences layouts system hashtables classes alien byte-arrays bit-arrays float-arrays combinators words sets ; IN: cpu.architecture +! Register classes +SINGLETON: int-regs +SINGLETON: single-float-regs +SINGLETON: double-float-regs +UNION: float-regs single-float-regs double-float-regs ; +UNION: reg-class int-regs float-regs ; + ! A pseudo-register class for parameters spilled on the stack SINGLETON: stack-params diff --git a/core/generator/fixup/fixup-docs.factor b/core/generator/fixup/fixup-docs.factor index 7f4b5026da..f5d530dccb 100644 --- a/core/generator/fixup/fixup-docs.factor +++ b/core/generator/fixup/fixup-docs.factor @@ -13,12 +13,6 @@ HELP: add-literal { $values { "obj" object } { "n" integer } } { $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ; -HELP: string>symbol -{ $values { "str" string } { "alien" alien } } -{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory." -$nl -"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ; - HELP: rel-dlsym { $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } } { $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats." diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 920690e9d8..ad6cd3051c 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs hashtables kernel kernel.private math namespaces sequences words -quotations strings alien layouts system combinators +quotations strings alien.strings layouts system combinators math.bitfields words.private cpu.architecture ; IN: generator.fixup @@ -110,10 +110,6 @@ SYMBOL: literal-table : add-literal ( obj -- n ) literal-table get push-new* ; -: string>symbol ( str -- alien ) - [ os wince? [ string>u16-alien ] [ string>char-alien ] if ] - over string? [ call ] [ map ] if ; - : add-dlsym-literals ( symbol dll -- ) >r string>symbol r> 2array literal-table get push-all ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 390dc28d8e..b8de9c3517 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -73,6 +73,7 @@ GENERIC: generate-node ( node -- next ) : word-dataflow ( word -- effect dataflow ) [ dup "no-effect" word-prop [ no-effect ] when + dup "no-compile" word-prop [ no-effect ] when dup specialized-def over dup 2array 1array infer-quot finish-word ] with-infer ; diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index a3198784ee..6a1d9ec0f4 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -13,13 +13,6 @@ SYMBOL: +scratch+ SYMBOL: +clobber+ SYMBOL: known-tag -! Register classes -SINGLETON: int-regs -SINGLETON: single-float-regs -SINGLETON: double-float-regs -UNION: float-regs single-float-regs double-float-regs ; -UNION: reg-class int-regs float-regs ; - set-primitive-effect -\ alien>char-string { c-ptr } { string } set-primitive-effect -\ alien>char-string make-flushable - -\ string>char-alien { string } { byte-array } set-primitive-effect -\ string>char-alien make-flushable - -\ alien>u16-string { c-ptr } { string } set-primitive-effect -\ alien>u16-string make-flushable - -\ string>u16-alien { string } { byte-array } set-primitive-effect -\ string>u16-alien make-flushable - \ alien-address { alien } { integer } set-primitive-effect \ alien-address make-flushable diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index bdd9e56d87..8a176ce4ec 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -41,12 +41,13 @@ $low-level-note ; ARTICLE: "encodings-descriptors" "Encoding descriptors" "An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" -{ $vocab-subsection "ASCII" "io.encodings.ascii" } -{ $vocab-subsection "Binary" "io.encodings.binary" } +{ $subsection "io.encodings.binary" } +{ $subsection "io.encodings.utf8" } +{ $subsection "io.encodings.utf16" } { $vocab-subsection "Strict encodings" "io.encodings.strict" } +"Legacy encodings:" { $vocab-subsection "8-bit encodings" "io.encodings.8-bit" } -{ $vocab-subsection "UTF-8" "io.encodings.utf8" } -{ $vocab-subsection "UTF-16" "io.encodings.utf16" } +{ $vocab-subsection "ASCII" "io.encodings.ascii" } { $see-also "encodings-introduction" } ; ARTICLE: "encodings-protocol" "Encoding protocol" diff --git a/extra/io/encodings/utf16/.utf16.factor.swo b/core/io/encodings/utf16/.utf16.factor.swo similarity index 100% rename from extra/io/encodings/utf16/.utf16.factor.swo rename to core/io/encodings/utf16/.utf16.factor.swo diff --git a/extra/io/encodings/utf16/authors.txt b/core/io/encodings/utf16/authors.txt similarity index 100% rename from extra/io/encodings/utf16/authors.txt rename to core/io/encodings/utf16/authors.txt diff --git a/extra/io/encodings/utf16/summary.txt b/core/io/encodings/utf16/summary.txt similarity index 100% rename from extra/io/encodings/utf16/summary.txt rename to core/io/encodings/utf16/summary.txt diff --git a/extra/io/encodings/utf16/tags.txt b/core/io/encodings/utf16/tags.txt similarity index 100% rename from extra/io/encodings/utf16/tags.txt rename to core/io/encodings/utf16/tags.txt diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor similarity index 77% rename from extra/io/encodings/utf16/utf16-docs.factor rename to core/io/encodings/utf16/utf16-docs.factor index 1666219db5..f37a9d1d58 100644 --- a/extra/io/encodings/utf16/utf16-docs.factor +++ b/core/io/encodings/utf16/utf16-docs.factor @@ -5,8 +5,7 @@ ARTICLE: "io.encodings.utf16" "UTF-16" "The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:" { $subsection utf16 } { $subsection utf16le } -{ $subsection utf16be } -{ $subsection utf16n } ; +{ $subsection utf16be } ; ABOUT: "io.encodings.utf16" @@ -22,8 +21,4 @@ HELP: utf16 { $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." } { $see-also "encodings-introduction" } ; -HELP: utf16n -{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" } -{ $see-also "encodings-introduction" } ; - -{ utf16 utf16le utf16be utf16n } related-words +{ utf16 utf16le utf16be } related-words diff --git a/extra/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor similarity index 95% rename from extra/io/encodings/utf16/utf16-tests.factor rename to core/io/encodings/utf16/utf16-tests.factor index 6985983917..0d171ee9aa 100755 --- a/extra/io/encodings/utf16/utf16-tests.factor +++ b/core/io/encodings/utf16/utf16-tests.factor @@ -1,6 +1,6 @@ USING: kernel tools.test io.encodings.utf16 arrays sbufs io.streams.byte-array sequences io.encodings io unicode -io.encodings.string alien.c-types accessors classes ; +io.encodings.string alien.c-types alien.strings accessors classes ; IN: io.encodings.utf16.tests [ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test diff --git a/extra/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor similarity index 92% rename from extra/io/encodings/utf16/utf16.factor rename to core/io/encodings/utf16/utf16.factor index fbc296e57c..9093132e5f 100755 --- a/extra/io/encodings/utf16/utf16.factor +++ b/core/io/encodings/utf16/utf16.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2006, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors namespaces io.binary -io.encodings combinators splitting io byte-arrays inspector -alien.c-types ; +io.encodings combinators splitting io byte-arrays inspector ; IN: io.encodings.utf16 TUPLE: utf16be ; @@ -11,8 +10,6 @@ TUPLE: utf16le ; TUPLE: utf16 ; -TUPLE: utf16n ; - ( stream utf16 -- decoder ) M: utf16 ( stream utf16 -- encoder ) drop bom-le over stream-write utf16le ; -! Native-order UTF-16 - -: native-utf16 ( -- descriptor ) - little-endian? utf16le utf16be ? ; - -M: utf16n drop native-utf16 ; - -M: utf16n drop native-utf16 ; - PRIVATE> diff --git a/core/io/streams/memory/memory.factor b/core/io/streams/memory/memory.factor new file mode 100644 index 0000000000..daadbb0e81 --- /dev/null +++ b/core/io/streams/memory/memory.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors alien.accessors math io ; +IN: io.streams.memory + +TUPLE: memory-stream alien index ; + +: ( alien -- stream ) + 0 memory-stream boa ; + +M: memory-stream stream-read1 + [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ] + [ [ 1+ ] change-index drop ] bi ; diff --git a/core/prettyprint/config/config.factor b/core/prettyprint/config/config.factor index 1474f51c53..6a649bc5a6 100644 --- a/core/prettyprint/config/config.factor +++ b/core/prettyprint/config/config.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: prettyprint.config -USING: alien arrays generic assocs io kernel math +USING: arrays generic assocs io kernel math namespaces sequences strings io.styles vectors words continuations ; diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 525749cfae..981c8dcfd0 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: prettyprint -USING: alien arrays generic generic.standard assocs io kernel +USING: arrays generic generic.standard assocs io kernel math namespaces sequences strings io.styles io.streams.string vectors words prettyprint.backend prettyprint.sections prettyprint.config sorting splitting math.parser vocabs diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index 319e5eab65..803f6e2459 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays generic hashtables io kernel math assocs +USING: arrays generic hashtables io kernel math assocs namespaces sequences strings io.styles vectors words prettyprint.config splitting classes continuations io.streams.nested accessors ; diff --git a/extra/benchmark/binary-trees/binary-trees.factor b/extra/benchmark/binary-trees/binary-trees.factor new file mode 100644 index 0000000000..be4620bff6 --- /dev/null +++ b/extra/benchmark/binary-trees/binary-trees.factor @@ -0,0 +1,55 @@ +USING: kernel math accessors prettyprint io locals sequences +math.ranges ; +IN: benchmark.binary-trees + +TUPLE: tree-node item left right ; + +C: tree-node + +: bottom-up-tree ( item depth -- tree ) + dup 0 > [ + 1 - + [ drop ] + [ >r 2 * 1 - r> bottom-up-tree ] + [ >r 2 * r> bottom-up-tree ] 2tri + ] [ + drop f f + ] if ; + +GENERIC: item-check ( node -- n ) + +M: tree-node item-check + [ item>> ] [ left>> ] [ right>> ] tri [ item-check ] bi@ - + ; + +M: f item-check drop 0 ; + +: min-depth 4 ; inline + +: stretch-tree ( max-depth -- ) + 1 + 0 over bottom-up-tree item-check + [ "stretch tree of depth " write pprint ] + [ "\t check: " write . ] bi* ; + +:: long-lived-tree ( max-depth -- ) + 0 max-depth bottom-up-tree + + min-depth max-depth 2 [| depth | + max-depth depth - min-depth + 2^ [ + [1,b] 0 [ + dup neg + [ depth bottom-up-tree item-check + ] bi@ + ] reduce + ] + [ 2 * ] bi + pprint "\t trees of depth " write depth pprint + "\t check: " write . + ] each + + "long lived tree of depth " write max-depth pprint + "\t check: " write item-check . ; + +: binary-trees ( n -- ) + min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ; + +: binary-trees-main ( -- ) + 16 binary-trees ; diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 2c7dc1e80d..5d36aa25bd 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -1,48 +1,44 @@ ! Factor port of ! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all USING: float-arrays kernel math math.functions math.vectors -sequences sequences.private prettyprint words tools.time hints ; +sequences sequences.private prettyprint words +hints locals ; IN: benchmark.spectral-norm -: fast-truncate >fixnum >float ; inline +:: inner-loop ( u n quot -- seq ) + n [| i | + n 0.0 [| j | + u i j quot call + + ] reduce + ] F{ } map-as ; inline : eval-A ( i j -- n ) [ >float ] bi@ - dupd + dup 1+ * 2 /f fast-truncate + 1+ - recip ; inline + [ drop ] [ + [ ] [ 1 + ] bi * 0.5 * ] 2bi + + 1 + recip ; inline : (eval-A-times-u) ( u i j -- x ) - tuck eval-A >r swap nth-unsafe r> * ; inline + tuck [ swap nth-unsafe ] [ eval-A ] 2bi* * ; inline : eval-A-times-u ( n u -- seq ) - over [ - pick 0.0 [ - swap >r >r 2dup r> (eval-A-times-u) r> + - ] reduce nip - ] F{ } map-as { float-array } declare 2nip ; inline + [ (eval-A-times-u) ] inner-loop ; inline : (eval-At-times-u) ( u i j -- x ) - tuck swap eval-A >r swap nth-unsafe r> * ; inline + tuck [ swap nth-unsafe ] [ swap eval-A ] 2bi* * ; inline -: eval-At-times-u ( n u -- seq ) - over [ - pick 0.0 [ - swap >r >r 2dup r> (eval-At-times-u) r> + - ] reduce nip - ] F{ } map-as { float-array } declare 2nip ; inline +: eval-At-times-u ( u n -- seq ) + [ (eval-At-times-u) ] inner-loop ; inline -: eval-AtA-times-u ( n u -- seq ) - dupd eval-A-times-u eval-At-times-u ; inline +: eval-AtA-times-u ( u n -- seq ) + [ eval-A-times-u ] [ eval-At-times-u ] bi ; inline -: u/v ( n -- u v ) - dup 1.0 dup +:: u/v ( n -- u v ) + n 1.0 dup 10 [ drop - dupd eval-AtA-times-u - 2dup eval-AtA-times-u - swap - ] times - rot drop ; inline + n eval-AtA-times-u + [ n eval-AtA-times-u ] keep + ] times ; inline : spectral-norm ( n -- norm ) u/v [ v. ] keep norm-sq /f sqrt ; @@ -50,6 +46,6 @@ IN: benchmark.spectral-norm HINTS: spectral-norm fixnum ; : spectral-norm-main ( -- ) - 2000 spectral-norm . ; + 5500 spectral-norm . ; MAIN: spectral-norm-main diff --git a/extra/bit-vectors/bit-vectors.factor b/extra/bit-vectors/bit-vectors.factor index b011f146c5..c14b0a5476 100755 --- a/extra/bit-vectors/bit-vectors.factor +++ b/extra/bit-vectors/bit-vectors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences sequences.private growable bit-arrays prettyprint.backend -parser ; +parser accessors ; IN: bit-vectors TUPLE: bit-vector underlying fill ; @@ -44,7 +44,7 @@ M: bit-array new-resizable drop ; INSTANCE: bit-vector growable -: ?V \ } [ >bit-vector ] parse-literal ; parsing +: ?V{ \ } [ >bit-vector ] parse-literal ; parsing M: bit-vector >pprint-sequence ; diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index ca9509c3ec..df3f84d451 100755 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.compiler +USING: alien alien.c-types alien.strings alien.compiler arrays assocs combinators compiler inference.transforms kernel math namespaces parser prettyprint prettyprint.sections quotations sequences strings words cocoa.runtime io macros -memoize debugger ; +memoize debugger io.encodings.ascii ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -104,7 +104,7 @@ MACRO: (send) ( selector super? -- quot ) : method-arg-type ( method i -- type ) f 0 over >r method_getArgumentInfo drop - r> *char* ; + r> *void* ascii alien>string ; SYMBOL: objc>alien-types diff --git a/extra/cocoa/subclassing/subclassing.factor b/extra/cocoa/subclassing/subclassing.factor index 48f45f21c0..6b3e1d330e 100755 --- a/extra/cocoa/subclassing/subclassing.factor +++ b/extra/cocoa/subclassing/subclassing.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays assocs combinators compiler -hashtables kernel libc math namespaces parser sequences words -cocoa.messages cocoa.runtime compiler.units ; +USING: alien alien.c-types alien.strings arrays assocs +combinators compiler hashtables kernel libc math namespaces +parser sequences words cocoa.messages cocoa.runtime +compiler.units io.encodings.ascii ; IN: cocoa.subclassing : init-method ( method alien -- ) >r first3 r> [ >r execute r> set-objc-method-imp ] keep - [ >r malloc-char-string r> set-objc-method-types ] keep + [ >r ascii malloc-string r> set-objc-method-types ] keep >r sel_registerName r> set-objc-method-name ; : ( n -- alien ) @@ -26,7 +27,7 @@ IN: cocoa.subclassing : ( name info -- class ) "objc-class" malloc-object [ set-objc-class-info ] keep - [ >r malloc-char-string r> set-objc-class-name ] keep ; + [ >r ascii malloc-string r> set-objc-class-name ] keep ; : ( name -- protocol-list ) "objc-protocol-list" malloc-object diff --git a/extra/core-foundation/core-foundation.factor b/extra/core-foundation/core-foundation.factor index 77ad30ad8f..a4bd24ccca 100644 --- a/extra/core-foundation/core-foundation.factor +++ b/extra/core-foundation/core-foundation.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax kernel math sequences ; +USING: alien alien.c-types alien.strings alien.syntax kernel +math sequences io.encodings.utf16 ; IN: core-foundation TYPEDEF: void* CFAllocatorRef @@ -31,7 +32,7 @@ FUNCTION: CFURLRef CFURLCreateWithString ( CFAllocatorRef allocator, CFStringRef FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ; -FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, ushort* cStr, CFIndex numChars ) ; +FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, wchar_t* cStr, CFIndex numChars ) ; FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ; @@ -57,7 +58,7 @@ FUNCTION: void CFRelease ( void* cf ) ; : CF>string ( alien -- string ) dup CFStringGetLength 1+ "ushort" [ >r 0 over CFStringGetLength r> CFStringGetCharacters - ] keep alien>u16-string ; + ] keep utf16n alien>string ; : CF>string-array ( alien -- seq ) CF>array [ CF>string ] map ; diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 3c9dbdbef0..67a4e59d04 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax kernel math sequences -namespaces assocs init accessors continuations combinators -core-foundation core-foundation.run-loop ; +USING: alien alien.c-types alien.strings alien.syntax kernel +math sequences namespaces assocs init accessors continuations +combinators core-foundation core-foundation.run-loop +io.encodings.utf8 ; IN: core-foundation.fsevents ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! @@ -165,7 +166,7 @@ SYMBOL: event-stream-callbacks : >event-triple ( n eventPaths eventFlags eventIds -- triple ) [ >r >r >r dup dup - r> char*-nth , + r> void*-nth utf8 alien>string , r> int-nth , r> longlong-nth , ] { } make ; diff --git a/extra/float-vectors/float-vectors.factor b/extra/float-vectors/float-vectors.factor index f0db37610a..d51f0d4e44 100755 --- a/extra/float-vectors/float-vectors.factor +++ b/extra/float-vectors/float-vectors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel kernel.private math sequences sequences.private growable float-arrays prettyprint.backend -parser ; +parser accessors ; IN: float-vectors TUPLE: float-vector underlying fill ; diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor index 91838d2a53..fe1fd72a21 100644 --- a/extra/hardware-info/macosx/macosx.factor +++ b/extra/hardware-info/macosx/macosx.factor @@ -1,6 +1,7 @@ -USING: alien alien.c-types alien.syntax byte-arrays kernel -namespaces sequences unix hardware-info.backend system -io.unix.backend ; +USING: alien alien.c-types alien.strings alien.syntax +byte-arrays kernel namespaces sequences unix +hardware-info.backend system io.unix.backend io.encodings.ascii +; IN: hardware-info.macosx ! See /usr/include/sys/sysctl.h for constants @@ -19,7 +20,7 @@ FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, voi [ ] [ ] bi (sysctl-query) ; : sysctl-query-string ( seq -- n ) - 4096 sysctl-query alien>char-string ; + 4096 sysctl-query ascii malloc-string ; : sysctl-query-uint ( seq -- n ) 4 sysctl-query *uint ; diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index ba9c1d74b5..2599a33754 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,4 +1,4 @@ -USING: alien alien.c-types +USING: alien alien.c-types alien.strings kernel libc math namespaces hardware-info.backend windows windows.advapi32 windows.kernel32 system ; IN: hardware-info.windows.nt @@ -35,12 +35,14 @@ M: winnt total-virtual-mem ( -- n ) M: winnt available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; +: pull-win32-string [ utf16n alien>string ] keep free ; + : computer-name ( -- string ) MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep dupd GetComputerName zero? [ free win32-error f ] [ - [ alien>u16-string ] keep free + pull-win32-string ] if ; : username ( -- string ) @@ -48,5 +50,5 @@ M: winnt available-virtual-mem ( -- n ) dupd GetUserName zero? [ free win32-error f ] [ - [ alien>u16-string ] keep free + pull-win32-string ] if ; diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 807fd158ba..10474c09f7 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -36,7 +36,7 @@ IN: hardware-info.windows os-version OSVERSIONINFO-dwPlatformId ; : windows-service-pack ( -- string ) - os-version OSVERSIONINFO-szCSDVersion alien>u16-string ; + os-version OSVERSIONINFO-szCSDVersion utf16n alien>string ; : feature-present? ( n -- ? ) IsProcessorFeaturePresent zero? not ; @@ -52,7 +52,7 @@ IN: hardware-info.windows : get-directory ( word -- str ) >r MAX_UNICODE_PATH [ ] keep dupd r> - execute win32-error=0/f alien>u16-string ; inline + execute win32-error=0/f utf16n alien>string ; inline : windows-directory ( -- str ) \ GetWindowsDirectory get-directory ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index d5bc1875e4..15e3b8be1d 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -163,7 +163,7 @@ ARTICLE: "collections" "Collections" { $subsection "buffers" } ; USING: io.sockets io.launcher io.mmap io.monitors -io.encodings.utf8 io.encodings.binary io.encodings.ascii io.files ; +io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ; ARTICLE: "encodings-introduction" "An introduction to encodings" "In order to express text in terms of binary, some sort of encoding has to be used. In a modern context, this is understood as a two-way mapping between Unicode code points (characters) and some amount of binary. Since English isn't the only language in the world, ASCII is not sufficient as a mapping from binary to Unicode; it can't even express em-dashes or curly quotes. Unicode was designed as a universal character set that could potentially represent everything." $nl diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor index 4e847cff70..6c62452ec2 100644 --- a/extra/http/server/boilerplate/boilerplate.factor +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -1,7 +1,8 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces boxes sequences strings -io io.streams.string +io io.streams.string arrays +html.elements http http.server http.server.templating ; @@ -28,6 +29,18 @@ SYMBOL: style : write-style ( -- ) style get >string write ; +SYMBOL: atom-feed + +: set-atom-feed ( title url -- ) + 2array atom-feed get >box ; + +: write-atom-feed ( -- ) + atom-feed get value>> [ + + ] when* ; + SYMBOL: nested-template? SYMBOL: next-template @@ -40,6 +53,7 @@ M: f call-template drop call-next-template ; : with-boilerplate ( body template -- ) [ title get [ title set ] unless + atom-feed get [ atom-feed set ] unless style get [ SBUF" " clone style set ] unless [ @@ -54,5 +68,8 @@ M: f call-template drop call-next-template ; ] with-scope ; inline M: boilerplate call-responder - [ responder>> call-responder clone ] [ template>> ] bi - [ [ with-boilerplate ] 2curry ] curry change-body ; + tuck responder>> call-responder + dup "content-type" header "text/html" = [ + clone swap template>> + [ [ with-boilerplate ] 2curry ] curry change-body + ] [ nip ] if ; diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index 6d3a048ac4..ff87bb71fb 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -129,3 +129,5 @@ TUPLE: test-tuple text number more-text ; [ t ] [ "wake up sheeple" dup "n" validate = ] unit-test [ ] [ "password" "p" set ] unit-test + +[ ] [ "pub-date" "d" set ] unit-test diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 50353c6b87..bdcdd95c71 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: html.elements http.server.validators accessors namespaces -kernel io math.parser assocs classes words classes.tuple arrays -sequences splitting mirrors hashtables fry combinators -continuations math ; +USING: accessors namespaces kernel io math.parser assocs classes +words classes.tuple arrays sequences splitting mirrors +hashtables fry combinators continuations math +calendar.format html.elements +http.server.validators ; IN: http.server.components ! Renderer protocol @@ -59,9 +60,14 @@ SYMBOL: values : values-tuple values get mirror-object ; +: render-view-or-summary ( component -- value renderer ) + [ id>> value ] [ component-string ] [ renderer>> ] tri ; + : render-view ( component -- ) - [ id>> value ] [ component-string ] [ renderer>> ] tri - render-view* ; + render-view-or-summary render-view* ; + +: render-summary ( component -- ) + render-view-or-summary render-summary* ; ( id -- component ) + url new-string + 5 >>min-length + 60 >>max-length ; + +M: url validate* + call-next-method dup empty? [ v-url ] unless ; + ! Don't send passwords back to the user TUPLE: password-renderer < field ; @@ -206,20 +223,20 @@ M: captcha validate* drop v-captcha ; ! Text areas -TUPLE: textarea-renderer rows cols ; +TUPLE: text-renderer rows cols ; -: new-textarea-renderer ( class -- renderer ) +: new-text-renderer ( class -- renderer ) new 60 >>cols 20 >>rows ; -: ( -- renderer ) - textarea-renderer new-textarea-renderer ; +: ( -- renderer ) + text-renderer new-text-renderer ; -M: textarea-renderer render-view* +M: text-renderer render-view* drop write ; -M: textarea-renderer render-edit* +M: text-renderer render-edit*