FFI string encoding conversion
Slava Pestov
parent
e2a185f1f4
commit
55f6636bc0
|
|
@ -28,12 +28,6 @@ M: f expired? drop t ;
|
|||
: <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? [
|
||||
|
|
|
|||
|
|
@ -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" } "."
|
||||
|
|
|
|||
|
|
@ -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 <displaced-alien> ] ;
|
||||
|
|
|
|||
|
|
@ -62,28 +62,6 @@ HELP: <c-object>
|
|||
|
||||
{ <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." } ;
|
||||
|
|
@ -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 <void*> } " 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
|
||||
|
|
|
|||
|
|
@ -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 } <displaced-alien> <void*>
|
||||
|
|
|
|||
|
|
@ -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 <int> *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 <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 ;
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
<c-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
|
||||
|
||||
<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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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>>
|
||||
[ <reversed> (make-prep-quot) ] [ ] make ;
|
||||
: param-prep-quot ( node -- quot )
|
||||
parameters>> [ <reversed> (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>> [ <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." ;
|
||||
|
|
@ -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 <alien> ] 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
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
|
||||
|
||||
|
|
@ -0,0 +1,108 @@
|
|||
! 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
|
||||
|
|
@ -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 ] [ \ <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" } ;
|
||||
|
||||
! 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -638,10 +638,6 @@ tuple
|
|||
{ "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" }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ 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 ;
|
||||
sequences.private io.encodings.ascii ;
|
||||
|
||||
! Make sure that intrinsic ops compile to correct code.
|
||||
[ ] [ 1 [ drop ] compile-call ] unit-test
|
||||
|
|
@ -364,8 +364,8 @@ cell 8 = [
|
|||
[ ] [ "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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Value protocol
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ USING: tools.test math math.functions math.constants
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -92,6 +92,8 @@ M: object infer-call
|
|||
peek-d infer-call
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ call t "no-compile" set-word-prop
|
||||
|
||||
\ execute [
|
||||
1 ensure-values
|
||||
pop-literal nip
|
||||
|
|
@ -471,18 +473,6 @@ set-primitive-effect
|
|||
|
||||
\ 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
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! UTF-16BE decoding
|
||||
|
|
@ -124,13 +121,4 @@ M: utf16 <decoder> ( stream utf16 -- decoder )
|
|||
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>
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <memory-stream> ( alien -- stream )
|
||||
0 memory-stream boa ;
|
||||
|
||||
M: memory-stream stream-read1
|
||||
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
|
||||
[ [ 1+ ] change-index drop ] bi ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,49 @@
|
|||
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 . ;
|
||||
|
|
@ -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 <void*> 0 <int> over
|
||||
>r method_getArgumentInfo drop
|
||||
r> *char* ;
|
||||
r> *void* ascii alien>string ;
|
||||
|
||||
SYMBOL: objc>alien-types
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <empty-method-list> ( n -- alien )
|
||||
|
|
@ -26,7 +27,7 @@ IN: cocoa.subclassing
|
|||
: <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
|
||||
|
|
|
|||
|
|
@ -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" <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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
|||
[ <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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<int> 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 )
|
|||
<int> dupd GetUserName zero? [
|
||||
free win32-error f
|
||||
] [
|
||||
[ alien>u16-string ] keep free
|
||||
pull-win32-string
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -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 [ <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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! 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
|
||||
|
||||
<< {
|
||||
|
|
@ -130,4 +131,4 @@ M: object resolve-host ( host serv passive? -- seq )
|
|||
M: object host-name ( -- name )
|
||||
256 <byte-array> dup dup length gethostname
|
||||
zero? [ "gethostname failed" throw ] unless
|
||||
alien>char-string ;
|
||||
ascii alien>string ;
|
||||
|
|
|
|||
|
|
@ -2,9 +2,10 @@
|
|||
! 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 ;
|
||||
|
|
@ -79,7 +80,7 @@ M: linux-monitor dispose ( monitor -- )
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,15 @@
|
|||
! 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 -- )
|
||||
|
|
@ -36,7 +38,7 @@ TUPLE: connect-task < output-task ;
|
|||
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 -- )
|
||||
|
|
@ -56,8 +58,6 @@ M: unix ((client)) ( addrspec -- client-in client-out )
|
|||
] if ;
|
||||
|
||||
! Server sockets - TCP and Unix domain
|
||||
USE: unix
|
||||
|
||||
: init-server-socket ( fd -- )
|
||||
SOL_SOCKET SO_REUSEADDR sockopt ;
|
||||
|
||||
|
|
@ -83,8 +83,6 @@ M: accept-task do-io-task
|
|||
: 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
|
||||
|
|
@ -187,12 +185,12 @@ M: local protocol-family drop PF_UNIX ;
|
|||
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> ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: io.windows.nt.files
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -35,3 +35,8 @@ IN: locals.backend
|
|||
[ infer-r> ]
|
||||
[ { } <effect> infer-shuffle ] bi
|
||||
] "infer" set-word-prop
|
||||
|
||||
<<
|
||||
{ load-locals get-local drop-locals }
|
||||
[ t "no-compile" set-word-prop ] each
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
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 ;
|
||||
|
|
@ -9,10 +10,10 @@ 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
|
||||
|
||||
|
|
@ -37,10 +38,10 @@ 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 ;
|
||||
|
|
@ -52,7 +53,7 @@ INSTANCE: range immutable-sequence
|
|||
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) ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
! 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
|
||||
|
||||
|
|
@ -150,7 +151,7 @@ FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNu
|
|||
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
|
||||
|
|
@ -192,7 +193,7 @@ C: <column> column
|
|||
|
||||
: 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
|
||||
|
|
@ -204,7 +205,7 @@ C: <column> column
|
|||
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
|
||||
|
|
@ -213,12 +214,12 @@ C: <column> column
|
|||
|
||||
: 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 ] }
|
||||
|
|
@ -236,7 +237,7 @@ C: <field> field
|
|||
: 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>
|
||||
|
|
|
|||
|
|
@ -1,14 +1,12 @@
|
|||
! 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
|
||||
|
|
@ -47,7 +45,7 @@ IN: opengl.shaders
|
|||
: 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 )
|
||||
|
|
@ -82,7 +80,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-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 )
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
|
|||
! 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
|
||||
|
|
|
|||
|
|
@ -3,8 +3,9 @@
|
|||
!
|
||||
! 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
|
||||
|
||||
|
|
@ -21,7 +22,7 @@ SYMBOL: rsa
|
|||
|
||||
: 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 ;
|
||||
|
||||
! =========================================================
|
||||
|
|
|
|||
|
|
@ -4,8 +4,9 @@
|
|||
! 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
|
||||
|
||||
|
|
@ -31,7 +32,7 @@ C: <connection> connection
|
|||
: 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 -- )
|
||||
{
|
||||
|
|
@ -101,9 +102,9 @@ C: <connection> connection
|
|||
|
||||
: 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 ;
|
||||
|
||||
! =========================================================
|
||||
|
|
@ -118,11 +119,11 @@ C: <connection> connection
|
|||
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 ( -- )
|
||||
|
|
@ -150,7 +151,7 @@ C: <connection> connection
|
|||
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 )
|
||||
|
|
@ -222,7 +223,7 @@ C: <connection> connection
|
|||
|
||||
: 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
|
||||
|
|
@ -236,13 +237,13 @@ C: <connection> connection
|
|||
|
||||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,14 @@
|
|||
! 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
|
||||
|
|
@ -36,14 +37,14 @@ 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
|
||||
|
|
@ -409,7 +410,7 @@ SYMBOL: trace-messages?
|
|||
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
|
||||
|
||||
|
|
@ -447,7 +448,7 @@ SYMBOL: trace-messages?
|
|||
: 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 ;
|
||||
|
||||
|
|
@ -492,7 +493,7 @@ M: windows-ui-backend raise-window* ( world -- )
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -137,8 +137,8 @@ M: world selection-notify-event
|
|||
} 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
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: unix.linux.ifreq
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -19,7 +19,7 @@ IN: unix.linux.ifreq
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -28,7 +28,7 @@ IN: unix.linux.ifreq
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -37,7 +37,7 @@ IN: unix.linux.ifreq
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -46,7 +46,7 @@ IN: unix.linux.ifreq
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
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
|
||||
|
|
@ -9,16 +8,16 @@ IN: unix.process
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
|
||||
<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>
|
||||
|
|
|
|||
|
|
@ -12,8 +12,8 @@ C-STRUCT: GUID
|
|||
|
||||
TYPEDEF: void* REFGUID
|
||||
TYPEDEF: void* LPUNKNOWN
|
||||
TYPEDEF: ushort* LPOLESTR
|
||||
TYPEDEF: ushort* LPCOLESTR
|
||||
TYPEDEF: wchar_t* LPOLESTR
|
||||
TYPEDEF: wchar_t* LPCOLESTR
|
||||
|
||||
TYPEDEF: REFGUID REFIID
|
||||
TYPEDEF: REFGUID REFCLSID
|
||||
|
|
@ -52,8 +52,8 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
|
|||
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
|
||||
|
||||
: string>guid ( string -- guid )
|
||||
string>u16-alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
|
||||
utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
|
||||
: guid>string ( guid -- string )
|
||||
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
|
||||
[ StringFromGUID2 drop ] { 2 } multikeep alien>u16-string ;
|
||||
[ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ;
|
||||
|
||||
|
|
|
|||
|
|
@ -91,7 +91,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -66,9 +66,8 @@ TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
|
|||
|
||||
TYPEDEF: WCHAR TCHAR
|
||||
TYPEDEF: TCHAR TBYTE
|
||||
! TYPEDEF: uchar* LPCSTR
|
||||
TYPEDEF: ushort* LPCSTR
|
||||
TYPEDEF: ushort* LPWSTR
|
||||
TYPEDEF: wchar_t* LPCSTR
|
||||
TYPEDEF: wchar_t* LPWSTR
|
||||
|
||||
|
||||
|
||||
|
|
@ -126,10 +125,10 @@ TYPEDEF: WCHAR* LPCWSTR
|
|||
! 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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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
|
||||
|
||||
|
|
@ -14,7 +14,7 @@ FUNCTION: void* error_message ( DWORD id ) ;
|
|||
|
||||
: (win32-error-string) ( n -- string )
|
||||
error_message
|
||||
dup alien>u16-string
|
||||
dup utf16n alien>string
|
||||
swap LocalFree drop ;
|
||||
|
||||
: win32-error-string ( -- str )
|
||||
|
|
|
|||
|
|
@ -397,7 +397,7 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
|
|||
: (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) ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
|
||||
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
|
||||
|
||||
|
|
@ -29,7 +30,7 @@ define-independent-class
|
|||
|
||||
<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
|
||||
|
|
@ -433,7 +434,7 @@ add-method
|
|||
|
||||
<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
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! 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
|
||||
|
|
@ -25,7 +25,7 @@ TUPLE: x-clipboard atom contents ;
|
|||
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
|
||||
|
|
|
|||
|
|
@ -11,8 +11,9 @@
|
|||
! 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
|
||||
|
|
@ -1372,7 +1373,7 @@ SYMBOL: root
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue