Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-03-19 14:40:09 -05:00
commit f78b626b58
68 changed files with 752 additions and 369 deletions

View File

@ -210,8 +210,9 @@ $nl
ARTICLE: "alien-callback" "Calling Factor from C"
"Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
{ $subsection alien-callback }
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
{ $subsection "alien-callback-gc" } ;
"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
{ $subsection "alien-callback-gc" }
{ $see-also "byte-arrays-gc" } ;
ARTICLE: "dll.private" "DLL handles"
"DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "."
@ -290,7 +291,7 @@ $nl
"The C library interface is entirely self-contained; there is no C code which one must write in order to wrap a library."
$nl
"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
{ $warning "Since C does not retain runtime type information or do any kind of runtime type checking, any C library interface is not pointer safe. Improper use of C functions can crash the runtime or corrupt memory in unpredictible ways." }
{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
{ $subsection "loading-libs" }
{ $subsection "alien-invoke" }
{ $subsection "alien-callback" }

View File

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math namespaces sequences system
kernel.private tuples bit-arrays byte-arrays float-arrays ;
kernel.private tuples bit-arrays byte-arrays float-arrays
arrays ;
IN: alien
! Some predicate classes used by the compiler for optimization

View File

@ -158,6 +158,19 @@ HELP: define-out
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
$nl
"In particular, a byte array can only be passed as a parameter if the the C function does not use the parameter after one of the following occurs:"
{ $list
"the C function returns"
"the C function calls Factor code via a callback"
}
"Returning from C to Factor, as well as invoking Factor code via a callback, may trigger garbage collection, and if the function had stored a pointer to the byte array somewhere, this pointer may cease to be valid."
$nl
"If this condition is not satisfied, " { $link "malloc" } " must be used instead."
{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
ARTICLE: "c-out-params" "Output parameters in C"
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
$nl
@ -229,13 +242,11 @@ $nl
{ $subsection <c-object> }
{ $subsection <c-array> }
{ $warning
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the function does not store a pointer to the byte array in some global structure, or retain it in any way after returning."
$nl
"Long-lived data for use by C libraries can be allocated manually, just as when programming in C. See " { $link "malloc" } "." }
"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
{ $see-also "c-arrays" } ;
ARTICLE: "malloc" "Manual memory management"
"Sometimes data passed to C functions must be allocated at a fixed address, and so garbage collector managed byte arrays cannot be used. See the warning at the bottom of " { $link "c-byte-arrays" } " for a description of when this is the case."
"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
$nl
"Allocating a C datum with a fixed address:"
{ $subsection malloc-object }
@ -245,8 +256,6 @@ $nl
{ $subsection malloc }
{ $subsection calloc }
{ $subsection realloc }
"The return value of the above three words must always be checked for a memory allocation failure:"
{ $subsection check-ptr }
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsection free }
"You can unsafely copy a range of bytes from one memory location to another:"
@ -271,20 +280,25 @@ ARTICLE: "c-strings" "C strings"
{ $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 } "."
"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 } ;
{ $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. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
"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
"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
{ $subsection "c-types-specs" }
{ $subsection "c-byte-arrays" }
{ $subsection "malloc" }
{ $subsection "c-strings" }
{ $subsection "c-arrays" }
{ $subsection "c-out-params" }
"Important guidelines for passing data in byte arrays:"
{ $subsection "byte-arrays-gc" }
"C-style enumerated types are supported:"
{ $subsection POSTPONE: C-ENUM: }
"C types can be aliased for convenience and consitency with native library documentation:"

View File

@ -330,11 +330,11 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
! Hack; if we're on ARM, we probably don't have much RAM, so
! skip this test.
cpu "arm" = [
[ "testing" ] [
"testing" callback-5a callback_test_1
] unit-test
] unless
! cpu "arm" = [
! [ "testing" ] [
! "testing" callback-5a callback_test_1
! ] unit-test
! ] unless
: callback-6
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;

View File

@ -87,11 +87,7 @@ call
"words.private"
"vectors"
"vectors.private"
} [
dup find-vocab-root swap create-vocab
[ set-vocab-root ] keep
f swap set-vocab-source-loaded?
] each
} [ create-vocab drop ] each
H{ } clone source-files set
H{ } clone class<map set

View File

@ -3,9 +3,7 @@
USING: words sequences vocabs kernel ;
IN: bootstrap.syntax
"syntax" create-vocab
"resource:core" over set-vocab-root
f swap set-vocab-source-loaded?
"syntax" create-vocab drop
{
"!"

View File

@ -4,7 +4,7 @@ inference.dataflow optimizer tools.test kernel.private generic
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts ;
system layouts vectors ;
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test

View File

@ -1,3 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
IN: io.encodings.binary SYMBOL: binary
USING: io.encodings kernel ;
IN: io.encodings.binary
TUPLE: binary ;
M: binary <encoder> drop ;
M: binary <decoder> drop ;

View File

@ -44,25 +44,21 @@ $nl { $vocab-link "io.encodings.utf16" } ;
ARTICLE: "encodings-protocol" "Encoding protocol"
"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again."
{ $subsection decode-step }
{ $subsection init-decoder }
{ $subsection stream-write-encoded } ;
{ $subsection decode-char }
{ $subsection encode-char }
"The following methods are optional:"
{ $subsection <encoder> }
{ $subsection <decoder> } ;
HELP: decode-step ( buf char encoding -- )
{ $values { "buf" "A string buffer which characters can be pushed to" }
{ "char" "An octet which is read from a stream" }
HELP: decode-char ( stream encoding -- char/f )
{ $values { "stream" "an underlying input stream" }
{ "encoding" "An encoding descriptor tuple" } }
{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ;
{ $description "Reads a single code point from the underlying stream, interpreting it by the encoding. This should not be used directly." } ;
HELP: stream-write-encoded ( string stream encoding -- )
{ $values { "string" "a string" }
{ "stream" "an output stream" }
HELP: encode-char ( char stream encoding -- )
{ $values { "char" "a character" }
{ "stream" "an underlying output stream" }
{ "encoding" "an encoding descriptor" } }
{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ;
{ $description "Writes the code point in the encoding to the underlying stream given. This should not be used directly." } ;
HELP: init-decoder ( stream encoding -- encoding )
{ $values { "stream" "an input stream" }
{ "encoding" "an encoding descriptor" } }
{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ;
{ init-decoder decode-step stream-write-encoded } related-words
{ encode-char decode-char } related-words

View File

@ -2,62 +2,36 @@
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces
growable strings io classes continuations combinators
io.styles io.streams.plain io.encodings.binary splitting
io.streams.duplex byte-arrays ;
io.styles io.streams.plain splitting
io.streams.duplex byte-arrays sequences.private ;
IN: io.encodings
! The encoding descriptor protocol
GENERIC: decode-step ( buf char encoding -- )
M: object decode-step drop swap push ;
GENERIC: decode-char ( stream encoding -- char/f )
GENERIC: init-decoder ( stream encoding -- encoding )
M: tuple-class init-decoder construct-empty init-decoder ;
M: object init-decoder nip ;
GENERIC: encode-char ( char stream encoding -- )
GENERIC: stream-write-encoded ( string stream encoding -- byte-array )
M: object stream-write-encoded drop stream-write ;
GENERIC: <decoder> ( stream decoding -- newstream )
GENERIC: <encoder> ( stream encoding -- newstream )
: replacement-char HEX: fffd ;
! Decoding
<PRIVATE
TUPLE: decode-error ;
: decode-error ( -- * ) \ decode-error construct-empty throw ;
SYMBOL: begin
TUPLE: decoder stream code cr ;
M: tuple-class <decoder> construct-empty <decoder> ;
M: tuple <decoder> f decoder construct-boa ;
: push-decoded ( buf ch -- buf ch state )
over push 0 begin ;
: push-replacement ( buf -- buf ch state )
! This is the replacement character
HEX: fffd push-decoded ;
: space ( resizable -- room-left )
dup underlying swap [ length ] 2apply - ;
: full? ( resizable -- ? ) space zero? ;
: end-read-loop ( buf ch state stream quot -- string/f )
2drop 2drop >string f like ;
: decode-read-loop ( buf stream encoding -- string/f )
pick full? [ 2drop >string ] [
over stream-read1 [
-rot tuck >r >r >r dupd r> decode-step r> r>
decode-read-loop
] [ 2drop >string f like ] if*
] if ;
: decode-read ( length stream encoding -- string )
rot <sbuf> -rot decode-read-loop ;
TUPLE: decoder code cr ;
: <decoder> ( stream encoding -- newstream )
dup binary eq? [ drop ] [
dupd init-decoder { set-delegate set-decoder-code }
decoder construct
] if ;
: >decoder< ( decoder -- stream encoding )
{ decoder-stream decoder-code } get-slots ;
: cr+ t swap set-decoder-cr ; inline
@ -82,72 +56,83 @@ TUPLE: decoder code cr ;
over decoder-cr [
over cr-
"\n" ?head [
swap stream-read1 [ add ] when*
] [ nip ] if
] [ nip ] if ;
over stream-read1 [ add ] when*
] when
] when nip ;
: read-loop ( n stream -- string )
SBUF" " clone [
[
>r nip stream-read1 dup
[ r> push f ] [ r> 2drop t ] if
] 2curry find-integer drop
] keep "" like f like ;
M: decoder stream-read
tuck { delegate decoder-code } get-slots decode-read fix-read ;
tuck read-loop fix-read ;
M: decoder stream-read-partial stream-read ;
: decoder-read-until ( stream delim -- ch )
! Copied from { c-reader stream-read-until }!!!
over stream-read1 dup [
dup pick memq? [ 2nip ] [ , decoder-read-until ] if
] [
2nip
] if ;
: (read-until) ( buf quot -- string/f sep/f )
! quot: -- char stop?
dup call
[ >r drop "" like r> ]
[ pick push (read-until) ] if ; inline
M: decoder stream-read-until
! Copied from { c-reader stream-read-until }!!!
[ swap decoder-read-until ] "" make
swap over empty? over not and [ 2drop f f ] when ;
SBUF" " clone -rot >decoder<
[ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
(read-until) ;
: fix-read1 ( stream char -- char )
over decoder-cr [
over cr-
dup CHAR: \n = [
drop stream-read1
] [ nip ] if
] [ nip ] if ;
drop dup stream-read1
] when
] when nip ;
M: decoder stream-read1
1 swap stream-read f like [ first ] [ f ] if* ;
dup >decoder< decode-char fix-read1 ;
M: decoder stream-readln ( stream -- str )
"\r\n" over stream-read-until handle-readln ;
M: decoder dispose decoder-stream dispose ;
! Encoding
TUPLE: encode-error ;
: encode-error ( -- * ) \ encode-error construct-empty throw ;
TUPLE: encoder code ;
: <encoder> ( stream encoding -- newstream )
dup binary eq? [ drop ] [
construct-empty { set-delegate set-encoder-code }
encoder construct
] if ;
TUPLE: encoder stream code ;
M: tuple-class <encoder> construct-empty <encoder> ;
M: tuple <encoder> encoder construct-boa ;
: >encoder< ( encoder -- stream encoding )
{ encoder-stream encoder-code } get-slots ;
M: encoder stream-write1
>r 1string r> stream-write ;
>encoder< encode-char ;
M: encoder stream-write
{ delegate encoder-code } get-slots stream-write-encoded ;
>encoder< [ encode-char ] 2curry each ;
M: encoder dispose delegate dispose ;
M: encoder dispose encoder-stream dispose ;
M: encoder stream-flush encoder-stream stream-flush ;
INSTANCE: encoder plain-writer
! Rebinding duplex streams which have not read anything yet
: reencode ( stream encoding -- newstream )
over encoder? [ >r delegate r> ] when <encoder> ;
over encoder? [ >r encoder-stream r> ] when <encoder> ;
: redecode ( stream encoding -- newstream )
over decoder? [ >r delegate r> ] when <decoder> ;
over decoder? [ >r decoder-stream r> ] when <decoder> ;
PRIVATE>
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
tuck reencode >r redecode r> <duplex-stream> ;

View File

@ -6,82 +6,68 @@ IN: io.encodings.utf8
! Decoding UTF-8
TUPLE: utf8 ch state ;
TUPLE: utf8 ;
SYMBOL: double
SYMBOL: triple
SYMBOL: triple2
SYMBOL: quad
SYMBOL: quad2
SYMBOL: quad3
<PRIVATE
: starts-2? ( char -- ? )
-6 shift BIN: 10 number= ;
dup [ -6 shift BIN: 10 number= ] when ;
: append-nums ( buf bottom top state-out -- buf num state )
>r over starts-2?
[ 6 shift swap BIN: 111111 bitand bitor r> ]
[ r> 3drop push-replacement ] if ;
: append-nums ( stream byte -- stream char )
over stream-read1 dup starts-2?
[ swap 6 shift swap BIN: 111111 bitand bitor ]
[ 2drop replacement-char ] if ;
: begin-utf8 ( buf byte -- buf ch state )
: double ( stream byte -- stream char )
BIN: 11111 bitand append-nums ;
: triple ( stream byte -- stream char )
BIN: 1111 bitand append-nums append-nums ;
: quad ( stream byte -- stream char )
BIN: 111 bitand append-nums append-nums append-nums ;
: begin-utf8 ( stream byte -- stream char )
{
{ [ dup -7 shift zero? ] [ push-decoded ] }
{ [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] }
{ [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] }
{ [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] }
{ [ t ] [ drop push-replacement ] }
{ [ dup -7 shift zero? ] [ ] }
{ [ dup -5 shift BIN: 110 number= ] [ double ] }
{ [ dup -4 shift BIN: 1110 number= ] [ triple ] }
{ [ dup -3 shift BIN: 11110 number= ] [ quad ] }
{ [ t ] [ drop replacement-char ] }
} cond ;
: end-multibyte ( buf byte ch -- buf ch state )
f append-nums [ push-decoded ] unless* ;
: decode-utf8 ( stream -- char/f )
dup stream-read1 dup [ begin-utf8 ] when nip ;
: decode-utf8-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop begin-utf8 ] }
{ double [ end-multibyte ] }
{ triple [ triple2 append-nums ] }
{ triple2 [ end-multibyte ] }
{ quad [ quad2 append-nums ] }
{ quad2 [ quad3 append-nums ] }
{ quad3 [ end-multibyte ] }
} case ;
: unpack-state ( encoding -- ch state )
{ utf8-ch utf8-state } get-slots ;
: pack-state ( ch state encoding -- )
{ set-utf8-ch set-utf8-state } set-slots ;
M: utf8 decode-step ( buf char encoding -- )
[ unpack-state decode-utf8-step ] keep pack-state drop ;
M: utf8 init-decoder nip begin over set-utf8-state ;
M: utf8 decode-char
drop decode-utf8 ;
! Encoding UTF-8
: encoded ( char -- )
BIN: 111111 bitand BIN: 10000000 bitor write1 ;
: encoded ( stream char -- )
BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ;
: char>utf8 ( char -- )
: char>utf8 ( stream char -- )
{
{ [ dup -7 shift zero? ] [ write1 ] }
{ [ dup -7 shift zero? ] [ swap stream-write1 ] }
{ [ dup -11 shift zero? ] [
dup -6 shift BIN: 11000000 bitor write1
2dup -6 shift BIN: 11000000 bitor swap stream-write1
encoded
] }
{ [ dup -16 shift zero? ] [
dup -12 shift BIN: 11100000 bitor write1
dup -6 shift encoded
2dup -12 shift BIN: 11100000 bitor swap stream-write1
2dup -6 shift encoded
encoded
] }
{ [ t ] [
dup -18 shift BIN: 11110000 bitor write1
dup -12 shift encoded
dup -6 shift encoded
2dup -18 shift BIN: 11110000 bitor swap stream-write1
2dup -12 shift encoded
2dup -6 shift encoded
encoded
] }
} cond ;
M: utf8 stream-write-encoded
! For efficiency, this should be modified to avoid variable reads
drop [ [ char>utf8 ] each ] with-stream* ;
M: utf8 encode-char
drop swap char>utf8 ;
PRIVATE>

View File

@ -1,5 +1,5 @@
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
sequences io namespaces ;
sequences io namespaces io.encodings.private ;
IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream )
@ -7,7 +7,7 @@ IN: io.streams.byte-array
: with-byte-writer ( encoding quot -- byte-array )
>r <byte-writer> r> [ stdio get ] compose with-stream*
>byte-array ; inline
dup encoder? [ encoder-stream ] when >byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream )
>r >byte-vector dup reverse-here r> <decoder> ;

2
core/io/streams/c/c-docs.factor Normal file → Executable file
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.files threads
strings byte-arrays io.streams.lines io.streams.plain ;
strings byte-arrays io.streams.plain ;
IN: io.streams.c
ARTICLE: "io.streams.c" "ANSI C streams"

View File

@ -1,9 +1,9 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.string
USING: io kernel math namespaces sequences sbufs strings
generic splitting growable continuations io.streams.plain
io.encodings ;
io.encodings io.encodings.private ;
IN: io.streams.string
M: growable dispose drop ;
@ -49,8 +49,11 @@ M: growable stream-read
M: growable stream-read-partial
stream-read ;
TUPLE: null ;
M: null decode-char drop stream-read1 ;
: <string-reader> ( str -- stream )
>sbuf dup reverse-here f <decoder> ;
>sbuf dup reverse-here null <decoder> ;
: with-string-reader ( str quot -- )
>r <string-reader> r> with-stream ; inline

View File

@ -78,6 +78,8 @@ IN: vocabs.loader.tests
] with-compilation-unit
] unit-test
[ f ] [ "vocabs.loader.test.b" vocab-files empty? ] unit-test
[ ] [
[
"vocabs.loader.test.b" vocab-files
@ -118,6 +120,13 @@ IN: vocabs.loader.tests
[ { "resource:core/kernel/kernel.factor" 1 } ]
[ "kernel" vocab where ] unit-test
[ ] [
[
"vocabs.loader.test.c" forget-vocab
"vocabs.loader.test.d" forget-vocab
] with-compilation-unit
] unit-test
[ t ] [
[ "vocabs.loader.test.d" require ] [ :1 ] recover
"vocabs.loader.test.d" vocab-source-loaded?

View File

@ -43,7 +43,7 @@ V{
vocab-roots get swap [ vocab-dir? ] curry find nip ;
M: string vocab-root
dup vocab [ vocab-root ] [ find-vocab-root ] ?if ;
vocab dup [ vocab-root ] when ;
M: vocab-link vocab-root
vocab-link-root ;
@ -66,24 +66,22 @@ SYMBOL: load-help?
: load-docs ( vocab -- )
load-help? get [
[ docs-weren't-loaded ] keep
[ vocab-docs-path ?run-file ] keep
[ vocab-docs-path [ ?run-file ] when* ] keep
docs-were-loaded
] [ drop ] if ;
: create-vocab-with-root ( vocab-link -- vocab )
dup vocab-name create-vocab
swap vocab-root over set-vocab-root ;
: create-vocab-with-root ( name root -- vocab )
swap create-vocab [ set-vocab-root ] keep ;
: update-root ( vocab -- )
dup vocab-root
[ drop ] [ dup find-vocab-root swap set-vocab-root ] if ;
: reload ( name -- )
[
f >vocab-link
dup vocab-root [
dup vocab-source-path resource-exists? [
create-vocab-with-root
dup load-source
load-docs
] [ no-vocab ] if
] [ no-vocab ] if
dup vocab [
dup update-root dup load-source load-docs
] [ no-vocab ] ?if
] with-compiler-errors ;
: require ( vocab -- )
@ -100,33 +98,38 @@ SYMBOL: load-help?
SYMBOL: blacklist
GENERIC: (load-vocab) ( name -- vocab )
: add-to-blacklist ( error vocab -- )
vocab-name blacklist get dup [ set-at ] [ 3drop ] if ;
GENERIC: (load-vocab) ( name -- )
M: vocab (load-vocab)
[
dup vocab-root [
dup update-root
dup vocab-root [
[
dup vocab-source-loaded? [ dup load-source ] unless
dup vocab-docs-loaded? [ dup load-docs ] unless
] when
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
] [ [ swap add-to-blacklist ] keep rethrow ] recover
] when drop ;
M: string (load-vocab)
[ ".private" ?tail drop reload ] keep vocab ;
! ".private" ?tail drop
dup find-vocab-root >vocab-link (load-vocab) ;
M: vocab-link (load-vocab)
vocab-name (load-vocab) ;
dup vocab-name swap vocab-root dup
[ create-vocab-with-root (load-vocab) ] [ 2drop ] if ;
[
dup vocab-name blacklist get at* [
rethrow
] [
drop
[ dup vocab swap or (load-vocab) ] with-compiler-errors
] if
[
dup vocab-name blacklist get at* [
rethrow
] [
drop
[ (load-vocab) ] with-compiler-errors
] if
] with-compiler-errors
] load-vocab-hook set-global
: vocab-where ( vocab -- loc )

View File

@ -15,8 +15,8 @@ source-loaded? docs-loaded? ;
M: vocab equal? 2drop f ;
: <vocab> ( name -- vocab )
H{ } clone t
{ set-vocab-name set-vocab-words set-vocab-source-loaded? }
H{ } clone
{ set-vocab-name set-vocab-words }
\ vocab construct ;
GENERIC: vocab ( vocab-spec -- vocab )
@ -60,9 +60,16 @@ M: f vocab-help ;
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
SYMBOL: load-vocab-hook
TUPLE: no-vocab name ;
: load-vocab ( name -- vocab ) load-vocab-hook get call ;
: no-vocab ( name -- * )
vocab-name \ no-vocab construct-boa throw ;
SYMBOL: load-vocab-hook ! ( name -- )
: load-vocab ( name -- vocab )
dup load-vocab-hook get call
dup vocab [ ] [ no-vocab ] ?if ;
: vocabs ( -- seq )
dictionary get keys natural-sort ;
@ -115,8 +122,3 @@ UNION: vocab-spec vocab vocab-link ;
vocab-name dictionary get delete-at ;
M: vocab-spec forget* forget-vocab ;
TUPLE: no-vocab name ;
: no-vocab ( name -- * )
vocab-name \ no-vocab construct-boa throw ;

View File

@ -9,11 +9,10 @@ IN: bootstrap.help
t load-help? set-global
[ vocab ] load-vocab-hook [
[ drop ] load-vocab-hook [
vocabs
[ vocab-root ] subset
[ vocab-source-loaded? ] subset
[ dup vocab-docs-loaded? [ drop ] [ load-docs ] if ] each
[ vocab-docs-loaded? not ] subset
[ load-docs ] each
] with-variable ;
load-help

View File

@ -1,5 +1,5 @@
USING: arrays bunny.model bunny.cel-shaded
combinators.lib continuations kernel math multiline
combinators.cleave continuations kernel math multiline
opengl opengl.shaders opengl.framebuffers opengl.gl
opengl.capabilities sequences ui.gadgets combinators.cleave ;
IN: bunny.outlined

View File

@ -141,7 +141,10 @@ MACRO: map-call-with ( quots -- )
[ 2drop ] append ;
MACRO: map-call-with2 ( quots -- )
[ (make-call-with2) ] keep length [ narray ] curry append ;
[
[ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
[ 2drop ] append
] keep length [ narray ] curry append ;
MACRO: map-exec-with ( words -- )
[ 1quotation ] map [ map-call-with ] curry ;
@ -163,5 +166,12 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
: and? ( obj quot1 quot2 -- ? )
>r keep r> rot [ call ] [ 2drop f ] if ; inline
MACRO: multikeep ( word out-indexes -- ... )
[
dup >r [ \ npick \ >r 3array % ] each
%
r> [ drop \ r> , ] each
] [ ] make ;
: retry ( quot n -- )
[ drop ] rot compose attempt-all ; inline

View File

@ -158,7 +158,8 @@ M: f print-element drop ;
: $subsection ( element -- )
[ first ($long-link) ] ($subsection) ;
: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
: ($vocab-link) ( text vocab -- )
dup vocab-root >vocab-link write-link ;
: $vocab-subsection ( element -- )
[

View File

@ -1,18 +1,22 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
USING: io io.encodings kernel math io.encodings.private ;
IN: io.encodings.ascii
: encode-check< ( string stream max -- )
[ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
<PRIVATE
: encode-if< ( char stream encoding max -- )
nip 1- pick < [ encode-error ] [ stream-write1 ] if ;
: push-if< ( sbuf character max -- )
over <= [ drop HEX: fffd ] when swap push ;
: decode-if< ( stream encoding max -- character )
nip swap stream-read1
[ tuck > [ drop replacement-char ] unless ]
[ drop f ] if* ;
PRIVATE>
TUPLE: ascii ;
M: ascii stream-write-encoded ( string stream encoding -- )
drop 128 encode-check< ;
M: ascii encode-char
128 encode-if< ;
M: ascii decode-step
drop 128 push-if< ;
M: ascii decode-char
128 decode-if< ;

View File

@ -1,12 +1,12 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.encodings strings kernel io.encodings.ascii sequences math ;
USING: io io.encodings kernel io.encodings.ascii.private ;
IN: io.encodings.latin1
TUPLE: latin1 ;
M: latin1 stream-write-encoded
drop 256 encode-check< ;
M: latin1 encode-char
256 encode-if< ;
M: latin1 decode-step
drop swap push ;
M: latin1 decode-char
drop stream-read1 ;

View File

@ -1,133 +1,101 @@
! 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 ;
io.encodings combinators splitting io byte-arrays inspector ;
IN: io.encodings.utf16
TUPLE: utf16be ;
TUPLE: utf16le ;
TUPLE: utf16 ;
<PRIVATE
! UTF-16BE decoding
TUPLE: utf16be ch state ;
SYMBOL: double
SYMBOL: quad1
SYMBOL: quad2
SYMBOL: quad3
SYMBOL: ignore
: do-ignore ( -- ch state ) 0 ignore ;
: append-nums ( byte ch -- ch )
8 shift bitor ;
over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
: end-multibyte ( buf byte ch -- buf ch state )
append-nums push-decoded ;
: double-be ( stream byte -- stream char )
over stream-read1 swap append-nums ;
: begin-utf16be ( buf byte -- buf ch state )
: quad-be ( stream byte -- stream char )
double-be over stream-read1 [
dup -2 shift BIN: 110111 number= [
>r 2 shift r> BIN: 11 bitand bitor
over stream-read1 swap append-nums HEX: 10000 +
] [ 2drop dup stream-read1 drop replacement-char ] if
] when* ;
: ignore ( stream -- stream char )
dup stream-read1 drop replacement-char ;
: begin-utf16be ( stream byte -- stream char )
dup -3 shift BIN: 11011 number= [
dup BIN: 00000100 bitand zero?
[ BIN: 11 bitand quad1 ]
[ drop do-ignore ] if
] [ double ] if ;
: handle-quad2be ( byte ch -- ch state )
swap dup -2 shift BIN: 110111 number= [
>r 2 shift r> BIN: 11 bitand bitor quad3
] [ 2drop do-ignore ] if ;
: decode-utf16be-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop begin-utf16be ] }
{ double [ end-multibyte ] }
{ quad1 [ append-nums quad2 ] }
{ quad2 [ handle-quad2be ] }
{ quad3 [ append-nums HEX: 10000 + push-decoded ] }
{ ignore [ 2drop push-replacement ] }
} case ;
: unpack-state-be ( encoding -- ch state )
{ utf16be-ch utf16be-state } get-slots ;
: pack-state-be ( ch state encoding -- )
{ set-utf16be-ch set-utf16be-state } set-slots ;
M: utf16be decode-step
[ unpack-state-be decode-utf16be-step ] keep pack-state-be drop ;
M: utf16be init-decoder nip begin over set-utf16be-state ;
[ BIN: 11 bitand quad-be ]
[ drop ignore ] if
] [ double-be ] if ;
M: utf16be decode-char
drop dup stream-read1 dup [ begin-utf16be ] when nip ;
! UTF-16LE decoding
TUPLE: utf16le ch state ;
: quad-le ( stream ch -- stream char )
over stream-read1 swap 10 shift bitor
over stream-read1 dup -2 shift BIN: 110111 = [
BIN: 11 bitand append-nums HEX: 10000 +
] [ 2drop replacement-char ] if ;
: handle-double ( buf byte ch -- buf ch state )
swap dup -3 shift BIN: 11011 = [
: double-le ( stream byte1 byte2 -- stream char )
dup -3 shift BIN: 11011 = [
dup BIN: 100 bitand 0 number=
[ BIN: 11 bitand 8 shift bitor quad2 ]
[ 2drop push-replacement ] if
] [ end-multibyte ] if ;
[ BIN: 11 bitand 8 shift bitor quad-le ]
[ 2drop replacement-char ] if
] [ append-nums ] if ;
: handle-quad3le ( buf byte ch -- buf ch state )
swap dup -2 shift BIN: 110111 = [
BIN: 11 bitand append-nums HEX: 10000 + push-decoded
] [ 2drop push-replacement ] if ;
: begin-utf16le ( stream byte -- stream char )
over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
: decode-utf16le-step ( buf byte ch state -- buf ch state )
{
{ begin [ drop double ] }
{ double [ handle-double ] }
{ quad1 [ append-nums quad2 ] }
{ quad2 [ 10 shift bitor quad3 ] }
{ quad3 [ handle-quad3le ] }
} case ;
: unpack-state-le ( encoding -- ch state )
{ utf16le-ch utf16le-state } get-slots ;
: pack-state-le ( ch state encoding -- )
{ set-utf16le-ch set-utf16le-state } set-slots ;
M: utf16le decode-step
[ unpack-state-le decode-utf16le-step ] keep pack-state-le drop ;
M: utf16le init-decoder nip begin over set-utf16le-state ;
M: utf16le decode-char
drop dup stream-read1 dup [ begin-utf16le ] when nip ;
! UTF-16LE/BE encoding
: encode-first
: encode-first ( char -- byte1 byte2 )
-10 shift
dup -8 shift BIN: 11011000 bitor
swap HEX: FF bitand ;
: encode-second
: encode-second ( char -- byte3 byte4 )
BIN: 1111111111 bitand
dup -8 shift BIN: 11011100 bitor
swap BIN: 11111111 bitand ;
: char>utf16be ( char -- )
: stream-write2 ( stream char1 char2 -- )
rot [ stream-write1 ] curry 2apply ;
: char>utf16be ( stream char -- )
dup HEX: FFFF > [
HEX: 10000 -
dup encode-first swap write1 write1
encode-second swap write1 write1
] [ h>b/b write1 write1 ] if ;
2dup encode-first stream-write2
encode-second stream-write2
] [ h>b/b swap stream-write2 ] if ;
: stream-write-utf16be ( string stream -- )
[ [ char>utf16be ] each ] with-stream* ;
M: utf16be encode-char ( char stream encoding -- )
drop swap char>utf16be ;
M: utf16be stream-write-encoded ( string stream encoding -- )
drop stream-write-utf16be ;
: char>utf16le ( char -- )
: char>utf16le ( char stream -- )
dup HEX: FFFF > [
HEX: 10000 -
dup encode-first write1 write1
encode-second write1 write1
] [ h>b/b swap write1 write1 ] if ;
2dup encode-first swap stream-write2
encode-second swap stream-write2
] [ h>b/b stream-write2 ] if ;
: stream-write-utf16le ( string stream -- )
[ [ char>utf16le ] each ] with-stream* ;
M: utf16le stream-write-encoded ( string stream encoding -- )
drop stream-write-utf16le ;
M: utf16le encode-char ( char stream encoding -- )
drop swap char>utf16le ;
! UTF-16
@ -139,17 +107,18 @@ M: utf16le stream-write-encoded ( string stream encoding -- )
: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
TUPLE: utf16 started? ;
M: utf16 stream-write-encoded
dup utf16-started? [ drop ]
[ t swap set-utf16-started? bom-le over stream-write ] if
stream-write-utf16le ;
TUPLE: missing-bom ;
M: missing-bom summary drop "The BOM for a UTF-16 stream was missing" ;
: bom>le/be ( bom -- le/be )
dup bom-le sequence= [ drop utf16le ] [
bom-be sequence= [ utf16be ] [ decode-error ] if
bom-be sequence= [ utf16be ] [ missing-bom ] if
] if ;
M: utf16 init-decoder ( stream encoding -- newencoding )
2 rot stream-read bom>le/be construct-empty init-decoder ;
M: utf16 <decoder> ( stream utf16 -- decoder )
drop 2 over stream-read bom>le/be <decoder> ;
M: utf16 <encoder> ( stream utf16 -- encoder )
drop bom-le over stream-write utf16le <encoder> ;
PRIVATE>

View File

@ -1,6 +1,6 @@
IN: io.unix.launcher.tests
USING: io.files tools.test io.launcher arrays io namespaces
continuations math io.encodings.ascii io.encodings.latin1
continuations math io.encodings.binary io.encodings.ascii
accessors kernel sequences ;
[ ] [
@ -64,7 +64,7 @@ accessors kernel sequences ;
[ ] [
2 [
"launcher-test-1" temp-file ascii <file-appender> [
"launcher-test-1" temp-file binary <file-appender> [
<process>
swap >>stdout
"echo Hello" >>command
@ -84,7 +84,7 @@ accessors kernel sequences ;
<process>
"env" >>command
{ { "A" "B" } } >>environment
latin1 <process-stream> lines
ascii <process-stream> lines
"A=B" swap member?
] unit-test
@ -93,5 +93,5 @@ accessors kernel sequences ;
"env" >>command
{ { "A" "B" } } >>environment
+replace-environment+ >>environment-mode
latin1 <process-stream> lines
ascii <process-stream> lines
] unit-test

View File

@ -2,5 +2,5 @@ USING: kernel alien ;
IN: opengl.gl.macosx
: gl-function-context ( -- context ) 0 ; inline
: gl-function-address ( name -- address ) "gl" load-library dlsym ; inline
: gl-function-address ( name -- address ) f dlsym ; inline
: gl-function-calling-convention ( -- str ) "cdecl" ; inline

View File

@ -2,7 +2,7 @@
! 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.lib
macros arrays combinators.cleave ;
combinators.cleave macros arrays ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
@ -92,10 +92,11 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
GL_ATTACHED_SHADERS gl-program-get-int ; inline
: gl-program-shaders ( program -- shaders )
dup gl-program-shaders-length [
dup "GLuint" <c-array>
[ 0 <int> swap glGetAttachedShaders ] keep
] keep c-uint-array> ;
dup gl-program-shaders-length
dup "GLuint" <c-array>
0 <int> swap
[ glGetAttachedShaders ] { 3 1 } multikeep
c-uint-array> ;
: delete-gl-program-only ( program -- )
glDeleteProgram ; inline

10
extra/tools/deploy/shaker/strip-libc.factor Normal file → Executable file
View File

@ -1,10 +1,10 @@
USING: libc.private ;
IN: libc
: malloc (malloc) ;
: malloc (malloc) check-ptr ;
: realloc (realloc) check-ptr ;
: calloc (calloc) check-ptr ;
: free (free) ;
: realloc (realloc) ;
: calloc (calloc) ;

View File

@ -19,16 +19,16 @@ IN: tools.vocabs
] [ drop ] if ;
: vocab-tests ( vocab -- tests )
dup vocab-root [
dup vocab-root dup [
[
f >vocab-link dup
>vocab-link dup
vocab-tests-file,
vocab-tests-dir,
] { } make
] [ drop f ] if ;
] [ 2drop f ] if ;
: vocab-files ( vocab -- seq )
f >vocab-link [
dup find-vocab-root >vocab-link [
dup vocab-source-path [ , ] when*
dup vocab-docs-path [ , ] when*
vocab-tests %

0
extra/windows/advapi32/advapi32.factor Executable file → Normal file
View File

0
extra/windows/advapi32/authors.txt Executable file → Normal file
View File

0
extra/windows/ce/authors.txt Executable file → Normal file
View File

View File

@ -11,4 +11,5 @@ USING: alien sequences ;
! { "gl" "libGLES_CM.dll" "stdcall" }
! { "glu" "libGLES_CM.dll" "stdcall" }
! { "freetype" "libfreetype-6.dll" "stdcall" }
{ "ole32" "ole32.dll" "stdcall" }
} [ first3 add-library ] each

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -0,0 +1,15 @@
USING: help.markup help.syntax io kernel math quotations
multiline ;
IN: windows.com
HELP: com-query-interface
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } }
{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be immediately retained using " { $link com-add-ref } ". The pointer must then be released using " { $link com-release } " when it is no longer needed." } ;
HELP: com-add-ref
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
{ $description "A small wrapper around " { $link IUnknown::AddRef } ". Increments the reference count on " { $snippet "interface" } ", keeping it on the stack. The reference count must be decremented with " { $link com-release } " when the reference is no longer held." } ;
HELP: com-release
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ;

View File

@ -0,0 +1,93 @@
USING: kernel windows.com windows.com.syntax windows.ole32
alien alien.syntax tools.test libc alien.c-types arrays.lib
namespaces arrays continuations ;
IN: windows.com.tests
! Create some test COM interfaces
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
HRESULT returnOK ( )
HRESULT returnError ( ) ;
COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
int getX ( )
void setX ( int newX ) ;
! Implement the IInherited interface in factor using alien-callbacks
C-STRUCT: test-implementation
{ "void*" "vtbl" }
{ "int" "x" } ;
: QueryInterface-callback
"HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 swap set-void*-nth S_OK ]
alien-callback ;
: AddRef-callback
"ULONG" { "void*" } "stdcall" [ drop 2 ]
alien-callback ;
: Release-callback
"ULONG" { "void*" } "stdcall" [ drop 1 ]
alien-callback ;
: returnOK-callback
"HRESULT" { "void*" } "stdcall" [ drop S_OK ]
alien-callback ;
: returnError-callback
"HRESULT" { "void*" } "stdcall" [ drop E_FAIL ]
alien-callback ;
: getX-callback
"int" { "void*" } "stdcall" [ test-implementation-x ]
alien-callback ;
: setX-callback
"void" { "void*" "int" } "stdcall" [ swap set-test-implementation-x ]
alien-callback ;
SYMBOL: +test-implementation-vtbl+
SYMBOL: +guinea-pig-implementation+
: (make-test-implementation) ( x imp -- imp )
[ set-test-implementation-x ] keep
+test-implementation-vtbl+ get over set-test-implementation-vtbl ;
: <test-implementation> ( x -- imp )
"test-implementation" <c-object> (make-test-implementation) ;
: <malloced-test-implementation> ( x -- imp )
"test-implementation" heap-size malloc (make-test-implementation) ;
QueryInterface-callback
AddRef-callback
Release-callback
returnOK-callback
returnError-callback
getX-callback
setX-callback
7 narray >c-void*-array
dup byte-length [
[ byte-array>memory ] keep
+test-implementation-vtbl+ set
! Test that the words defined by COM-INTERFACE: do their magic
"{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
"{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
S_OK 1array [ 0 <test-implementation> ISimple::returnOK ] unit-test
E_FAIL <long> *long 1array [ 0 <test-implementation> ISimple::returnError ] unit-test
1984 1array [ 0 <test-implementation> dup 1984 IInherited::setX IInherited::getX ] unit-test
! Test that the helper functions for QueryInterface, AddRef, Release work
0 <malloced-test-implementation> +guinea-pig-implementation+ set
[
+guinea-pig-implementation+ get 1array [
+guinea-pig-implementation+ get com-add-ref
] unit-test
{ } [ +guinea-pig-implementation+ get com-release ] unit-test
+guinea-pig-implementation+ get 1array [
+guinea-pig-implementation+ get IUnknown-iid com-query-interface
] unit-test
] [ +guinea-pig-implementation+ get free ] [ ] cleanup
] with-malloc

View File

@ -0,0 +1,22 @@
USING: alien alien.c-types windows.com.syntax windows.ole32
windows.types continuations kernel ;
IN: windows.com
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
ULONG AddRef ( )
ULONG Release ( ) ;
: com-query-interface ( interface iid -- interface' )
f <void*>
[ IUnknown::QueryInterface ole32-error ] keep
*void* ;
: com-add-ref ( interface -- interface )
[ IUnknown::AddRef drop ] keep ; inline
: com-release ( interface -- )
IUnknown::Release drop ; inline
: with-com-interface ( interface quot -- )
[ keep ] [ com-release ] [ ] cleanup ; inline

View File

@ -0,0 +1 @@
COM interface

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -0,0 +1 @@
Parsing words for defining COM interfaces

View File

@ -0,0 +1,26 @@
USING: help.markup help.syntax io kernel math quotations
multiline ;
IN: windows.com.syntax
HELP: COM-INTERFACE:
{ $syntax <"
COM-INTERFACE: <interface> <parent> <iid>
<function-1> ( <params1> )
<function-2> ( <params2> )
... ;
"> }
{ $description "\nFor the interface " { $snippet "<interface>" } ", a word " { $snippet "<interface>-iid ( -- iid )" } " is defined to push the interface GUID (IID) onto the stack. Words of the form " { $snippet "<interface>::<function>" } " are also defined to invoke each method, as well as the methods inherited from " { $snippet "<parent>" } ". A " { $snippet "<parent>" } " of " { $snippet "f" } " indicates that the interface is a root interface. (Note that COM conventions demand that all interfaces at least inherit from " { $snippet "IUnknown" } ".)\n\nExample:" }
{ $code <"
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}
HRESULT QueryInterface ( REFGUID iid, void** ppvObject )
ULONG AddRef ( )
ULONG Release ( ) ;
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
HRESULT returnOK ( )
HRESULT returnError ( ) ;
COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
int getX ( )
void setX ( int newX ) ;
"> } ;

View File

@ -0,0 +1,90 @@
USING: alien alien.c-types kernel windows.ole32
combinators.lib parser splitting sequences.lib
sequences namespaces new-slots combinators.cleave
assocs quotations shuffle accessors words macros
alien.syntax fry ;
IN: windows.com.syntax
<PRIVATE
C-STRUCT: com-interface
{ "void*" "vtbl" } ;
MACRO: com-invoke ( n return parameters -- )
dup length -roll
'[
, npick com-interface-vtbl , swap void*-nth , ,
"stdcall" alien-indirect
] ;
TUPLE: com-interface-definition name parent iid functions ;
C: <com-interface-definition> com-interface-definition
TUPLE: com-function-definition name return parameters ;
C: <com-function-definition> com-function-definition
SYMBOL: +com-interface-definitions+
+com-interface-definitions+ get-global
[ H{ } +com-interface-definitions+ set-global ]
unless
: find-com-interface-definition ( name -- definition )
dup "f" = [ drop f ] [
dup +com-interface-definitions+ get-global at*
[ nip ]
[ swap " COM interface hasn't been defined" append throw ]
if
] if ;
: save-com-interface-definition ( definition -- )
dup name>> +com-interface-definitions+ get-global set-at ;
: (parse-com-function) ( tokens -- definition )
[ second ]
[ first ]
[ 3 tail 2 group [ first ] map "void*" add* ]
tri
<com-function-definition> ;
: parse-com-functions ( -- functions )
";" parse-tokens { ")" } split
[ empty? not ] subset
[ (parse-com-function) ] map ;
: (iid-word) ( definition -- word )
name>> "-iid" append create-in ;
: (function-word) ( function interface -- word )
name>> "::" rot name>> 3append create-in ;
: all-functions ( definition -- functions )
dup parent>> [ all-functions ] [ { } ] if*
swap functions>> append ;
: (define-word-for-function) ( function interface n -- )
-rot [ (function-word) swap ] 2keep drop
{ return>> parameters>> } get-slots
[ com-invoke ] 3curry
define ;
: define-words-for-com-interface ( definition -- )
[ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
[ name>> "com-interface" swap typedef ]
[
dup all-functions
[ (define-word-for-function) ] with each-index
]
tri ;
PRIVATE>
: COM-INTERFACE:
scan
scan find-com-interface-definition
scan string>guid
parse-com-functions
<com-interface-definition>
dup save-com-interface-definition
define-words-for-com-interface
; parsing

View File

@ -0,0 +1,3 @@
windows
com
bindings

View File

@ -0,0 +1,3 @@
windows
com
bindings

0
extra/windows/errors/authors.txt Executable file → Normal file
View File

0
extra/windows/errors/errors.factor Executable file → Normal file
View File

0
extra/windows/gdi32/authors.txt Executable file → Normal file
View File

0
extra/windows/kernel32/authors.txt Executable file → Normal file
View File

0
extra/windows/kernel32/kernel32.factor Executable file → Normal file
View File

0
extra/windows/messages/authors.txt Executable file → Normal file
View File

0
extra/windows/messages/messages.factor Executable file → Normal file
View File

0
extra/windows/nt/authors.txt Executable file → Normal file
View File

View File

@ -12,4 +12,5 @@ USING: alien sequences ;
{ "gl" "opengl32.dll" "stdcall" }
{ "glu" "glu32.dll" "stdcall" }
{ "freetype" "freetype6.dll" "cdecl" }
{ "ole32" "ole32.dll" "stdcall" }
} [ first3 add-library ] each

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -0,0 +1,59 @@
USING: alien alien.syntax alien.c-types math kernel sequences
windows windows.types combinators.lib ;
IN: windows.ole32
LIBRARY: ole32
C-STRUCT: GUID
{ "DWORD" "part1" }
{ "DWORD" "part2" }
{ "DWORD" "part3" }
{ "DWORD" "part4" } ;
TYPEDEF: void* REFGUID
TYPEDEF: void* LPUNKNOWN
TYPEDEF: ushort* LPOLESTR
TYPEDEF: ushort* LPCOLESTR
TYPEDEF: REFGUID REFIID
TYPEDEF: REFGUID REFCLSID
FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;
FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ;
FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
: S_OK 0 ; inline
: S_FALSE 1 ; inline
: E_FAIL HEX: 80004005 ; inline
: E_INVALIDARG HEX: 80070057 ; inline
: MK_ALT HEX: 20 ; inline
: DROPEFFECT_NONE 0 ; inline
: DROPEFFECT_COPY 1 ; inline
: DROPEFFECT_MOVE 2 ; inline
: DROPEFFECT_LINK 4 ; inline
: DROPEFFECT_SCROLL HEX: 80000000 ; inline
: DD_DEFSCROLLINSET 11 ; inline
: DD_DEFSCROLLDELAY 50 ; inline
: DD_DEFSCROLLINTERVAL 50 ; inline
: DD_DEFDRAGDELAY 200 ; inline
: DD_DEFDRAGMINDIST 2 ; inline
: ole32-error ( n -- )
dup S_OK = [
drop
] [ (win32-error-string) throw ] if ;
: guid= ( a b -- ? )
IsEqualGUID c-bool> ;
: GUID-STRING-LENGTH
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
: string>guid ( string -- guid )
string>u16-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 ;

0
extra/windows/opengl32/authors.txt Executable file → Normal file
View File

0
extra/windows/opengl32/opengl32.factor Executable file → Normal file
View File

0
extra/windows/shell32/authors.txt Executable file → Normal file
View File

View File

@ -1,5 +1,6 @@
USING: alien alien.c-types alien.syntax combinators
kernel windows windows.user32 ;
kernel windows windows.user32 windows.ole32
windows.com windows.com.syntax ;
IN: windows.shell32
: CSIDL_DESKTOP HEX: 00 ; inline
@ -68,10 +69,6 @@ IN: windows.shell32
: CSIDL_FLAG_MASK HEX: ff00 ; inline
: S_OK 0 ; inline
: S_FALSE 1 ; inline
: E_FAIL HEX: 80004005 ; inline
: E_INVALIDARG HEX: 80070057 ; inline
: ERROR_FILE_NOT_FOUND 2 ; inline
: SHGFP_TYPE_CURRENT 0 ; inline
@ -89,15 +86,7 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
f "open" rot f f SW_SHOWNORMAL ShellExecute drop ;
: shell32-error ( n -- )
dup S_OK = [
drop
] [
{
! { ERROR_FILE_NOT_FOUND [ "file not found" throw ] }
! { E_INVALIDARG [ "invalid arg" throw ] }
[ (win32-error-string) throw ]
} case
] if ;
ole32-error ; inline
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
@ -130,3 +119,96 @@ FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFi
: program-files-common-x86 ( -- str )
CSIDL_PROGRAM_FILES_COMMONX86 shell32-directory ;
: SHCONTF_FOLDERS 32 ; inline
: SHCONTF_NONFOLDERS 64 ; inline
: SHCONTF_INCLUDEHIDDEN 128 ; inline
: SHCONTF_INIT_ON_FIRST_NEXT 256 ; inline
: SHCONTF_NETPRINTERSRCH 512 ; inline
: SHCONTF_SHAREABLE 1024 ; inline
: SHCONTF_STORAGE 2048 ; inline
TYPEDEF: DWORD SHCONTF
: SHGDN_NORMAL 0 ; inline
: SHGDN_INFOLDER 1 ; inline
: SHGDN_FOREDITING HEX: 1000 ; inline
: SHGDN_INCLUDE_NONFILESYS HEX: 2000 ; inline
: SHGDN_FORADDRESSBAR HEX: 4000 ; inline
: SHGDN_FORPARSING HEX: 8000 ; inline
TYPEDEF: DWORD SHGDNF
: SFGAO_CANCOPY DROPEFFECT_COPY ; inline
: SFGAO_CANMOVE DROPEFFECT_MOVE ; inline
: SFGAO_CANLINK DROPEFFECT_LINK ; inline
: SFGAO_CANRENAME HEX: 00000010 ; inline
: SFGAO_CANDELETE HEX: 00000020 ; inline
: SFGAO_HASPROPSHEET HEX: 00000040 ; inline
: SFGAO_DROPTARGET HEX: 00000100 ; inline
: SFGAO_CAPABILITYMASK HEX: 00000177 ; inline
: SFGAO_LINK HEX: 00010000 ; inline
: SFGAO_SHARE HEX: 00020000 ; inline
: SFGAO_READONLY HEX: 00040000 ; inline
: SFGAO_GHOSTED HEX: 00080000 ; inline
: SFGAO_HIDDEN HEX: 00080000 ; inline
: SFGAO_DISPLAYATTRMASK HEX: 000F0000 ; inline
: SFGAO_FILESYSANCESTOR HEX: 10000000 ; inline
: SFGAO_FOLDER HEX: 20000000 ; inline
: SFGAO_FILESYSTEM HEX: 40000000 ; inline
: SFGAO_HASSUBFOLDER HEX: 80000000 ; inline
: SFGAO_CONTENTSMASK HEX: 80000000 ; inline
: SFGAO_VALIDATE HEX: 01000000 ; inline
: SFGAO_REMOVABLE HEX: 02000000 ; inline
: SFGAO_COMPRESSED HEX: 04000000 ; inline
: SFGAO_BROWSABLE HEX: 08000000 ; inline
: SFGAO_NONENUMERATED HEX: 00100000 ; inline
: SFGAO_NEWCONTENT HEX: 00200000 ; inline
TYPEDEF: ULONG SFGAOF
C-STRUCT: SHITEMID
{ "USHORT" "cb" }
{ "BYTE[1]" "abID" } ;
TYPEDEF: SHITEMID* LPSHITEMID
TYPEDEF: SHITEMID* LPCSHITEMID
C-STRUCT: ITEMIDLIST
{ "SHITEMID" "mkid" } ;
TYPEDEF: ITEMIDLIST* LPITEMIDLIST
TYPEDEF: ITEMIDLIST* LPCITEMIDLIST
TYPEDEF: ITEMIDLIST ITEMID_CHILD
TYPEDEF: ITEMID_CHILD* PITEMID_CHILD
TYPEDEF: ITEMID_CHILD* PCUITEMID_CHILD
: STRRET_WSTR 0 ; inline
: STRRET_OFFSET 1 ; inline
: STRRET_CSTR 2 ; inline
C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
C-STRUCT: STRRET
{ "int" "uType" }
{ "STRRET-union" "union" } ;
COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )
HRESULT Skip ( ULONG celt )
HRESULT Reset ( )
HRESULT Clone ( IEnumIDList** ppenum ) ;
COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046}
HRESULT ParseDisplayName ( HWND hwndOwner, void* pbcReserved, LPOLESTR lpszDisplayName, ULONG* pchEaten, LPITEMIDLIST* ppidl, ULONG* pdwAttributes )
HRESULT EnumObjects ( HWND hwndOwner, SHCONTF grfFlags, IEnumIDList** ppenumIDList )
HRESULT BindToObject ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvOut )
HRESULT BindToStorage ( LPCITEMIDLIST pidl, void* pbcReserved, REFGUID riid, void** ppvObj )
HRESULT CompareIDs ( LPARAM lParam, LPCITEMIDLIST pidl1, LPCITEMIDLIST pidl2 )
HRESULT CreateViewObject ( HWND hwndOwner, REFGUID riid, void** ppvOut )
HRESULT GetAttributesOf ( UINT cidl, LPCITEMIDLIST* apidl, SFGAOF* rgfInOut )
HRESULT GetUIObjectOf ( HWND hwndOwner, UINT cidl, LPCITEMIDLIST* apidl, REFGUID riid, UINT* prgfInOut, void** ppvOut )
HRESULT GetDisplayNameOf ( LPCITEMIDLIST pidl, SHGDNF uFlags, STRRET* lpName )
HRESULT SetNameOf ( HWND hwnd, LPCITEMIDLIST pidl, LPCOLESTR lpszName, SHGDNF uFlags, LPITEMIDLIST* ppidlOut ) ;
FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ;
FUNCTION: HRESULT StrRetToBufW ( STRRET *pstr, PCUITEMID_CHILD pidl, LPWSTR pszBuf, UINT cchBuf ) ;
: StrRetToBuf StrRetToBufW ; inline

0
extra/windows/time/authors.txt Executable file → Normal file
View File

0
extra/windows/time/time-tests.factor Executable file → Normal file
View File

0
extra/windows/time/time.factor Executable file → Normal file
View File

0
extra/windows/types/authors.txt Executable file → Normal file
View File

0
extra/windows/user32/authors.txt Executable file → Normal file
View File

0
extra/windows/user32/user32.factor Executable file → Normal file
View File

0
extra/windows/windows.factor Executable file → Normal file
View File

0
extra/windows/winsock/authors.txt Executable file → Normal file
View File

0
extra/windows/winsock/winsock.factor Executable file → Normal file
View File