: <alien> ( address -- alien )
f <displaced-alien> { simple-c-ptr } declare ; inline
-: alien>native-string ( alien -- string )
- os windows? [ alien>u16-string ] [ alien>char-string ] if ;
-
-: dll-path ( dll -- string )
- (dll-path) alien>native-string ;
-
M: alien equal?
over alien? [
2dup [ expired? ] either? [
{ $subsection >c-ushort-array }\r
{ $subsection >c-void*-array }\r
{ $subsection c-bool-array> }\r
-{ $subsection c-char*-array> }\r
{ $subsection c-char-array> }\r
{ $subsection c-double-array> }\r
{ $subsection c-float-array> }\r
{ $subsection c-uint-array> }\r
{ $subsection c-ulong-array> }\r
{ $subsection c-ulonglong-array> }\r
-{ $subsection c-ushort*-array> }\r
{ $subsection c-ushort-array> }\r
{ $subsection c-void*-array> } ;\r
\r
{ $subsection double-nth }\r
{ $subsection set-double-nth }\r
{ $subsection void*-nth }\r
-{ $subsection set-void*-nth }\r
-{ $subsection char*-nth }\r
-{ $subsection ushort*-nth } ;\r
+{ $subsection set-void*-nth } ;\r
\r
ARTICLE: "c-arrays" "C arrays"\r
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."\r
-! 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 ;
M: value-type c-type-reg-class drop int-regs ;
-M: value-type c-type-prep drop f ;
+M: value-type c-type-boxer-quot drop f ;
+
+M: value-type c-type-unboxer-quot drop f ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
{ <c-object> malloc-object } related-words
-HELP: string>char-alien ( string -- array )
-{ $values { "string" string } { "array" byte-array } }
-{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
-{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." } ;
-
-{ string>char-alien alien>char-string malloc-char-string } related-words
-
-HELP: alien>char-string ( c-ptr -- string )
-{ $values { "c-ptr" c-ptr } { "string" string } }
-{ $description "Reads a null-terminated 8-bit C string from the specified address." } ;
-
-HELP: string>u16-alien ( string -- array )
-{ $values { "string" string } { "array" byte-array } }
-{ $description "Copies the string to a new byte array in UCS-2 format with a trailing null byte." }
-{ $errors "Throws an error if the string contains null characters." } ;
-
-{ string>u16-alien alien>u16-string malloc-u16-string } related-words
-
-HELP: alien>u16-string ( c-ptr -- string )
-{ $values { "c-ptr" c-ptr } { "string" string } }
-{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
-
HELP: memory>byte-array
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
{ $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." }
{ $subsection *float }
{ $subsection *double }
{ $subsection *void* }
-{ $subsection *char* }
-{ $subsection *ushort* }
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
ARTICLE: "c-types-specs" "C type specifiers"
"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
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* ;
TYPEDEF: uchar* MyLPBYTE
-[ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test
+[ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
! 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
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type
-boxer prep unboxer
+boxer boxer-quot unboxer unboxer-quot
getter setter
reg-class size align stack-align? ;
: malloc-byte-array ( byte-array -- alien )
dup length dup malloc [ -rot memcpy ] keep ;
-: malloc-char-string ( string -- alien )
- string>char-alien malloc-byte-array ;
-
-: malloc-u16-string ( string -- alien )
- string>u16-alien malloc-byte-array ;
-
: memory>byte-array ( alien len -- byte-array )
dup <byte-array> [ -rot memcpy ] keep ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;
-DEFER: >c-ushort-array
-
-: string>u16-memory ( string base -- )
- >r >c-ushort-array r> byte-array>memory ;
-
: (define-nth) ( word type quot -- )
>r heap-size [ rot * ] swap prefix r> append define-inline ;
"box_float" >>boxer
"to_float" >>unboxer
single-float-regs >>reg-class
- [ >float ] >>prep
+ [ >float ] >>unboxer-quot
"float" define-primitive-type
<c-type>
"box_double" >>boxer
"to_double" >>unboxer
double-float-regs >>reg-class
- [ >float ] >>prep
+ [ >float ] >>unboxer-quot
"double" define-primitive-type
- <c-type>
- [ alien-cell alien>char-string ] >>getter
- [ set-alien-cell ] >>setter
- bootstrap-cell >>size
- bootstrap-cell >>align
- "box_char_string" >>boxer
- "alien_offset" >>unboxer
- [ string>char-alien ] >>prep
- "char*" define-primitive-type
-
- "char*" "uchar*" typedef
-
- <c-type>
- [ alien-cell alien>u16-string ] >>getter
- [ set-alien-cell ] >>setter
- 4 >>size
- 4 >>align
- "box_u16_string" >>boxer
- "alien_offset" >>unboxer
- [ string>u16-alien ] >>prep
- "ushort*" define-primitive-type
-
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
] with-compilation-unit
+ + 1+\r
] alien-callback ;\r
\r
+FUNCTION: void ffi_test_36_point_5 ( ) ;\r
+\r
+[ ] [ ffi_test_36_point_5 ] unit-test\r
+\r
FUNCTION: int ffi_test_37 ( void* func ) ;\r
\r
[ 1 ] [ callback-9 ffi_test_37 ] unit-test\r
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 ;
: 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>>
dup return>> "void" = 0 1 ?
swap produce-values ;
-: (make-prep-quot) ( parameters -- )
+: (param-prep-quot) ( parameters -- )
dup empty? [
drop
] [
- unclip c-type c-type-prep %
- \ >r , (make-prep-quot) \ r> ,
+ unclip c-type c-type-unboxer-quot %
+ \ >r , (param-prep-quot) \ r> ,
] if ;
-: make-prep-quot ( node -- quot )
- parameters>>
- [ <reversed> (make-prep-quot) ] [ ] make ;
+: param-prep-quot ( node -- quot )
+ parameters>> [ <reversed> (param-prep-quot) ] [ ] make ;
: unbox-parameters ( offset node -- )
parameters>> [
: box-return* ( node -- )
return>> [ ] [ box-return ] if-void ;
+: (return-prep-quot) ( parameters -- )
+ dup empty? [
+ drop
+ ] [
+ unclip c-type c-type-boxer-quot %
+ \ >r , (return-prep-quot) \ r> ,
+ ] if ;
+
+: callback-prep-quot ( node -- quot )
+ parameters>> [ <reversed> (return-prep-quot) ] [ ] make ;
+
+: return-prep-quot ( node -- quot )
+ [ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ;
+
M: alien-invoke-error summary
drop
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
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
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
: callback-bottom ( node -- )
xt>> [ word-xt drop <alien> ] curry
- recursive-state get infer-quot ;
+ f infer-quot ;
\ alien-callback [
4 ensure-values
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 ;
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 ;
-! 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 ;
--- /dev/null
+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"
--- /dev/null
+USING: alien.strings tools.test kernel libc
+io.encodings.8-bit 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
+
--- /dev/null
+! 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
+
+: alien>string ( alien encoding -- string )
+ >r <memory-stream> r> <decoder>
+ "\0" swap stream-read-until 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: alien string>alien drop ;
+
+M: byte-array string>alien drop ;
+
+M: string string>alien
+ over check-string
+ <byte-writer>
+ [ stream-write ]
+ [ 0 swap stream-write1 ]
+ [ stream>> >byte-array ]
+ tri ;
+
+: malloc-string ( string encoding -- alien )
+ string>alien malloc-byte-array ;
+
+PREDICATE: string-type < pair
+ first2 [ "char*" = ] [ word? ] bi* and ;
+
+M: string-type c-type ;
+
+M: string-type heap-size
+ drop "void*" heap-size ;
+
+M: string-type c-type-align
+ drop "void*" c-type-align ;
+
+M: string-type c-type-stack-align?
+ drop "void*" c-type-stack-align? ;
+
+M: string-type unbox-parameter
+ drop "void*" unbox-parameter ;
+
+M: string-type unbox-return
+ drop "void*" unbox-return ;
+
+M: string-type box-parameter
+ drop "void*" box-parameter ;
+
+M: string-type box-return
+ drop "void*" box-return ;
+
+M: string-type stack-size
+ drop "void*" stack-size ;
+
+M: string-type c-type-reg-class
+ drop int-regs ;
+
+M: string-type c-type-boxer
+ drop "void*" c-type-boxer ;
+
+M: string-type c-type-unboxer
+ drop "void*" c-type-unboxer ;
+
+M: string-type c-type-boxer-quot
+ second [ alien>string ] curry [ ] like ;
+
+M: string-type c-type-unboxer-quot
+ second [ string>alien ] curry [ ] like ;
+
+M: string-type c-type-getter
+ drop [ alien-cell ] ;
+
+M: string-type c-type-setter
+ drop [ set-alien-cell ] ;
+
+TUPLE: utf16n ;
+
+! Native-order UTF-16
+
+: utf16n ( -- descriptor )
+ little-endian? utf16le utf16be ? ; foldable
+
+M: utf16n <decoder> drop utf16n <decoder> ;
+
+M: utf16n <encoder> drop utf16n <encoder> ;
+
+: alien>native-string ( alien -- string )
+ os windows? [ utf16n ] [ utf8 ] if alien>string ;
+
+: dll-path ( dll -- string )
+ (dll-path) alien>native-string ;
+
+: string>symbol ( str -- alien )
+ [ os wince? [ utf16n ] [ utf8 ] if string>alien ]
+ over string? [ call ] [ map ] if ;
+
+{ "char*" utf8 } "char*" typedef
+{ "char*" utf16n } "wchar_t*" typedef
+"char*" "uchar*" typedef
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" }
[ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
-! This was actually only correct on Windows/x86:
-
-! C-STRUCT: align-test
-! { "int" "x" }
-! { "double" "y" } ;
-!
-! [ 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
+C-STRUCT: align-test
+ { "int" "x" }
+ { "double" "y" } ;
+
+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 ;
: 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 -- )
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays
-kernel math namespaces parser sequences words quotations
-math.parser splitting effects prettyprint prettyprint.sections
-prettyprint.backend assocs combinators ;
+alien.strings kernel math namespaces parser sequences words
+quotations math.parser splitting effects prettyprint
+prettyprint.sections prettyprint.backend assocs combinators ;
IN: alien.syntax
<PRIVATE
{ "set-alien-double" "alien.accessors" }
{ "alien-cell" "alien.accessors" }
{ "set-alien-cell" "alien.accessors" }
- { "alien>char-string" "alien" }
- { "string>char-alien" "alien" }
- { "alien>u16-string" "alien" }
- { "string>u16-alien" "alien" }
{ "(throw)" "kernel.private" }
{ "alien-address" "alien" }
{ "slot" "slots.private" }
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 ;
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 ;
+sequences.private io.encodings.ascii ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test
[ ] [ "hello world" malloc-char-string "s" set ] unit-test
"s" get [
- [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test
- [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test
+ [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
+ [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
[ ] [ "s" get free ] unit-test
] when
-! 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
{ $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."
! 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
: 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 ;
: 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 ;
SYMBOL: +clobber+
SYMBOL: known-tag
-! Register classes
-SINGLETON: int-regs
-SINGLETON: single-float-regs
-SINGLETON: double-float-regs
-UNION: float-regs single-float-regs double-float-regs ;
-UNION: reg-class int-regs float-regs ;
-
<PRIVATE
! Value protocol
generic.standard strings sequences arrays kernel accessors
words float-arrays byte-arrays bit-arrays parser namespaces
quotations inference vectors growable hashtables sbufs
-prettyprint ;
+prettyprint byte-vectors bit-vectors float-vectors ;
GENERIC: lo-tag-test
peek-d infer-call
] "infer" set-word-prop
+\ call t "no-compile" set-word-prop
+
\ execute [
1 ensure-values
pop-literal nip
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
-\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
-\ alien>char-string make-flushable
-
-\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
-\ string>char-alien make-flushable
-
-\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
-\ alien>u16-string make-flushable
-
-\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
-\ string>u16-alien make-flushable
-
\ alien-address { alien } { integer } <effect> set-primitive-effect
\ alien-address make-flushable
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"
"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"
{ $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
! 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 ;
TUPLE: utf16 ;
-TUPLE: utf16n ;
-
<PRIVATE
! UTF-16BE decoding
M: utf16 <encoder> ( stream utf16 -- encoder )
drop bom-le over stream-write utf16le <encoder> ;
-! Native-order UTF-16
-
-: utf16n ( -- descriptor )
- little-endian? utf16le utf16be ? ; foldable
-
-M: utf16n <decoder> drop utf16n <decoder> ;
-
-M: utf16n <encoder> drop utf16n <encoder> ;
-
PRIVATE>
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors alien.accessors math io ;
+IN: io.streams.memory
+
+TUPLE: memory-stream alien index ;
+
+: <memory-stream> ( alien -- stream )
+ 0 memory-stream boa ;
+
+M: memory-stream stream-read1
+ [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
+ [ [ 1+ ] change-index drop ] bi ;
! 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 ;
! 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
! 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 ;
--- /dev/null
+USING: kernel math accessors prettyprint io locals sequences
+math.ranges ;
+IN: benchmark.binary-trees
+
+TUPLE: tree-node item left right ;
+
+C: <tree-node> 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 <tree-node> ;
+
+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 <range> [| depth |
+ max-depth depth - min-depth + 2^ [
+ [1,b] 0 [
+ [ depth ] [ depth neg ] bi
+ [ bottom-up-tree item-check + ] 2bi@
+ ] 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 . ;
-! 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 )
: method-arg-type ( method i -- type )
f <void*> 0 <int> over
>r method_getArgumentInfo drop
- r> *char* ;
+ r> *void* ascii alien>string ;
SYMBOL: objc>alien-types
! 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 ;
: <empty-method-list> ( n -- alien )
: <objc-class> ( 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 ;
: <protocol-list> ( name -- protocol-list )
"objc-protocol-list" malloc-object
! 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
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 ) ;
: CF>string ( alien -- string )
dup CFStringGetLength 1+ "ushort" <c-array> [
>r 0 over CFStringGetLength r> CFStringGetCharacters
- ] keep alien>u16-string ;
+ ] keep utf16n alien>string ;
: CF>string-array ( alien -- seq )
CF>array [ CF>string ] map ;
! 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
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
: >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 ;
-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
[ <byte-array> ] [ <uint> ] 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 ;
-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
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
<int> dupd GetComputerName zero? [
free win32-error f
] [
- [ alien>u16-string ] keep free
+ pull-win32-string
] if ;
: username ( -- string )
<int> dupd GetUserName zero? [
free win32-error f
] [
- [ alien>u16-string ] keep free
+ pull-win32-string
] if ;
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 ;
: get-directory ( word -- str )
>r MAX_UNICODE_PATH [ <u16-string-object> ] 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 ;
{ $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
-! 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: arrays byte-arrays io.backend io.binary io.sockets
-kernel math math.parser sequences splitting system
-alien.c-types combinators namespaces alien parser ;
+io.encodings.ascii kernel math math.parser sequences splitting
+system alien.c-types alien.strings alien combinators namespaces
+parser ;
IN: io.sockets.impl
<< {
M: object host-name ( -- name )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
- alien>char-string ;
+ ascii alien>string ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.backend io.monitors io.monitors.recursive
io.files io.buffers io.monitors io.nonblocking io.timeouts
-io.unix.backend io.unix.select unix.linux.inotify assocs
-namespaces threads continuations init math math.bitfields sets
-alien.c-types alien vocabs.loader accessors system hashtables ;
+io.unix.backend io.unix.select io.encodings.utf8
+unix.linux.inotify assocs namespaces threads continuations init
+math math.bitfields sets alien.strings alien vocabs.loader
+accessors system hashtables ;
IN: io.unix.linux.monitors
TUPLE: linux-monitor < monitor wd ;
dup inotify-event-mask ignore-flags? [
drop f f
] [
- [ inotify-event-name alien>char-string ]
+ [ inotify-event-name utf8 alien>string ]
[ inotify-event-mask parse-action ] bi
] if ;
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings generic kernel math
+namespaces threads sequences byte-arrays io.nonblocking
+io.binary io.unix.backend io.streams.duplex io.sockets.impl
+io.backend io.files io.files.private io.encodings.utf8
+math.parser continuations libc combinators system accessors
+qualified unix ;
+
+EXCLUDE: io => read write close ;
+EXCLUDE: io.sockets => accept ;
-! We need to fiddle with the exact search order here, since
-! unix::accept shadows streams::accept.
-USING: alien alien.c-types generic io kernel math namespaces
-io.nonblocking parser threads unix sequences
-byte-arrays io.sockets io.binary io.unix.backend
-io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators io.backend io.files io.files.private system accessors ;
IN: io.unix.sockets
: pending-init-error ( port -- )
connect-task <io-task> ;
M: connect-task do-io-task
- io-task-port dup port-handle f 0 write
+ port>> dup handle>> f 0 write
0 < [ defer-error ] [ drop t ] if ;
: wait-to-connect ( port -- )
] if ;
! Server sockets - TCP and Unix domain
-USE: unix
-
: init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR sockopt ;
: wait-to-accept ( server -- )
[ <accept-task> add-io-task ] with-port-continuation drop ;
-USE: io.sockets
-
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> socket-fd
dup init-server-socket
M: local sockaddr-type drop "sockaddr-un" c-type ;
M: local make-sockaddr
- local-path cwd prepend-path
+ path>> (normalize-path)
dup length 1 + max-un-path > [ "Path too long" throw ] when
"sockaddr-un" <c-object>
AF_UNIX over set-sockaddr-un-family
- dup sockaddr-un-path rot string>char-alien dup length memcpy ;
+ dup sockaddr-un-path rot utf8 string>alien dup length memcpy ;
M: local parse-sockaddr
drop
- sockaddr-un-path alien>char-string <local> ;
+ sockaddr-un-path utf8 alien>string <local> ;
M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array>
[ GetCurrentDirectory win32-error=0/f ] keep
- alien>u16-string ;
+ utf16n alien>string ;
M: winnt cd
SetCurrentDirectory win32-error=0/f ;
[ infer-r> ]
[ { } <effect> infer-shuffle ] bi
] "infer" set-word-prop
+
+<<
+{ load-locals get-local drop-locals }
+[ t "no-compile" set-word-prop ] each
+>>
-USING: kernel layouts math namespaces sequences sequences.private ;
+USING: kernel layouts math namespaces sequences
+sequences.private accessors ;
IN: math.ranges
TUPLE: range from length step ;
range boa ;
M: range length ( seq -- n )
- range-length ;
+ length>> ;
M: range nth-unsafe ( n range -- obj )
- [ range-step * ] keep range-from + ;
+ [ step>> * ] keep from>> + ;
INSTANCE: range immutable-sequence
: [0,b) ( b -- range ) 0 swap [a,b) ;
: range-increasing? ( range -- ? )
- range-step 0 > ;
+ step>> 0 > ;
: range-decreasing? ( range -- ? )
- range-step 0 < ;
+ step>> 0 < ;
: first-or-peek ( seq head? -- elt )
[ first ] [ peek ] if ;
dup range-decreasing? first-or-peek ;
: clamp-to-range ( n range -- n )
- tuck range-min max swap range-max min ;
+ [ min>> max ] [ max>> min ] bi ;
: sequence-index-range ( seq -- range )
length [0,b) ;
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien alien.syntax combinators alien.c-types
- strings sequences namespaces words math threads ;
+USING: kernel alien alien.strings alien.syntax combinators
+alien.c-types strings sequences namespaces words math threads
+io.encodings.ascii ;
IN: odbc
-"odbc" "odbc32.dll" "stdcall" add-library
+<< "odbc" "odbc32.dll" "stdcall" add-library >>
LIBRARY: odbc
SQL-HANDLE-STMT swap alloc-handle ;
: temp-string ( length -- byte-array length )
- [ CHAR: \space <string> string>char-alien ] keep ;
+ [ CHAR: \space <string> ascii string>alien ] keep ;
: odbc-init ( -- env )
alloc-env-handle
: odbc-describe-column ( statement n -- column )
dup >r
- 1024 CHAR: \space <string> string>char-alien dup >r
+ 1024 CHAR: \space <string> ascii string>alien dup >r
1024
0 <short>
0 <short> dup >r
r> *short
r> *uint
r> *short convert-sql-type
- r> alien>char-string
+ r> ascii alien>string
r> <column>
] [
r> drop r> drop r> drop r> drop r> drop r> drop
: dereference-type-pointer ( byte-array column -- object )
column-type {
- { SQL-CHAR [ alien>char-string ] }
- { SQL-VARCHAR [ alien>char-string ] }
- { SQL-LONGVARCHAR [ alien>char-string ] }
- { SQL-WCHAR [ alien>char-string ] }
- { SQL-WCHARVAR [ alien>char-string ] }
- { SQL-WLONGCHARVAR [ alien>char-string ] }
+ { SQL-CHAR [ ascii alien>string ] }
+ { SQL-VARCHAR [ ascii alien>string ] }
+ { SQL-LONGVARCHAR [ ascii alien>string ] }
+ { SQL-WCHAR [ ascii alien>string ] }
+ { SQL-WCHARVAR [ ascii alien>string ] }
+ { SQL-WLONGCHARVAR [ ascii alien>string ] }
{ SQL-SMALLINT [ *short ] }
{ SQL-INTEGER [ *long ] }
{ SQL-REAL [ *float ] }
: odbc-get-field ( statement column -- field )
dup column? [ dupd odbc-describe-column ] unless dup >r column-number
SQL-C-DEFAULT
- 8192 CHAR: \space <string> string>char-alien dup >r
+ 8192 CHAR: \space <string> ascii string>alien dup >r
8192
f SQLGetData succeeded? [
r> r> [ dereference-type-pointer ] keep <field>
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
-assocs alien libc opengl math sequences combinators
-combinators.lib macros arrays ;
+assocs alien alien.strings libc opengl math sequences combinators
+combinators.lib macros arrays io.encodings.ascii ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
- swap string>char-alien malloc-byte-array [
- <void*> swap call
- ] keep free ; inline
+ swap ascii malloc-string [ <void*> swap call ] keep free ; inline
: <gl-shader> ( source kind -- shader )
glCreateShader dup rot
: gl-shader-info-log ( shader -- log )
dup gl-shader-info-log-length dup [
[ 0 <int> swap glGetShaderInfoLog ] keep
- alien>char-string
+ ascii alien>string
] with-malloc ;
: check-gl-shader ( shader -- shader )
: gl-program-info-log ( program -- log )
dup gl-program-info-log-length dup [
[ 0 <int> swap glGetProgramInfoLog ] keep
- alien>char-string
+ ascii alien>string
] with-malloc ;
: check-gl-program ( program -- program )
! TODO: debug 'Memory protection fault at address 6c'
! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
-[ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test
+[ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test
! Enter PEM pass phrase: password
[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path
!
! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
-USING: alien alien.c-types assocs kernel libc namespaces
-openssl.libcrypto openssl.libssl sequences ;
+USING: alien alien.c-types alien.strings assocs kernel libc
+namespaces openssl.libcrypto openssl.libssl sequences
+io.encodings.ascii ;
IN: openssl
: password-cb ( -- alien )
"int" { "char*" "int" "int" "void*" } "cdecl"
- [ 3drop "password" string>char-alien 1023 memcpy
+ [ 3drop "password" ascii string>alien 1023 memcpy
"password" length ] alien-callback ;
! =========================================================
! Adapted from oci.h and ociap.h
! Tested with Oracle version - 10.1.0.3 Instant Client
-USING: alien alien.c-types combinators kernel math namespaces oracle.liboci
-prettyprint sequences ;
+USING: alien alien.c-types alien.strings combinators kernel math
+namespaces oracle.liboci prettyprint sequences
+io.encodings.ascii ;
IN: oracle
: get-oci-error ( object -- * )
1 f "uint*" <c-object> dup >r 512 "uchar" <c-array> dup >r
512 OCI_HTYPE_ERROR OCIErrorGet r> r> *uint drop
- alien>char-string throw ;
+ ascii alien>string throw ;
: check-result ( result -- )
{
: oci-log-on ( -- )
env get err get svc get
- con get connection-username dup length swap malloc-char-string swap
- con get connection-password dup length swap malloc-char-string swap
- con get connection-db dup length swap malloc-char-string swap
+ con get connection-username dup length swap ascii malloc-string swap
+ con get connection-password dup length swap ascii malloc-string swap
+ con get connection-db dup length swap ascii malloc-string swap
OCILogon check-result ;
! =========================================================
svc get OCI_HTYPE_SVCCTX srv get 0 OCI_ATTR_SERVER err get OCIAttrSet check-result ;
: set-username-attribute ( -- )
- ses get OCI_HTYPE_SESSION con get connection-username dup length swap malloc-char-string swap
+ ses get OCI_HTYPE_SESSION con get connection-username dup length swap ascii malloc-string swap
OCI_ATTR_USERNAME err get OCIAttrSet check-result ;
: set-password-attribute ( -- )
- ses get OCI_HTYPE_SESSION con get connection-password dup length swap malloc-char-string swap
+ ses get OCI_HTYPE_SESSION con get connection-password dup length swap ascii malloc-string swap
OCI_ATTR_PASSWORD err get OCIAttrSet check-result ;
: set-attributes ( -- )
check-result *void* stm set ;
: prepare-statement ( statement -- )
- >r stm get err get r> dup length swap malloc-char-string swap
+ >r stm get err get r> dup length swap ascii malloc-string swap
OCI_NTV_SYNTAX OCI_DEFAULT OCIStmtPrepare check-result ;
: calculate-size ( type -- size )
: server-version ( -- )
srv get err get 512 "uchar" malloc-array dup >r 512 OCI_HTYPE_SERVER
- OCIServerVersion check-result r> alien>char-string . ;
+ OCIServerVersion check-result r> ascii alien>string . ;
! =========================================================
! Public routines
: fetch-each ( object -- object )
fetch-statement [
- buf get alien>char-string res get swap suffix res set
+ buf get ascii alien>string res get swap suffix res set
fetch-each
] [ ] if ;
: run-query ( object -- object )
execute-statement [
- buf get alien>char-string res get swap suffix res set
+ buf get ascii alien>string res get swap suffix res set
fetch-each
] [ ] if ;
! Copyright (C) 2005, 2006 Doug Coleman.
+! Portions copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays assocs ui ui.gadgets
-ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
-math math.vectors namespaces prettyprint sequences strings
-vectors words windows.kernel32 windows.gdi32 windows.user32
-windows.opengl32 windows.messages windows.types windows.nt
-windows threads libc combinators continuations command-line
-shuffle opengl ui.render unicode.case ascii math.bitfields
-locals symbols accessors ;
+USING: alien alien.c-types alien.strings arrays assocs ui
+ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
+ui.gestures io kernel math math.vectors namespaces prettyprint
+sequences strings vectors words windows.kernel32 windows.gdi32
+windows.user32 windows.opengl32 windows.messages windows.types
+windows.nt windows threads libc combinators continuations
+command-line shuffle opengl ui.render unicode.case ascii
+math.bitfields locals symbols accessors ;
IN: ui.windows
SINGLETON: windows-ui-backend
CF_UNICODETEXT GetClipboardData dup win32-error=0/f
dup GlobalLock dup win32-error=0/f
GlobalUnlock win32-error=0/f
- alien>u16-string
+ utf16n alien>string
] if
] with-clipboard
crlf>lf ;
: copy ( str -- )
lf>crlf [
- string>u16-alien
+ utf16n string>alien
EmptyClipboard win32-error=0/f
GMEM_MOVEABLE over length 1+ GlobalAlloc
dup win32-error=0/f
0 over set-WNDCLASSEX-cbClsExtra
0 over set-WNDCLASSEX-cbWndExtra
f GetModuleHandle over set-WNDCLASSEX-hInstance
- f GetModuleHandle "fraptor" string>u16-alien LoadIcon
+ f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
over set-WNDCLASSEX-hIcon
f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
: init-win32-ui ( -- )
V{ } clone nc-buttons set-global
"MSG" malloc-object msg-obj set-global
- "Factor-window" malloc-u16-string class-name-ptr set-global
+ "Factor-window" utf16n malloc-string class-name-ptr set-global
register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ;
M: windows-ui-backend set-title ( string world -- )
world-handle
dup win-title [ free ] when*
- >r malloc-u16-string r>
+ >r utf16n malloc-string r>
2dup set-win-title
win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ;
} cond ;
: encode-clipboard ( string type -- bytes )
- XSelectionRequestEvent-target XA_UTF8_STRING =
- [ utf8 encode ] [ string>char-alien ] if ;
+ XSelectionRequestEvent-target
+ XA_UTF8_STRING = utf8 ascii ? encode ;
: set-selection-prop ( evt -- )
dpy get swap
: set-if-addr ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFADDR rot ioctl drop ;
: set-if-flags ( name flags -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap <short> over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFFLAGS rot ioctl drop ;
: set-if-dst-addr ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFDSTADDR rot ioctl drop ;
: set-if-brd-addr ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFBRDADDR rot ioctl drop ;
: set-if-netmask ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFNETMASK rot ioctl drop ;
-USING: kernel alien.c-types sequences math unix
-vectors kernel namespaces continuations
-threads assocs vectors io.unix.backend ;
-
+USING: kernel alien.c-types alien.strings sequences math unix
+vectors kernel namespaces continuations threads assocs vectors
+io.unix.backend io.encodings.utf8 ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
! io.launcher instead.
: >argv ( seq -- alien )
- [ malloc-char-string ] map f suffix >c-void*-array ;
+ [ utf8 malloc-string ] map f suffix >c-void*-array ;
: exec ( pathname argv -- int )
- [ malloc-char-string ] [ >argv ] bi* execv ;
+ [ utf8 malloc-string ] [ >argv ] bi* execv ;
: exec-with-path ( filename argv -- int )
- [ malloc-char-string ] [ >argv ] bi* execvp ;
+ [ utf8 malloc-string ] [ >argv ] bi* execvp ;
: exec-with-env ( filename argv envp -- int )
- [ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ;
+ [ utf8 malloc-string ] [ >argv ] [ >argv ] tri* execve ;
: exec-args ( seq -- int )
[ first ] [ ] bi exec ;
<table class="todo-list">
<tr><th>Summary</th><th>Priority</th><th>View</th><th>Edit</th></tr>
- <t:view component="list" />
+ <t:summary component="list" />
</table>
</t:chloe>
\r
TYPEDEF: void* REFGUID\r
TYPEDEF: void* LPUNKNOWN\r
-TYPEDEF: ushort* LPOLESTR\r
-TYPEDEF: ushort* LPCOLESTR\r
+TYPEDEF: wchar_t* LPOLESTR\r
+TYPEDEF: wchar_t* LPCOLESTR\r
\r
TYPEDEF: REFGUID REFIID\r
TYPEDEF: REFGUID REFCLSID\r
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline\r
\r
: string>guid ( string -- guid )\r
- string>u16-alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;\r
+ utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;\r
: guid>string ( guid -- string )\r
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep\r
- [ StringFromGUID2 drop ] { 2 } multikeep alien>u16-string ;\r
+ [ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ;\r
\r
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
MAX_UNICODE_PATH "ushort" <c-array>
- [ SHGetFolderPath shell32-error ] keep alien>u16-string ;
+ [ SHGetFolderPath shell32-error ] keep utf16n alien>string ;
: desktop ( -- str )
CSIDL_DESKTOPDIRECTORY shell32-directory ;
TYPEDEF: WCHAR TCHAR
TYPEDEF: TCHAR TBYTE
-! TYPEDEF: uchar* LPCSTR
-TYPEDEF: ushort* LPCSTR
-TYPEDEF: ushort* LPWSTR
+TYPEDEF: wchar_t* LPCSTR
+TYPEDEF: wchar_t* LPWSTR
! TYPEDEF: WCHAR* LPWSTR
TYPEDEF: WCHAR* LPSTR
-TYPEDEF: ushort* LPCTSTR
-TYPEDEF: ushort* LPWTSTR
+TYPEDEF: wchar_t* LPCTSTR
+TYPEDEF: wchar_t* LPWTSTR
-TYPEDEF: ushort* LPTSTR
+TYPEDEF: wchar_t* LPTSTR
TYPEDEF: LPCSTR PCTSTR
TYPEDEF: LPSTR PTSTR
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax alien.c-types arrays combinators
-kernel math namespaces parser prettyprint sequences
+USING: alien alien.syntax alien.c-types alien.strings arrays
+combinators kernel math namespaces parser prettyprint sequences
windows.errors windows.types windows.kernel32 words ;
IN: windows
: (win32-error-string) ( n -- string )
error_message
- dup alien>u16-string
+ dup utf16n alien>string
swap LocalFree drop ;
: win32-error-string ( -- str )
: (winsock-error-string) ( n -- str )
! #! WSAStartup returns the error code 'n' directly
dup winsock-expected-error?
- [ drop f ] [ error_message alien>u16-string ] if ;
+ [ drop f ] [ error_message utf16n alien>string ] if ;
: winsock-error-string ( -- string/f )
WSAGetLastError (winsock-error-string) ;
-USING: kernel io alien alien.c-types namespaces threads
+USING: kernel io alien alien.c-types alien.strings namespaces threads
arrays sequences assocs math vars combinators.lib
- x11.constants x11.events x11.xlib mortar slot-accessors geom.rect ;
+ x11.constants x11.events x11.xlib mortar slot-accessors geom.rect
+ io.encodings.ascii ;
IN: x
<display> "create" !( name <display> -- display ) [
new-empty swap >>name
- dup $name dup [ string>char-alien ] [ ] if XOpenDisplay
+ dup $name dup [ ascii string>alien ] [ ] if XOpenDisplay
dup [ >>ptr ] [ "XOpenDisplay error" throw ] if
dup $ptr XDefaultScreen >>default-screen
dup $ptr XDefaultRootWindow dupd <window> new >>default-root
<window> "fetch-name" !( window -- name-or-f )
[ <- raw f <void*> dup >r XFetchName drop r>
- dup *void* alien-address 0 = [ drop f ] [ *char* ] if ]
+ dup *void* [ drop f ] [ *void* ascii alien>string ] if ]
add-method
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax arrays kernel math
-namespaces sequences io.encodings.string io.encodings.utf8 x11.xlib
-x11.constants ;
+USING: alien alien.c-types alien.strings alien.syntax arrays
+kernel math namespaces sequences io.encodings.string
+io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants ;
IN: x11.clipboard
! This code was based on by McCLIM's Backends/CLX/port.lisp
CurrentTime XConvertSelection drop ;
: snarf-property ( prop-return -- string )
- dup *void* [ *char* ] [ drop f ] if ;
+ dup *void* [ *void* ascii alien>string ] [ drop f ] if ;
: window-property ( win prop delete? -- string )
>r dpy get -rot 0 -1 r> AnyPropertyType
! modify, just find the function or data structure in the manual
! and note the section.
-USING: kernel arrays alien alien.c-types alien.syntax
-math math.bitfields words sequences namespaces continuations ;
+USING: kernel arrays alien alien.c-types alien.strings
+alien.syntax math math.bitfields words sequences namespaces
+continuations io.encodings.ascii ;
IN: x11.xlib
LIBRARY: xlib
: initialize-x ( display-string -- )
init-locale
- dup [ string>char-alien ] when
+ dup [ ascii string>alien ] when
XOpenDisplay check-display dpy set-global
dpy get XDefaultScreen scr set-global
dpy get scr get XRootWindow root set-global ;
projects / factor.git / commitdiff