diff --git a/basis/alien/arrays/arrays-docs.factor b/basis/alien/arrays/arrays-docs.factor index e8ebe1824d..bf012090f8 100644 --- a/basis/alien/arrays/arrays-docs.factor +++ b/basis/alien/arrays/arrays-docs.factor @@ -7,6 +7,6 @@ $nl "C type specifiers for array types are documented in " { $link "c-types-specs" } "." $nl "Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:" -{ $subsection require-c-type-arrays } -{ $subsection } -{ $subsection } ; +{ $subsection require-c-arrays } +{ $subsection } +{ $subsection } ; diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index e56f151383..98994c753e 100755 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -35,8 +35,8 @@ M: array stack-size drop "void*" stack-size ; M: array c-type-boxer-quot unclip [ array-length ] - [ [ require-c-type-arrays ] keep ] bi* - [ ] 2curry ; + [ [ require-c-arrays ] keep ] bi* + [ ] 2curry ; M: array c-type-unboxer-quot drop [ >c-ptr ] ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index cd0f90f81c..b6b28d0a95 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -49,10 +49,10 @@ HELP: c-setter { $errors "Throws an error if the type does not exist." } ; HELP: -{ $deprecated "New code should use " { $link } " or the " { $vocab-link "specialized-arrays" } " vocabularies." } { $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } } { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." } -{ $errors "Throws an error if the type does not exist or the requested size is negative." } ; +{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } +{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ; HELP: { $values { "type" "a C type" } { "array" byte-array } } @@ -72,8 +72,8 @@ HELP: byte-array>memory HELP: malloc-array { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } } -{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link } "." } -{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } +{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link } "." } +{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." } { $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ; @@ -89,7 +89,7 @@ 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." } ; -{ malloc-array } related-words +{ malloc-array } related-words HELP: box-parameter { $values { "n" integer } { "ctype" string } } @@ -130,20 +130,15 @@ HELP: malloc-string } } ; -HELP: require-c-type-arrays +HELP: require-c-arrays { $values { "c-type" "a C type" } } -{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link } " or " { $link } " vocabularies." } +{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link } " or " { $link } " vocabularies." } { $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ; -HELP: -{ $values { "len" integer } { "c-type" "a C type" } { "array" "a specialized array" } } -{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } "." } -{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ; - -HELP: +HELP: { $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } } { $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." } -{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ; +{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ; 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." diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index d75a4898c5..ac0bbf68b3 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -24,6 +24,7 @@ size align array-class array-constructor +(array)-constructor direct-array-class direct-array-constructor sequence-mixin-class ; @@ -79,47 +80,74 @@ M: string c-type ( name -- type ) : ?require-word ( word/pair -- ) dup word? [ drop ] [ first require ] ?if ; -GENERIC: require-c-type-arrays ( c-type -- ) +! These words being foldable means that words need to be +! recompiled if a C type is redefined. Even so, folding the +! size facilitates some optimizations. +GENERIC: heap-size ( type -- size ) foldable -M: object require-c-type-arrays +M: string heap-size c-type heap-size ; + +M: abstract-c-type heap-size size>> ; + +GENERIC: require-c-arrays ( c-type -- ) + +M: object require-c-arrays drop ; -M: c-type require-c-type-arrays +M: c-type require-c-arrays [ array-class>> ?require-word ] [ sequence-mixin-class>> ?require-word ] [ direct-array-class>> ?require-word ] tri ; -M: string require-c-type-arrays - c-type require-c-type-arrays ; +M: string require-c-arrays + c-type require-c-arrays ; -M: array require-c-type-arrays - first c-type require-c-type-arrays ; +M: array require-c-arrays + first c-type require-c-arrays ; ERROR: specialized-array-vocab-not-loaded vocab word ; -: c-type-array-constructor ( c-type -- word ) +: c-array-constructor ( c-type -- word ) array-constructor>> dup array? [ first2 specialized-array-vocab-not-loaded ] when ; foldable -: c-type-direct-array-constructor ( c-type -- word ) +: c-(array)-constructor ( c-type -- word ) + (array)-constructor>> dup array? + [ first2 specialized-array-vocab-not-loaded ] when ; foldable + +: c-direct-array-constructor ( c-type -- word ) direct-array-constructor>> dup array? [ first2 specialized-array-vocab-not-loaded ] when ; foldable -GENERIC: ( len c-type -- array ) -M: object - c-type-array-constructor execute( len -- array ) ; inline -M: string - c-type ; inline -M: array - first c-type ; inline +GENERIC: ( len c-type -- array ) +M: object + c-array-constructor execute( len -- array ) ; inline +M: string + c-type ; inline +M: array + first c-type ; inline -GENERIC: ( alien len c-type -- array ) -M: object - c-type-direct-array-constructor execute( alien len -- array ) ; inline -M: string - c-type ; inline -M: array - first c-type ; inline +GENERIC: (c-array) ( len c-type -- array ) +M: object (c-array) + c-(array)-constructor execute( len -- array ) ; inline +M: string (c-array) + c-type (c-array) ; inline +M: array (c-array) + first c-type (c-array) ; inline + +GENERIC: ( alien len c-type -- array ) +M: object + c-direct-array-constructor execute( alien len -- array ) ; inline +M: string + c-type ; inline +M: array + first c-type ; inline + +: malloc-array ( n type -- alien ) + [ heap-size calloc ] [ ] 2bi ; inline + +: (malloc-array) ( n type -- alien ) + [ heap-size * malloc ] [ ] 2bi ; inline GENERIC: c-type-class ( name -- class ) @@ -219,15 +247,6 @@ M: c-type unbox-return f swap c-type-unbox ; M: string unbox-return c-type unbox-return ; -! These words being foldable means that words need to be -! recompiled if a C type is redefined. Even so, folding the -! size facilitates some optimizations. -GENERIC: heap-size ( type -- size ) foldable - -M: string heap-size c-type heap-size ; - -M: abstract-c-type heap-size size>> ; - GENERIC: stack-size ( type -- size ) foldable M: string stack-size c-type stack-size ; @@ -253,21 +272,12 @@ M: f byte-length drop 0 ; inline [ "Cannot write struct fields with this type" throw ] ] unless* ; -: ( n type -- array ) - heap-size * ; inline deprecated - : ( type -- array ) heap-size ; inline : (c-object) ( type -- array ) heap-size (byte-array) ; inline -: malloc-array ( n type -- alien ) - [ heap-size calloc ] [ ] 2bi ; inline - -: (malloc-array) ( n type -- alien ) - [ heap-size * malloc ] [ ] 2bi ; inline - : malloc-object ( type -- alien ) 1 swap heap-size calloc ; inline @@ -354,6 +364,10 @@ M: long-long-type box-return ( type -- ) [ "specialized-arrays." prepend ] [ "<" "-array>" surround ] bi* ?lookup >>array-constructor ] + [ + [ "specialized-arrays." prepend ] + [ "(" "-array)" surround ] bi* ?lookup >>(array)-constructor + ] [ [ "specialized-arrays." prepend ] [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class diff --git a/basis/classes/struct/prettyprint/prettyprint.factor b/basis/classes/struct/prettyprint/prettyprint.factor index 6368424ec6..d9d2a6f677 100644 --- a/basis/classes/struct/prettyprint/prettyprint.factor +++ b/basis/classes/struct/prettyprint/prettyprint.factor @@ -1,7 +1,9 @@ ! (c)Joe Groff bsd license -USING: accessors assocs classes classes.struct combinators -kernel math prettyprint.backend prettyprint.custom -prettyprint.sections see.private sequences strings words ; +USING: accessors alien alien.c-types arrays assocs classes +classes.struct combinators continuations fry kernel make math +math.parser mirrors prettyprint.backend prettyprint.custom +prettyprint.sections see.private sequences strings +summary words ; IN: classes.struct.prettyprint assoc ( struct -- assoc ) - [ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ; + [ class struct-slots ] [ struct-slot-values ] bi zip ; : pprint-struct-slot ( slot -- ) ; +: pprint-struct ( struct -- ) + [ + [ \ S{ ] dip + [ class ] + [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi + \ } (pprint-tuple) + ] ?pprint-tuple ; + +: pprint-struct-pointer ( struct -- ) + \ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ; + PRIVATE> M: struct-class see-class* @@ -38,4 +51,23 @@ M: struct >pprint-sequence [ class ] [ struct-slot-values ] bi class-slot-sequence ; M: struct pprint* - [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ; + [ pprint-struct ] + [ pprint-struct-pointer ] pprint-c-object ; + +M: struct summary + [ + dup class name>> % + " struct of " % + byte-length # + " bytes " % + ] "" make ; + +M: struct make-mirror + [ + [ drop "underlying" ] [ (underlying)>> ] bi 2array 1array + ] [ + '[ + _ struct>assoc + [ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map + ] [ drop { } ] recover + ] bi append ; diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor index 787f03423e..8a67f00354 100644 --- a/basis/classes/struct/struct-docs.factor +++ b/basis/classes/struct/struct-docs.factor @@ -42,6 +42,13 @@ HELP: S{ { $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } } { $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ; +HELP: S@ +{ $syntax "S@ class alien" } +{ $values { "class" "a " { $link struct } " class word" } { "alien" "a literal alien" } } +{ $description "Marks the beginning of a literal struct at a specific C address. The prettyprinter uses this syntax when the memory backing a struct object is invalid. This syntax should not generally be used in source code." } ; + +{ POSTPONE: S{ POSTPONE: S@ } related-words + HELP: UNION-STRUCT: { $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" } { $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } } diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor index f015556bec..55f67c398b 100644 --- a/basis/classes/struct/struct-tests.factor +++ b/basis/classes/struct/struct-tests.factor @@ -1,12 +1,12 @@ ! (c)Joe Groff bsd license USING: accessors alien alien.c-types alien.libraries -alien.structs.fields alien.syntax ascii classes.struct combinators -destructors io.encodings.utf8 io.pathnames io.streams.string +alien.structs.fields alien.syntax ascii byte-arrays classes.struct +combinators destructors io.encodings.utf8 io.pathnames io.streams.string kernel libc literals math multiline namespaces prettyprint prettyprint.config see sequences specialized-arrays.ushort system tools.test compiler.tree.debugger struct-arrays classes.tuple.private specialized-arrays.direct.int -compiler.units byte-arrays specialized-arrays.char ; +compiler.units specialized-arrays.char ; IN: classes.struct.tests << @@ -76,18 +76,38 @@ STRUCT: struct-test-string-ptr ] with-destructors ] unit-test -[ "S{ struct-test-foo { y 7654 } }" ] +[ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ] [ - f boa-tuples? - [ struct-test-foo 7654 >>y [ pprint ] with-string-writer ] - with-variable + [ + boa-tuples? off + c-object-pointers? off + struct-test-foo 7654 >>y [ pprint ] with-string-writer + ] with-scope +] unit-test + +[ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ] +[ + [ + c-object-pointers? on + 12 struct-test-foo memory>struct [ pprint ] with-string-writer + ] with-scope ] unit-test [ "S{ struct-test-foo f 0 7654 f }" ] [ - t boa-tuples? - [ struct-test-foo 7654 >>y [ pprint ] with-string-writer ] - with-variable + [ + boa-tuples? on + c-object-pointers? off + struct-test-foo 7654 >>y [ pprint ] with-string-writer + ] with-scope +] unit-test + +[ "S@ struct-test-foo f" ] +[ + [ + c-object-pointers? off + f struct-test-foo memory>struct [ pprint ] with-string-writer + ] with-scope ] unit-test [ <" USING: classes.struct ; @@ -164,6 +184,14 @@ STRUCT: struct-test-equality-2 ] with-destructors ] unit-test +[ t ] [ + [ + struct-test-equality-1 5 >>x + struct-test-equality-1 malloc-struct &free 5 >>x + [ hashcode ] bi@ = + ] with-destructors +] unit-test + STRUCT: struct-test-ffi-foo { x int } { y int } ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 09c1d23c4e..731f305748 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -6,7 +6,7 @@ combinators combinators.short-circuit combinators.smart functors.backend fry generalizations generic.parser kernel kernel.private lexer libc locals macros make math math.order parser quotations sequences slots slots.private struct-arrays vectors -words compiler.tree.propagation.transforms ; +words compiler.tree.propagation.transforms specialized-arrays.direct.uchar ; FROM: slots => reader-word writer-word ; IN: classes.struct @@ -23,7 +23,7 @@ TUPLE: struct-slot-spec < slot-spec PREDICATE: struct-class < tuple-class { [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ; -: struct-slots ( struct -- slots ) +: struct-slots ( struct-class -- slots ) "struct-slots" word-prop ; ! struct allocation @@ -35,7 +35,10 @@ M: struct equal? { [ [ class ] bi@ = ] [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ] - } 2&& ; + } 2&& ; inline + +M: struct hashcode* + [ >c-ptr ] [ byte-length ] bi hashcode* ; inline : struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable @@ -254,19 +257,22 @@ PRIVATE> ERROR: invalid-struct-slot token ; - ( name c-type attributes -- slot-spec ) + [ struct-slot-spec new ] 3dip + [ >>name ] + [ [ >>c-type ] [ struct-slot-class >>class ] bi ] + [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ; + +array ] when ; : parse-struct-slot ( -- slot ) - struct-slot-spec new - scan >>name - scan-c-type [ >>c-type ] [ struct-slot-class >>class ] bi - \ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ; + scan scan-c-type \ } parse-until ; : parse-struct-slots ( slots -- slots' more? ) scan { @@ -287,23 +293,18 @@ SYNTAX: UNION-STRUCT: SYNTAX: S{ scan-word dup struct-slots parse-tuple-literal-slots parsed ; +SYNTAX: S@ + scan-word scan-object swap memory>struct parsed ; + ! functor support array ] [ >string-param ] if ; -:: parse-struct-slot` ( accum -- accum ) - scan-string-param :> name - scan-c-type` :> c-type - \ } parse-until :> attributes - accum { - \ struct-slot-spec new - name >>name - c-type [ >>c-type ] [ struct-slot-class >>class ] bi - attributes [ dup empty? ] [ peel-off-attributes ] until drop - over push - } over push-all ; +: parse-struct-slot` ( accum -- accum ) + scan-string-param scan-c-type` \ } parse-until + [ over push ] 3curry over push-all ; : parse-struct-slots` ( accum -- accum more? ) scan { diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor index 9da68e368b..5f931340c5 100644 --- a/basis/cocoa/enumeration/enumeration.factor +++ b/basis/cocoa/enumeration/enumeration.factor @@ -4,7 +4,7 @@ USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types locals math sequences vectors fry libc destructors ; IN: cocoa.enumeration -<< "id" require-c-type-arrays >> +<< "id" require-c-arrays >> CONSTANT: NS-EACH-BUFFER-SIZE 16 @@ -19,7 +19,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16 :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- ) object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count items-count 0 = [ - state itemsPtr>> [ items-count "id" ] [ stackbuf ] if* :> items + state itemsPtr>> [ items-count "id" ] [ stackbuf ] if* :> items items-count iota [ items nth quot call ] each object quot state stackbuf count (NSFastEnumeration-each) ] unless ; inline recursive diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index fe003c32e1..26672dde80 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -155,12 +155,16 @@ objc>alien-types get [ swap ] assoc-map } case assoc-union alien>objc-types set-global +: internal-cocoa-type? ( c-type -- ? ) + [ "?" = ] [ first CHAR: _ = ] bi or ; + +: warn-c-type ( c-type -- ) + dup internal-cocoa-type? + [ drop ] [ "Warning: no such C type: " write print ] if ; + : objc-struct-type ( i string -- ctype ) [ CHAR: = ] 2keep index-from swap subseq - dup c-types get key? [ - "Warning: no such C type: " write dup print - drop "void*" - ] unless ; + dup c-types get key? [ warn-c-type "void*" ] unless ; ERROR: no-objc-type name ; diff --git a/basis/environment/winnt/winnt.factor b/basis/environment/winnt/winnt.factor index d4ce25397c..afe4425b3f 100644 --- a/basis/environment/winnt/winnt.factor +++ b/basis/environment/winnt/winnt.factor @@ -6,10 +6,10 @@ alien.c-types sequences windows.errors io.streams.memory io.encodings io ; IN: environment.winnt -<< "TCHAR" require-c-type-arrays >> +<< "TCHAR" require-c-arrays >> M: winnt os-env ( key -- value ) - MAX_UNICODE_PATH "TCHAR" + MAX_UNICODE_PATH "TCHAR" [ dup length GetEnvironmentVariable ] keep over 0 = [ 2drop f ] [ diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor index 26d57871d7..6c72dc05cc 100755 --- a/basis/game-input/dinput/dinput.factor +++ b/basis/game-input/dinput/dinput.factor @@ -39,12 +39,14 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ get IDirectInputDevice8W::SetDataFormat ole32-error ; : ( size -- DIPROPDWORD ) - "DIPROPDWORD" - "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize - "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize - 0 over set-DIPROPHEADER-dwObj - DIPH_DEVICE over set-DIPROPHEADER-dwHow - swap over set-DIPROPDWORD-dwData ; + DIPROPDWORD [ + diph>> + DIPROPDWORD heap-size >>dwSize + DIPROPHEADER heap-size >>dwHeaderSize + 0 >>dwObj + DIPH_DEVICE >>dwHow + drop + ] keep swap >>dwData ; : set-buffer-size ( device size -- ) DIPROP_BUFFERSIZE swap @@ -63,7 +65,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ GUID_SysKeyboard device-for-guid [ configure-keyboard ] [ +keyboard-device+ set-global ] bi - 256 keyboard-state boa + 256 256 keyboard-state boa +keyboard-state+ set-global ; : find-mouse ( -- ) @@ -72,23 +74,20 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ [ +mouse-device+ set-global ] bi 0 0 0 0 8 f mouse-state boa +mouse-state+ set-global - MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" + MOUSE-BUFFER-SIZE DIDEVICEOBJECTDATA +mouse-buffer+ set-global ; : device-info ( device -- DIDEVICEIMAGEINFOW ) - "DIDEVICEINSTANCEW" - "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize - [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; + DIDEVICEINSTANCEW + DIDEVICEINSTANCEW heap-size >>dwSize + [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; inline : device-caps ( device -- DIDEVCAPS ) - "DIDEVCAPS" - "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize - [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ; - -: ( memory -- byte-array ) - "GUID" heap-size memory>byte-array ; + DIDEVCAPS + DIDEVCAPS heap-size >>dwSize + [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ; inline : device-guid ( device -- guid ) - device-info DIDEVICEINSTANCEW-guidInstance ; + device-info guidInstance>> ; inline : device-attached? ( device -- ? ) +dinput+ get swap device-guid @@ -96,8 +95,9 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ : find-device-axes-callback ( -- alien ) [ ! ( lpddoi pvRef -- BOOL ) + [ DIDEVICEOBJECTINSTANCEW memory>struct ] dip +controller-devices+ get at - swap DIDEVICEOBJECTINSTANCEW-guidType { + swap guidType>> { { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] } { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] } { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] } @@ -118,8 +118,8 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ : controller-state-template ( device -- controller-state ) controller-state new over device-caps - [ DIDEVCAPS-dwButtons f >>buttons ] - [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi + [ dwButtons>> f >>buttons ] + [ dwPOVs>> zero? f pov-neutral ? >>pov ] bi find-device-axes ; : device-known? ( guid -- ? ) @@ -129,12 +129,12 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ device-for-guid { [ configure-controller ] [ controller-state-template ] - [ dup device-guid +controller-guids+ get set-at ] + [ dup device-guid clone +controller-guids+ get set-at ] [ +controller-devices+ get set-at ] } cleave ; : add-controller ( guid -- ) - dup device-known? [ drop ] [ (add-controller) ] if ; + dup device-known? [ drop ] [ (add-controller) ] if ; : remove-controller ( device -- ) [ +controller-devices+ get delete-at ] @@ -143,9 +143,9 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ : find-controller-callback ( -- alien ) [ ! ( lpddi pvRef -- BOOL ) - drop DIDEVICEINSTANCEW-guidInstance add-controller + drop DIDEVICEINSTANCEW memory>struct guidInstance>> add-controller DIENUM_CONTINUE - ] LPDIENUMDEVICESCALLBACKW ; + ] LPDIENUMDEVICESCALLBACKW ; inline : find-controllers ( -- ) +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback @@ -252,11 +252,11 @@ M: dinput-game-input-backend get-controllers [ drop controller boa ] { } assoc>map ; M: dinput-game-input-backend product-string - handle>> device-info DIDEVICEINSTANCEW-tszProductName + handle>> device-info tszProductName>> utf16n alien>string ; M: dinput-game-input-backend product-id - handle>> device-info DIDEVICEINSTANCEW-guidProduct ; + handle>> device-info guidProduct>> ; M: dinput-game-input-backend instance-id handle>> device-guid ; @@ -273,38 +273,36 @@ CONSTANT: pov-values } : >axis ( long -- float ) - 32767 - 32767.0 /f ; + 32767 - 32767.0 /f ; inline : >slider ( long -- float ) - 65535.0 /f ; + 65535.0 /f ; inline : >pov ( long -- symbol ) dup HEX: FFFF bitand HEX: FFFF = [ drop pov-neutral ] - [ 2750 + 4500 /i pov-values nth ] if ; -: >buttons ( alien length -- array ) - memory>byte-array ; + [ 2750 + 4500 /i pov-values nth ] if ; inline : (fill-if) ( controller-state DIJOYSTATE2 ? quot -- ) [ drop ] compose [ 2drop ] if ; inline : fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state ) { - [ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ] - [ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ] - [ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ] - [ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ] - [ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ] - [ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ] - [ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ] - [ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ] - [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ] + [ over x>> [ lX>> >axis >>x ] (fill-if) ] + [ over y>> [ lY>> >axis >>y ] (fill-if) ] + [ over z>> [ lZ>> >axis >>z ] (fill-if) ] + [ over rx>> [ lRx>> >axis >>rx ] (fill-if) ] + [ over ry>> [ lRy>> >axis >>ry ] (fill-if) ] + [ over rz>> [ lRz>> >axis >>rz ] (fill-if) ] + [ over slider>> [ rglSlider>> first >slider >>slider ] (fill-if) ] + [ over pov>> [ rgdwPOV>> first >pov >>pov ] (fill-if) ] + [ rgbButtons>> over buttons>> length >>buttons ] } 2cleave ; : read-device-buffer ( device buffer count -- buffer count' ) - [ "DIDEVICEOBJECTDATA" heap-size ] 2dip + [ DIDEVICEOBJECTDATA heap-size ] 2dip [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ; : (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state ) - [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi { + [ dwData>> 32 >signed ] [ dwOfs>> ] bi { { DIMOFS_X [ [ + ] curry change-dx ] } { DIMOFS_Y [ [ + ] curry change-dy ] } { DIMOFS_Z [ [ + ] curry change-scroll-dy ] } @@ -312,16 +310,15 @@ CONSTANT: pov-values } case ; : fill-mouse-state ( buffer count -- state ) - [ +mouse-state+ get ] 2dip swap - [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ; + [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ; -: get-device-state ( device byte-array -- ) +: get-device-state ( device DIJOYSTATE2 -- ) [ dup IDirectInputDevice8W::Poll ole32-error ] dip - [ length ] keep + [ byte-length ] keep IDirectInputDevice8W::GetDeviceState ole32-error ; : (read-controller) ( handle template -- state ) - swap [ "DIJOYSTATE2" heap-size [ get-device-state ] keep ] + swap [ DIJOYSTATE2 [ get-device-state ] keep ] [ fill-controller-state ] [ drop f ] with-acquisition ; M: dinput-game-input-backend read-controller diff --git a/basis/game-input/dinput/keys-array/keys-array.factor b/basis/game-input/dinput/keys-array/keys-array.factor index 12ad072449..9a84747dd8 100755 --- a/basis/game-input/dinput/keys-array/keys-array.factor +++ b/basis/game-input/dinput/keys-array/keys-array.factor @@ -2,13 +2,15 @@ USING: sequences sequences.private math alien.c-types accessors ; IN: game-input.dinput.keys-array -TUPLE: keys-array underlying ; +TUPLE: keys-array + { underlying sequence read-only } + { length integer read-only } ; C: keys-array : >key ( byte -- ? ) HEX: 80 bitand c-bool> ; -M: keys-array length underlying>> length ; +M: keys-array length length>> ; M: keys-array nth-unsafe underlying>> nth-unsafe >key ; INSTANCE: keys-array sequence diff --git a/basis/io/files/info/unix/freebsd/freebsd.factor b/basis/io/files/info/unix/freebsd/freebsd.factor index 079dac23a9..baae14a30f 100644 --- a/basis/io/files/info/unix/freebsd/freebsd.factor +++ b/basis/io/files/info/unix/freebsd/freebsd.factor @@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.syntax combinators io.backend io.files io.files.info io.files.unix kernel math system unix unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd sequences grouping alien.strings io.encodings.utf8 unix.types -arrays io.files.info.unix classes.struct ; +arrays io.files.info.unix classes.struct struct-arrays ; IN: io.files.info.unix.freebsd TUPLE: freebsd-file-system-info < unix-file-system-info @@ -40,7 +40,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf } cleave ; M: freebsd file-system-statvfs ( path -- byte-array ) - \ statvfs [ \ statvfs io-error ] keep ; + \ statvfs [ statvfs io-error ] keep ; M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info ) { @@ -50,6 +50,6 @@ M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in M: freebsd file-systems ( -- array ) f 0 0 getfsstat dup io-error - \ statfs dup dup length 0 getfsstat io-error - statfs heap-size group - [ f_mntonname>> alien>native-string file-system-info ] map ; + \ statfs + [ dup length 0 getfsstat io-error ] + [ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ; diff --git a/basis/io/files/info/unix/netbsd/netbsd.factor b/basis/io/files/info/unix/netbsd/netbsd.factor old mode 100644 new mode 100755 index d2e7bc9d6b..65c2d1d03c --- a/basis/io/files/info/unix/netbsd/netbsd.factor +++ b/basis/io/files/info/unix/netbsd/netbsd.factor @@ -4,7 +4,7 @@ USING: alien.syntax kernel unix.stat math unix combinators system io.backend accessors alien.c-types io.encodings.utf8 alien.strings unix.types io.files.unix io.files io.files.info unix.statvfs.netbsd unix.getfsstat.netbsd arrays -grouping sequences io.encodings.utf8 classes.struct +grouping sequences io.encodings.utf8 classes.struct struct-arrays io.files.info.unix ; IN: io.files.info.unix.netbsd @@ -47,6 +47,6 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf M: netbsd file-systems ( -- array ) f 0 0 getvfsstat dup io-error - \ statvfs dup dup length 0 getvfsstat io-error - \ statvfs heap-size group - [ f_mntonname>> utf8 alien>string file-system-info ] map ; + \ statvfs + [ dup length 0 getvfsstat io-error ] + [ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ; diff --git a/basis/io/files/info/unix/openbsd/openbsd.factor b/basis/io/files/info/unix/openbsd/openbsd.factor old mode 100644 new mode 100755 index 6c334b8d62..3cf2863713 --- a/basis/io/files/info/unix/openbsd/openbsd.factor +++ b/basis/io/files/info/unix/openbsd/openbsd.factor @@ -4,7 +4,8 @@ USING: accessors alien.c-types alien.strings alien.syntax combinators io.backend io.files io.files.info io.files.unix kernel math sequences system unix unix.getfsstat.openbsd grouping unix.statfs.openbsd unix.statvfs.openbsd unix.types -arrays io.files.info.unix classes.struct ; +arrays io.files.info.unix classes.struct struct-arrays +io.encodings.utf8 ; IN: io.files.unix.openbsd TUPLE: freebsd-file-system-info < unix-file-system-info @@ -34,9 +35,9 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info [ f_fsid>> >>id ] [ f_namemax>> >>name-max ] [ f_owner>> >>owner ] - [ f_fstypename>> alien>native-string >>type ] - [ f_mntonname>> alien>native-string >>mount-point ] - [ f_mntfromname>> alien>native-string >>device-name ] + [ f_fstypename>> utf8 alien>string >>type ] + [ f_mntonname>> utf8 alien>string >>mount-point ] + [ f_mntfromname>> utf8 alien>string >>device-name ] } cleave ; M: openbsd file-system-statvfs ( normalized-path -- statvfs ) @@ -47,6 +48,6 @@ M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in M: openbsd file-systems ( -- seq ) f 0 0 getfsstat dup io-error - \ statfs dup dup length 0 getfsstat io-error - \ statfs heap-size group - [ f_mntonname>> alien>native-string file-system-info ] map ; + \ statfs + [ dup length 0 getfsstat io-error ] + [ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ; diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 052f5058d2..7ecd46f7e7 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -98,11 +98,11 @@ M: windows link-info ( path -- info ) file-info ; : volume-information ( normalized-path -- volume-name volume-serial max-component flags type ) - MAX_PATH 1 + [ ] keep + MAX_PATH 1 + [ ] keep "DWORD" "DWORD" "DWORD" - MAX_PATH 1 + [ ] keep + MAX_PATH 1 + [ ] keep [ GetVolumeInformation win32-error=0/f ] 7 nkeep drop 5 nrot drop [ utf16n alien>string ] 4 ndip @@ -154,13 +154,13 @@ M: winnt file-system-info ( path -- file-system-info ) ] if ; : find-first-volume ( -- string handle ) - MAX_PATH 1 + [ ] keep + MAX_PATH 1 + [ ] keep dupd FindFirstVolume dup win32-error=0/f [ utf16n alien>string ] dip ; : find-next-volume ( handle -- string/f ) - MAX_PATH 1 + [ tuck ] keep + MAX_PATH 1 + [ tuck ] keep FindNextVolume 0 = [ GetLastError ERROR_NO_MORE_FILES = [ drop f ] [ win32-error-string throw ] if diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index 1882ccd0d5..a7ee79f210 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -132,7 +132,7 @@ M: blas-matrix-base clone ! XXX try rounding stride to next 128 bit bound for better vectorizin' : ( rows cols exemplar -- matrix ) - [ element-type [ * ] dip ] + [ element-type heap-size * * ] [ 2drop ] [ f swap (blas-matrix-like) ] 3tri ; diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 3017a12b18..dd80b50f90 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -99,12 +99,12 @@ PRIVATE> length v inc>> v (blas-vector-like) ; : ( exemplar -- zero ) - [ element-type ] + [ element-type heap-size ] [ length>> 0 ] [ (blas-vector-like) ] tri ; : ( length exemplar -- vector ) - [ element-type ] + [ element-type heap-size * ] [ 1 swap ] 2bi (blas-vector-like) ; diff --git a/basis/pango/layouts/layouts.factor b/basis/pango/layouts/layouts.factor index 88c6f17093..7a7bd86aea 100644 --- a/basis/pango/layouts/layouts.factor +++ b/basis/pango/layouts/layouts.factor @@ -5,7 +5,7 @@ USING: arrays sequences alien alien.c-types alien.destructors alien.syntax math math.functions math.vectors destructors combinators colors fonts accessors assocs namespaces kernel pango pango.fonts pango.cairo cairo cairo.ffi glib unicode.data images cache init -math.rectangles fry memoize io.encodings.utf8 ; +math.rectangles fry memoize io.encodings.utf8 classes.struct ; IN: pango.layouts LIBRARY: pango @@ -84,8 +84,8 @@ SYMBOL: dpi [ set-layout-text ] keep ; : layout-extents ( layout -- ink-rect logical-rect ) - "PangoRectangle" - "PangoRectangle" + PangoRectangle + PangoRectangle [ pango_layout_get_extents ] 2keep [ PangoRectangle>rect ] bi@ ; diff --git a/basis/pango/pango.factor b/basis/pango/pango.factor index ec5afa3c3d..11e15ae951 100644 --- a/basis/pango/pango.factor +++ b/basis/pango/pango.factor @@ -2,7 +2,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license USING: arrays system alien.destructors alien.c-types alien.syntax alien -combinators math.rectangles kernel math alien.libraries ; +combinators math.rectangles kernel math alien.libraries classes.struct +accessors ; IN: pango ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -25,13 +26,13 @@ CONSTANT: PANGO_SCALE 1024 FUNCTION: PangoContext* pango_context_new ( ) ; -C-STRUCT: PangoRectangle - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } ; +STRUCT: PangoRectangle + { x int } + { y int } + { width int } + { height int } ; : PangoRectangle>rect ( PangoRectangle -- rect ) - [ [ PangoRectangle-x pango>float ] [ PangoRectangle-y pango>float ] bi 2array ] - [ [ PangoRectangle-width pango>float ] [ PangoRectangle-height pango>float ] bi 2array ] bi + [ [ x>> pango>float ] [ y>> pango>float ] bi 2array ] + [ [ width>> pango>float ] [ height>> pango>float ] bi 2array ] bi ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 247067673e..76cf8806f4 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -1,10 +1,11 @@ ! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays byte-arrays byte-vectors generic hashtables -assocs kernel math namespaces make sequences strings sbufs vectors -words prettyprint.config prettyprint.custom prettyprint.sections -quotations io io.pathnames io.styles math.parser effects classes.tuple -math.order classes.tuple.private classes combinators colors ; +USING: accessors arrays byte-arrays byte-vectors continuations +generic hashtables assocs kernel math namespaces make sequences +strings sbufs vectors words prettyprint.config prettyprint.custom +prettyprint.sections quotations io io.pathnames io.styles math.parser +effects classes.tuple math.order classes.tuple.private classes +combinators colors ; IN: prettyprint.backend M: effect pprint* effect>string "(" ")" surround text ; @@ -153,6 +154,15 @@ M: pathname pprint* M: tuple pprint* pprint-tuple ; +: recover-pprint ( try recovery -- ) + pprinter-stack get clone + [ pprinter-stack set ] curry prepose recover ; inline + +: pprint-c-object ( object content-quot pointer-quot -- ) + [ c-object-pointers? get ] 2dip + [ nip ] + [ [ drop ] prepose [ recover-pprint ] 2curry ] 2bi if ; inline + : do-length-limit ( seq -- trimmed n/f ) length-limit get dup [ over length over [-] diff --git a/basis/prettyprint/config/config-docs.factor b/basis/prettyprint/config/config-docs.factor index dda565d5c9..1dcb1b5617 100644 --- a/basis/prettyprint/config/config-docs.factor +++ b/basis/prettyprint/config/config-docs.factor @@ -23,5 +23,8 @@ HELP: string-limit? { $var-description "Toggles whether printed strings are truncated to the margin." } ; HELP: boa-tuples? -{ $var-description "Toggles whether tuples print in BOA-form or assoc-form." } +{ $var-description "Toggles whether tuples and structs print in BOA-form or assoc-form." } { $notes "See " { $link POSTPONE: T{ } " for a description of both literal tuple forms." } ; + +HELP: c-object-pointers? +{ $var-description "Toggles whether C objects such as structs and direct arrays only print their underlying address. If this flag isn't set, C objects will attempt to print their contents. If a C object points to invalid memory, it will display only its address regardless." } ; diff --git a/basis/prettyprint/config/config.factor b/basis/prettyprint/config/config.factor index d986791f94..d42b134d4c 100644 --- a/basis/prettyprint/config/config.factor +++ b/basis/prettyprint/config/config.factor @@ -13,6 +13,7 @@ SYMBOL: length-limit SYMBOL: line-limit SYMBOL: string-limit? SYMBOL: boa-tuples? +SYMBOL: c-object-pointers? 4 tab-size set-global 64 margin set-global diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index fbbece4602..7c114f2e22 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -30,6 +30,7 @@ ARTICLE: "prettyprint-variables" "Prettyprint control variables" { $subsection line-limit } { $subsection string-limit? } { $subsection boa-tuples? } +{ $subsection c-object-pointers? } "Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables." { $warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope." diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 2ba436cd58..5731fd8c17 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -2,9 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: functors sequences sequences.private kernel words classes math alien alien.c-types byte-arrays accessors -specialized-arrays prettyprint.custom ; +specialized-arrays parser +prettyprint.backend prettyprint.custom prettyprint.sections ; IN: specialized-arrays.direct.functor +> ] [ length>> ] bi [ pprint* ] bi@ ] pprint-prefix ; + +PRIVATE> + FUNCTOR: define-direct-array ( T -- ) A' IS ${T}-array @@ -15,6 +23,7 @@ A'{ IS ${A'}{ A DEFINES-CLASS direct-${T}-array DEFINES <${A}> +A'@ DEFINES ${A'}@ NTH [ T dup c-type-getter-boxer array-accessor ] SET-NTH [ T dup c-setter array-accessor ] @@ -34,11 +43,17 @@ M: A new-sequence drop ; inline M: A byte-length length>> T heap-size * ; inline +SYNTAX: A'@ + scan-object scan-object parsed ; + M: A pprint-delims drop \ A'{ \ } ; M: A >pprint-sequence ; -M: A pprint* pprint-object ; +M: A pprint* + [ pprint-object ] + [ \ A'@ pprint-direct-array ] + pprint-c-object ; INSTANCE: A sequence INSTANCE: A S diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index f5aca7fb95..df1c938d03 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -10,10 +10,10 @@ ERROR: bad-byte-array-length byte-array type ; M: bad-byte-array-length summary drop "Byte array length doesn't divide type width" ; -: (c-array) ( n c-type -- array ) +: (underlying) ( n c-type -- array ) heap-size * (byte-array) ; inline -: ( n type -- array ) +: ( n type -- array ) heap-size * ; inline FUNCTOR: define-array ( T -- ) @@ -37,9 +37,9 @@ TUPLE: A { length array-capacity read-only } { underlying byte-array read-only } ; -: ( n -- specialized-array ) dup T A boa ; inline +: ( n -- specialized-array ) dup T A boa ; inline -: (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline +: (A) ( n -- specialized-array ) dup T (underlying) A boa ; inline : byte-array>A ( byte-array -- specialized-array ) dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless @@ -86,6 +86,7 @@ A T c-type-boxed-class specialize-vector-words T c-type \ A >>array-class \ >>array-constructor + \ (A) >>(array)-constructor \ S >>sequence-mixin-class drop diff --git a/basis/struct-arrays/prettyprint/prettyprint.factor b/basis/struct-arrays/prettyprint/prettyprint.factor index 352def9055..77fb6847a0 100644 --- a/basis/struct-arrays/prettyprint/prettyprint.factor +++ b/basis/struct-arrays/prettyprint/prettyprint.factor @@ -1,6 +1,6 @@ ! (c)Joe Groff bsd license USING: accessors arrays kernel prettyprint.backend -prettyprint.custom sequences struct-arrays ; +prettyprint.custom prettyprint.sections sequences struct-arrays ; IN: struct-arrays.prettyprint M: struct-array pprint-delims @@ -9,5 +9,12 @@ M: struct-array pprint-delims M: struct-array >pprint-sequence [ >array ] [ class>> ] bi prefix ; -M: struct-array pprint* pprint-object ; +: pprint-struct-array-pointer ( struct-array -- ) + \ struct-array@ + [ [ class>> pprint-word ] [ underlying>> pprint* ] [ length>> pprint* ] tri ] + pprint-prefix ; + +M: struct-array pprint* + [ pprint-object ] + [ pprint-struct-array-pointer ] pprint-c-object ; diff --git a/basis/struct-arrays/struct-arrays-docs.factor b/basis/struct-arrays/struct-arrays-docs.factor index 0a627f7538..7b49d6ef42 100644 --- a/basis/struct-arrays/struct-arrays-docs.factor +++ b/basis/struct-arrays/struct-arrays-docs.factor @@ -1,5 +1,5 @@ IN: struct-arrays -USING: help.markup help.syntax alien strings math ; +USING: classes.struct help.markup help.syntax alien strings math multiline ; HELP: struct-array { $class-description "The class of C struct and union arrays." @@ -14,10 +14,38 @@ HELP: { $values { "alien" c-ptr } { "length" integer } { "c-type" string } { "struct-array" struct-array } } { $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ; +HELP: struct-array-on +{ $value { "struct" struct } { "length" integer } } +{ $description "Create a new array for holding values of " { $snippet "struct" } "'s C type, backed by the memory starting at " { $snippet "struct" } "'s address." } +{ $examples +"This word is useful with the FFI. When a C function has a pointer to a struct as its return type (or a C callback has a struct pointer as an argument type), Factor automatically wraps the pointer in a " { $link struct } " object. If the pointer actually references an array of objects, this word will convert the struct object to a struct array object:" +{ $code <" USING: alien.syntax classes.struct struct-arrays ; +IN: scratchpad + +STRUCT: zim { zang int } { zung int } ; + +FUNCTION: zim* zingle ( ) ; ! Returns a pointer to 20 zims + +zingle 20 struct-array-on "> } +} ; + +HELP: struct-array{ +{ $syntax "struct-array{ class value value value ... }" } +{ $description "Literal syntax for a " { $link struct-array } " containing structs of the given " { $link struct } " class." } ; + +HELP: struct-array@ +{ $syntax "struct-array@ class alien length" } +{ $description "Literal syntax for a " { $link struct-array } " at a particular memory address. The prettyprinter uses this syntax when the memory backing a struct array object is invalid. This syntax should not generally be used in source code." } ; + +{ POSTPONE: struct-array{ POSTPONE: struct-array@ } related-words + ARTICLE: "struct-arrays" "C struct and union arrays" "The " { $vocab-link "struct-arrays" } " vocabulary implements arrays specialized for holding C struct and union values." { $subsection struct-array } { $subsection } -{ $subsection } ; +{ $subsection } +{ $subsection struct-array-on } +"Struct arrays have literal syntax:" +{ $subsection POSTPONE: struct-array{ } ; ABOUT: "struct-arrays" diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index a3dcd98f0e..cc34072d2c 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.structs byte-arrays -classes.struct kernel libc math parser sequences sequences.private ; +classes classes.struct kernel libc math parser sequences +sequences.private words fry memoize compiler.units ; IN: struct-arrays : c-type-struct-class ( c-type -- class ) @@ -11,7 +12,8 @@ TUPLE: struct-array { underlying c-ptr read-only } { length array-capacity read-only } { element-size array-capacity read-only } -{ class read-only } ; +{ class read-only } +{ ctor read-only } ; M: struct-array length length>> ; inline M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline @@ -20,47 +22,65 @@ M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline [ element-size>> * >fixnum ] [ underlying>> ] bi ; inline M: struct-array nth-unsafe - [ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline + [ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline M: struct-array set-nth-unsafe [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline +: (struct-element-constructor) ( c-type -- word ) + [ + "struct-array-ctor" f + [ + swap dup struct-class? + [ '[ _ memory>struct ] [ ] like ] [ drop [ ] ] if + (( alien -- object )) define-inline + ] keep + ] with-compilation-unit ; + +! Foldable memo word. This is an optimization; by precompiling a +! constructor for array elements, we avoid memory>struct's slow path. +MEMO: struct-element-constructor ( c-type -- word ) + (struct-element-constructor) ; foldable + +: ( alien length c-type -- struct-array ) + [ heap-size ] [ c-type-struct-class ] [ struct-element-constructor ] + tri struct-array boa ; inline + M: struct-array new-sequence - [ element-size>> [ * (byte-array) ] 2keep ] - [ class>> ] bi struct-array boa ; inline + [ element-size>> * (byte-array) ] [ length>> ] [ class>> ] tri + ; inline M: struct-array resize ( n seq -- newseq ) - [ [ element-size>> * ] [ underlying>> ] bi resize ] - [ [ element-size>> ] [ class>> ] bi ] 2bi - struct-array boa ; + [ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi + ; inline : ( length c-type -- struct-array ) - [ heap-size [ * ] 2keep ] - [ c-type-struct-class ] bi struct-array boa ; inline + [ heap-size * ] 2keep ; inline ERROR: bad-byte-array-length byte-array ; : byte-array>struct-array ( byte-array c-type -- struct-array ) - [ heap-size [ + [ + heap-size [ dup length ] dip /mod 0 = [ drop bad-byte-array-length ] unless - ] keep ] [ c-type-struct-class ] bi struct-array boa ; inline + ] keep ; inline -: ( alien length c-type -- struct-array ) - [ heap-size ] [ c-type-struct-class ] bi struct-array boa ; inline +: struct-array-on ( struct length -- struct-array ) + [ [ >c-ptr ] [ class ] bi ] dip swap ; inline : malloc-struct-array ( length c-type -- struct-array ) [ heap-size calloc ] 2keep ; inline INSTANCE: struct-array sequence -M: struct-type ( len c-type -- array ) - dup c-type-array-constructor +M: struct-type ( len c-type -- array ) + dup c-array-constructor [ execute( len -- array ) ] [ ] ?if ; inline -M: struct-type ( alien len c-type -- array ) - dup c-type-direct-array-constructor +M: struct-type ( alien len c-type -- array ) + dup c-direct-array-constructor [ execute( alien len -- array ) ] [ ] ?if ; inline @@ -71,6 +91,9 @@ M: struct-type ( alien len c-type -- array ) SYNTAX: struct-array{ \ } scan-word [ >struct-array ] curry parse-literal ; +SYNTAX: struct-array@ + scan-word [ scan-object scan-object ] dip parsed ; + USING: vocabs vocabs.loader ; "prettyprint" vocab [ "struct-arrays.prettyprint" require ] when diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 6a133d9c87..2244eb9249 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -68,9 +68,14 @@ IN: tools.deploy.shaker ] when ; : strip-destructors ( -- ) - "libc" vocab [ - "Stripping destructor debug code" show - "vocab:tools/deploy/shaker/strip-destructors.factor" + "Stripping destructor debug code" show + "vocab:tools/deploy/shaker/strip-destructors.factor" + run-file ; + +: strip-struct-arrays ( -- ) + "struct-arrays" vocab [ + "Stripping dynamic struct array code" show + "vocab:tools/deploy/shaker/strip-struct-arrays.factor" run-file ] when ; @@ -493,6 +498,7 @@ SYMBOL: deploy-vocab : strip ( -- ) init-stripper strip-libc + strip-struct-arrays strip-destructors strip-call strip-cocoa diff --git a/basis/tools/deploy/shaker/strip-call.factor b/basis/tools/deploy/shaker/strip-call.factor index d0593b6c15..0ecc22e4c0 100644 --- a/basis/tools/deploy/shaker/strip-call.factor +++ b/basis/tools/deploy/shaker/strip-call.factor @@ -1,10 +1,14 @@ ! Copyright (C) 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -IN: tools.deploy.shaker.call - +USING: combinators.private kernel ; IN: combinators -USE: combinators.private -: call-effect ( word effect -- ) call-effect-unsafe ; inline +: call-effect ( word effect -- ) call-effect-unsafe ; -: execute-effect ( word effect -- ) execute-effect-unsafe ; inline \ No newline at end of file +: execute-effect ( word effect -- ) execute-effect-unsafe ; + +IN: compiler.tree.propagation.call-effect + +: call-effect-unsafe? ( quot effect -- ? ) 2drop t ; inline + +: execute-effect-unsafe? ( word effect -- ? ) 2drop t ; inline \ No newline at end of file diff --git a/basis/tools/deploy/shaker/strip-struct-arrays.factor b/basis/tools/deploy/shaker/strip-struct-arrays.factor new file mode 100644 index 0000000000..55b6630082 --- /dev/null +++ b/basis/tools/deploy/shaker/strip-struct-arrays.factor @@ -0,0 +1,13 @@ +USING: kernel stack-checker.transforms ; +IN: struct-arrays + +: struct-element-constructor ( c-type -- word ) + "Struct array usages must be compiled" throw ; + +<< + +\ struct-element-constructor [ + (struct-element-constructor) [ ] curry +] 1 define-transform + +>> \ No newline at end of file diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index cf4966b756..fd06b2cb76 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -614,8 +614,8 @@ M: windows-ui-backend do-events : default-position-RECT ( RECT -- RECT' ) dup get-RECT-width/height - [ CW_USEDEFAULT + >>bottom ] dip - CW_USEDEFAULT + >>right + [ CW_USEDEFAULT + >>right ] dip + CW_USEDEFAULT + >>bottom CW_USEDEFAULT >>left CW_USEDEFAULT >>top ; @@ -758,7 +758,7 @@ M: windows-ui-backend beep ( -- ) : client-area>RECT ( hwnd -- RECT ) RECT [ GetClientRect win32-error=0/f ] - [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ] + [ >c-ptr "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ] [ nip ] 2tri ; : hwnd>RECT ( hwnd -- RECT ) diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index bb0f9b5201..dd45a42d3e 100644 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax combinators system vocabs.loader ; +USING: alien.syntax classes.struct combinators system +vocabs.loader ; IN: unix CONSTANT: MAXPATHLEN 1024 @@ -46,18 +47,18 @@ C-STRUCT: sockaddr-un { "uchar" "family" } { { "char" 104 } "path" } ; -C-STRUCT: passwd - { "char*" "pw_name" } - { "char*" "pw_passwd" } - { "uid_t" "pw_uid" } - { "gid_t" "pw_gid" } - { "time_t" "pw_change" } - { "char*" "pw_class" } - { "char*" "pw_gecos" } - { "char*" "pw_dir" } - { "char*" "pw_shell" } - { "time_t" "pw_expire" } - { "int" "pw_fields" } ; +STRUCT: passwd + { pw_name char* } + { pw_passwd char* } + { pw_uid uid_t } + { pw_gid gid_t } + { pw_change time_t } + { pw_class char* } + { pw_gecos char* } + { pw_dir char* } + { pw_shell char* } + { pw_expire time_t } + { pw_fields int } ; CONSTANT: max-un-path 104 diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index eba0e4976f..c4392c4c6d 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -1,12 +1,14 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings io.encodings.utf8 -io.backend.unix kernel math sequences splitting unix strings +io.backend.unix kernel math sequences splitting strings combinators.short-circuit byte-arrays combinators accessors math.parser fry assocs namespaces continuations -unix.users unix.utilities ; +unix.users unix.utilities classes.struct ; IN: unix.groups +QUALIFIED: unix + QUALIFIED: grouping TUPLE: group id name passwd members ; @@ -18,27 +20,27 @@ GENERIC: group-struct ( obj -- group/f ) strings ; + gr_mem>> utf8 alien>strings ; : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) - "group" tuck 4096 + \ unix:group tuck 4096 [ ] keep f ; : check-group-struct ( group-struct ptr -- group-struct/f ) *void* [ drop f ] unless ; M: integer group-struct ( id -- group/f ) - (group-struct) [ getgrgid_r io-error ] keep check-group-struct ; + (group-struct) [ unix:getgrgid_r unix:io-error ] keep check-group-struct ; M: string group-struct ( string -- group/f ) - (group-struct) [ getgrnam_r io-error ] keep check-group-struct ; + (group-struct) [ unix:getgrnam_r unix:io-error ] keep check-group-struct ; : group-struct>group ( group-struct -- group ) [ \ group new ] dip { - [ group-gr_name >>name ] - [ group-gr_passwd >>passwd ] - [ group-gr_gid >>id ] + [ gr_name>> >>name ] + [ gr_passwd>> >>passwd ] + [ gr_gid>> >>id ] [ group-members >>members ] } cleave ; @@ -48,12 +50,12 @@ PRIVATE> dup group-cache get [ ?at [ name>> ] [ number>string ] if ] [ - group-struct [ group-gr_name ] [ f ] if* + group-struct [ gr_name>> ] [ f ] if* ] if* [ nip ] [ number>string ] if* ; : group-id ( string -- id/f ) - group-struct [ group-gr_gid ] [ f ] if* ; + group-struct [ gr_gid>> ] [ f ] if* ; : (user-groups) ( string -- seq ) #! first group is -1337, legacy unix code - -1337 NGROUPS_MAX [ 4 * ] keep - [ getgrouplist io-error ] 2keep + -1337 unix:NGROUPS_MAX [ 4 * ] keep + [ unix:getgrouplist unix:io-error ] 2keep [ 4 tail-slice ] [ *int 1 - ] bi* >groups ; PRIVATE> @@ -77,7 +79,7 @@ M: integer user-groups ( id -- seq ) user-name (user-groups) ; : all-groups ( -- seq ) - [ getgrent dup ] [ group-struct>group ] produce nip ; + [ unix:getgrent dup ] [ \ unix:group memory>struct group-struct>group ] produce nip ; : ( -- assoc ) all-groups [ [ id>> ] keep ] H{ } map>assoc ; @@ -85,14 +87,11 @@ M: integer user-groups ( id -- seq ) : with-group-cache ( quot -- ) [ group-cache ] dip with-variable ; inline -: real-group-id ( -- id ) - getgid ; inline +: real-group-id ( -- id ) unix:getgid ; inline -: real-group-name ( -- string ) - real-group-id group-name ; inline +: real-group-name ( -- string ) real-group-id group-name ; inline -: effective-group-id ( -- string ) - getegid ; inline +: effective-group-id ( -- string ) unix:getegid ; inline : effective-group-name ( -- string ) effective-group-id group-name ; inline @@ -112,10 +111,10 @@ GENERIC: set-effective-group ( obj -- ) diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 31789baf1c..5b1a41f21f 100644 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -84,14 +84,14 @@ CONSTANT: SEEK_SET 0 CONSTANT: SEEK_CUR 1 CONSTANT: SEEK_END 2 -C-STRUCT: passwd - { "char*" "pw_name" } - { "char*" "pw_passwd" } - { "uid_t" "pw_uid" } - { "gid_t" "pw_gid" } - { "char*" "pw_gecos" } - { "char*" "pw_dir" } - { "char*" "pw_shell" } ; +STRUCT: passwd + { pw_name char* } + { pw_passwd char* } + { pw_uid uid_t } + { pw_gid gid_t } + { pw_gecos char* } + { pw_dir char* } + { pw_shell char* } ; ! dirent64 STRUCT: dirent diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 9c4251dd1e..59a3331354 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -5,7 +5,7 @@ USING: alien alien.c-types alien.syntax kernel libc sequences continuations byte-arrays strings math namespaces system combinators vocabs.loader accessors stack-checker macros locals generalizations unix.types -io vocabs ; +io vocabs classes.struct ; IN: unix CONSTANT: PROT_NONE 0 @@ -35,11 +35,11 @@ CONSTANT: DT_LNK 10 CONSTANT: DT_SOCK 12 CONSTANT: DT_WHT 14 -C-STRUCT: group - { "char*" "gr_name" } - { "char*" "gr_passwd" } - { "int" "gr_gid" } - { "char**" "gr_mem" } ; +STRUCT: group + { gr_name char* } + { gr_passwd char* } + { gr_gid int } + { gr_mem char** } ; LIBRARY: libc @@ -147,19 +147,19 @@ M: unix open-file [ open ] unix-system-call ; FUNCTION: DIR* opendir ( char* path ) ; -C-STRUCT: utimbuf - { "time_t" "actime" } - { "time_t" "modtime" } ; +STRUCT: utimbuf + { actime time_t } + { modtime time_t } ; -FUNCTION: int utime ( char* path, utimebuf* buf ) ; +FUNCTION: int utime ( char* path, utimbuf* buf ) ; : touch ( filename -- ) f [ utime ] unix-system-call drop ; : change-file-times ( filename access modification -- ) - "utimebuf" - [ set-utimbuf-modtime ] keep - [ set-utimbuf-actime ] keep - [ utime ] unix-system-call drop ; + utimbuf + swap >>modtime + swap >>actime + [ utime ] unix-system-call drop ; FUNCTION: int pclose ( void* file ) ; FUNCTION: int pipe ( int* filedes ) ; diff --git a/basis/unix/users/bsd/bsd.factor b/basis/unix/users/bsd/bsd.factor index b3778ced70..2c41a05a7f 100644 --- a/basis/unix/users/bsd/bsd.factor +++ b/basis/unix/users/bsd/bsd.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators accessors kernel unix unix.users +USING: combinators accessors kernel unix.users system ; IN: unix.users.bsd +QUALIFIED: unix TUPLE: bsd-passwd < passwd change class expire fields ; @@ -11,9 +12,9 @@ M: bsd new-passwd ( -- bsd-passwd ) bsd-passwd new ; M: bsd passwd>new-passwd ( passwd -- bsd-passwd ) [ call-next-method ] keep { - [ passwd-pw_change >>change ] - [ passwd-pw_class >>class ] - [ passwd-pw_shell >>shell ] - [ passwd-pw_expire >>expire ] - [ passwd-pw_fields >>fields ] + [ pw_change>> >>change ] + [ pw_class>> >>class ] + [ pw_shell>> >>shell ] + [ pw_expire>> >>expire ] + [ pw_fields>> >>fields ] } cleave ; diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index a523f0818b..09119ff0cc 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings io.encodings.utf8 -io.backend.unix kernel math sequences splitting unix strings +io.backend.unix kernel math sequences splitting strings combinators.short-circuit grouping byte-arrays combinators accessors math.parser fry assocs namespaces continuations -vocabs.loader system ; +vocabs.loader system classes.struct ; IN: unix.users +QUALIFIED: unix TUPLE: passwd user-name password uid gid gecos dir shell ; @@ -20,23 +21,23 @@ M: unix new-passwd ( -- passwd ) M: unix passwd>new-passwd ( passwd -- seq ) [ new-passwd ] dip { - [ passwd-pw_name >>user-name ] - [ passwd-pw_passwd >>password ] - [ passwd-pw_uid >>uid ] - [ passwd-pw_gid >>gid ] - [ passwd-pw_gecos >>gecos ] - [ passwd-pw_dir >>dir ] - [ passwd-pw_shell >>shell ] + [ pw_name>> >>user-name ] + [ pw_passwd>> >>password ] + [ pw_uid>> >>uid ] + [ pw_gid>> >>gid ] + [ pw_gecos>> >>gecos ] + [ pw_dir>> >>dir ] + [ pw_shell>> >>shell ] } cleave ; : with-pwent ( quot -- ) - [ endpwent ] [ ] cleanup ; inline + [ unix:endpwent ] [ ] cleanup ; inline PRIVATE> : all-users ( -- seq ) [ - [ getpwent dup ] [ passwd>new-passwd ] produce nip + [ unix:getpwent dup ] [ unix:passwd memory>struct passwd>new-passwd ] produce nip ] with-pwent ; SYMBOL: user-cache @@ -51,10 +52,10 @@ GENERIC: user-passwd ( obj -- passwd/f ) M: integer user-passwd ( id -- passwd/f ) user-cache get - [ at ] [ getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ; + [ at ] [ unix:getpwuid [ unix:passwd memory>struct passwd>new-passwd ] [ f ] if* ] if* ; M: string user-passwd ( string -- passwd/f ) - getpwnam dup [ passwd>new-passwd ] when ; + unix:getpwnam dup [ unix:passwd memory>struct passwd>new-passwd ] when ; : user-name ( id -- string ) dup user-passwd @@ -64,13 +65,13 @@ M: string user-passwd ( string -- passwd/f ) user-passwd uid>> ; : real-user-id ( -- id ) - getuid ; inline + unix:getuid ; inline : real-user-name ( -- string ) real-user-id user-name ; inline : effective-user-id ( -- id ) - geteuid ; inline + unix:geteuid ; inline : effective-user-name ( -- string ) effective-user-id user-name ; inline @@ -92,10 +93,10 @@ GENERIC: set-effective-user ( string/id -- ) diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 3d78ccc849..2af416fb7e 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -3,7 +3,8 @@ init windows.com.syntax.private windows.com continuations kernel namespaces windows.ole32 libc vocabs assocs accessors arrays sequences quotations combinators math words compiler.units destructors fry math.parser generalizations sets -specialized-arrays.alien specialized-arrays.direct.alien ; +specialized-arrays.alien specialized-arrays.direct.alien +windows.kernel32 ; IN: windows.com.wrapper TUPLE: com-wrapper < disposable callbacks vtbls ; diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index ccc28c00e9..ec70a3cdd6 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -2,7 +2,7 @@ USING: windows.dinput windows.kernel32 windows.ole32 windows.com windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces combinators sequences fry math accessors macros words quotations libc continuations generalizations splitting locals assocs init -struct-arrays memoize ; +struct-arrays memoize classes.struct ; IN: windows.dinput.constants ! Some global variables aren't provided by the DirectInput DLL (they're in the @@ -38,14 +38,6 @@ MEMO: heap-size* ( c-type -- n ) heap-size ; : (flags) ( array -- n ) 0 [ (flag) bitor ] reduce ; -: (DIOBJECTDATAFORMAT) ( pguid dwOfs dwType dwFlags alien -- alien ) - [ { - [ set-DIOBJECTDATAFORMAT-dwFlags ] - [ set-DIOBJECTDATAFORMAT-dwType ] - [ set-DIOBJECTDATAFORMAT-dwOfs ] - [ set-DIOBJECTDATAFORMAT-pguid ] - } cleave ] keep ; - : ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- alien ) { [ first dup word? [ get ] when ] @@ -54,10 +46,10 @@ MEMO: heap-size* ( c-type -- n ) heap-size ; [ fourth (flags) ] [ 4 swap nth (flag) ] } cleave - "DIOBJECTDATAFORMAT" (DIOBJECTDATAFORMAT) ; + DIOBJECTDATAFORMAT ; :: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien ) - [let | alien [ array length "DIOBJECTDATAFORMAT" malloc-struct-array ] | + [let | alien [ array length DIOBJECTDATAFORMAT malloc-struct-array ] | array [| args i | struct args i alien set-nth @@ -65,22 +57,10 @@ MEMO: heap-size* ( c-type -- n ) heap-size ; alien ] ; -: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien ) - [ - { - [ set-DIDATAFORMAT-rgodf ] - [ set-DIDATAFORMAT-dwNumObjs ] - [ set-DIDATAFORMAT-dwDataSize ] - [ set-DIDATAFORMAT-dwFlags ] - [ set-DIDATAFORMAT-dwObjSize ] - [ set-DIDATAFORMAT-dwSize ] - } cleave - ] keep ; - : ( dwFlags dwDataSize struct rgodf-array -- alien ) - [ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip + [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip [ nip length ] [ malloc-DIOBJECTDATAFORMAT-array ] 2bi - "DIDATAFORMAT" (DIDATAFORMAT) ; + DIDATAFORMAT ; : initialize ( symbol quot -- ) call swap set-global ; inline @@ -861,7 +841,7 @@ MEMO: heap-size* ( c-type -- n ) heap-size ; { c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2 - } [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ; + } [ [ rgodf>> free ] uninitialize ] each ; PRIVATE> diff --git a/basis/windows/dinput/dinput.factor b/basis/windows/dinput/dinput.factor index e5e32aac0e..46317ab604 100755 --- a/basis/windows/dinput/dinput.factor +++ b/basis/windows/dinput/dinput.factor @@ -1,5 +1,6 @@ USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax -alien alien.c-types alien.syntax kernel system namespaces math ; +alien alien.c-types alien.syntax kernel system namespaces math +classes.struct ; IN: windows.dinput LIBRARY: dinput @@ -35,291 +36,293 @@ TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW TYPEDEF: DWORD D3DCOLOR -C-STRUCT: DIDEVICEINSTANCEW - { "DWORD" "dwSize" } - { "GUID" "guidInstance" } - { "GUID" "guidProduct" } - { "DWORD" "dwDevType" } - { "WCHAR[260]" "tszInstanceName" } - { "WCHAR[260]" "tszProductName" } - { "GUID" "guidFFDriver" } - { "WORD" "wUsagePage" } - { "WORD" "wUsage" } ; +STRUCT: DIDEVICEINSTANCEW + { dwSize DWORD } + { guidInstance GUID } + { guidProduct GUID } + { dwDevType DWORD } + { tszInstanceName WCHAR[260] } + { tszProductName WCHAR[260] } + { guidFFDriver GUID } + { wUsagePage WORD } + { wUsage WORD } ; TYPEDEF: DIDEVICEINSTANCEW* LPDIDEVICEINSTANCEW TYPEDEF: DIDEVICEINSTANCEW* LPCDIDEVICEINSTANCEW -C-UNION: DIACTION-union "LPCWSTR" "UINT" ; -C-STRUCT: DIACTIONW - { "UINT_PTR" "uAppData" } - { "DWORD" "dwSemantic" } - { "DWORD" "dwFlags" } - { "DIACTION-union" "lptszActionName-or-uResIdString" } - { "GUID" "guidInstance" } - { "DWORD" "dwObjID" } - { "DWORD" "dwHow" } ; +UNION-STRUCT: DIACTION-union + { lptszActionName LPCWSTR } + { uResIdString UINT } ; +STRUCT: DIACTIONW + { uAppData UINT_PTR } + { dwSemantic DWORD } + { dwFlags DWORD } + { union DIACTION-union } + { guidInstance GUID } + { dwObjID DWORD } + { dwHow DWORD } ; TYPEDEF: DIACTIONW* LPDIACTIONW TYPEDEF: DIACTIONW* LPCDIACTIONW -C-STRUCT: DIACTIONFORMATW - { "DWORD" "dwSize" } - { "DWORD" "dwActionSize" } - { "DWORD" "dwDataSize" } - { "DWORD" "dwNumActions" } - { "LPDIACTIONW" "rgoAction" } - { "GUID" "guidActionMap" } - { "DWORD" "dwGenre" } - { "DWORD" "dwBufferSize" } - { "LONG" "lAxisMin" } - { "LONG" "lAxisMax" } - { "HINSTANCE" "hInstString" } - { "FILETIME" "ftTimeStamp" } - { "DWORD" "dwCRC" } - { "WCHAR[260]" "tszActionMap" } ; +STRUCT: DIACTIONFORMATW + { dwSize DWORD } + { dwActionSize DWORD } + { dwDataSize DWORD } + { dwNumActions DWORD } + { rgoAction LPDIACTIONW } + { guidActionMap GUID } + { dwGenre DWORD } + { dwBufferSize DWORD } + { lAxisMin LONG } + { lAxisMax LONG } + { hInstString HINSTANCE } + { ftTimeStamp FILETIME } + { dwCRC DWORD } + { tszActionMap WCHAR[260] } ; TYPEDEF: DIACTIONFORMATW* LPDIACTIONFORMATW TYPEDEF: DIACTIONFORMATW* LPCDIACTIONFORMATW -C-STRUCT: DICOLORSET - { "DWORD" "dwSize" } - { "D3DCOLOR" "cTextFore" } - { "D3DCOLOR" "cTextHighlight" } - { "D3DCOLOR" "cCalloutLine" } - { "D3DCOLOR" "cCalloutHighlight" } - { "D3DCOLOR" "cBorder" } - { "D3DCOLOR" "cControlFill" } - { "D3DCOLOR" "cHighlightFill" } - { "D3DCOLOR" "cAreaFill" } ; +STRUCT: DICOLORSET + { dwSize DWORD } + { cTextFore D3DCOLOR } + { cTextHighlight D3DCOLOR } + { cCalloutLine D3DCOLOR } + { cCalloutHighlight D3DCOLOR } + { cBorder D3DCOLOR } + { cControlFill D3DCOLOR } + { cHighlightFill D3DCOLOR } + { cAreaFill D3DCOLOR } ; TYPEDEF: DICOLORSET* LPDICOLORSET TYPEDEF: DICOLORSET* LPCDICOLORSET -C-STRUCT: DICONFIGUREDEVICESPARAMSW - { "DWORD" "dwSize" } - { "DWORD" "dwcUsers" } - { "LPWSTR" "lptszUserNames" } - { "DWORD" "dwcFormats" } - { "LPDIACTIONFORMATW" "lprgFormats" } - { "HWND" "hwnd" } - { "DICOLORSET" "dics" } - { "IUnknown*" "lpUnkDDSTarget" } ; +STRUCT: DICONFIGUREDEVICESPARAMSW + { dwSize DWORD } + { dwcUsers DWORD } + { lptszUserNames LPWSTR } + { dwcFormats DWORD } + { lprgFormats LPDIACTIONFORMATW } + { hwnd HWND } + { dics DICOLORSET } + { lpUnkDDSTarget IUnknown* } ; TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW -C-STRUCT: DIDEVCAPS - { "DWORD" "dwSize" } - { "DWORD" "dwFlags" } - { "DWORD" "dwDevType" } - { "DWORD" "dwAxes" } - { "DWORD" "dwButtons" } - { "DWORD" "dwPOVs" } - { "DWORD" "dwFFSamplePeriod" } - { "DWORD" "dwFFMinTimeResolution" } - { "DWORD" "dwFirmwareRevision" } - { "DWORD" "dwHardwareRevision" } - { "DWORD" "dwFFDriverVersion" } ; +STRUCT: DIDEVCAPS + { dwSize DWORD } + { dwFlags DWORD } + { dwDevType DWORD } + { dwAxes DWORD } + { dwButtons DWORD } + { dwPOVs DWORD } + { dwFFSamplePeriod DWORD } + { dwFFMinTimeResolution DWORD } + { dwFirmwareRevision DWORD } + { dwHardwareRevision DWORD } + { dwFFDriverVersion DWORD } ; TYPEDEF: DIDEVCAPS* LPDIDEVCAPS TYPEDEF: DIDEVCAPS* LPCDIDEVCAPS -C-STRUCT: DIDEVICEOBJECTINSTANCEW - { "DWORD" "dwSize" } - { "GUID" "guidType" } - { "DWORD" "dwOfs" } - { "DWORD" "dwType" } - { "DWORD" "dwFlags" } - { "WCHAR[260]" "tszName" } - { "DWORD" "dwFFMaxForce" } - { "DWORD" "dwFFForceResolution" } - { "WORD" "wCollectionNumber" } - { "WORD" "wDesignatorIndex" } - { "WORD" "wUsagePage" } - { "WORD" "wUsage" } - { "DWORD" "dwDimension" } - { "WORD" "wExponent" } - { "WORD" "wReportId" } ; +STRUCT: DIDEVICEOBJECTINSTANCEW + { dwSize DWORD } + { guidType GUID } + { dwOfs DWORD } + { dwType DWORD } + { dwFlags DWORD } + { tszName WCHAR[260] } + { dwFFMaxForce DWORD } + { dwFFForceResolution DWORD } + { wCollectionNumber WORD } + { wDesignatorIndex WORD } + { wUsagePage WORD } + { wUsage WORD } + { dwDimension DWORD } + { wExponent WORD } + { wReportId WORD } ; TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPDIDEVICEOBJECTINSTANCEW TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPCDIDEVICEOBJECTINSTANCEW -C-STRUCT: DIDEVICEOBJECTDATA - { "DWORD" "dwOfs" } - { "DWORD" "dwData" } - { "DWORD" "dwTimeStamp" } - { "DWORD" "dwSequence" } - { "UINT_PTR" "uAppData" } ; +STRUCT: DIDEVICEOBJECTDATA + { dwOfs DWORD } + { dwData DWORD } + { dwTimeStamp DWORD } + { dwSequence DWORD } + { uAppData UINT_PTR } ; TYPEDEF: DIDEVICEOBJECTDATA* LPDIDEVICEOBJECTDATA TYPEDEF: DIDEVICEOBJECTDATA* LPCDIDEVICEOBJECTDATA -C-STRUCT: DIOBJECTDATAFORMAT - { "GUID*" "pguid" } - { "DWORD" "dwOfs" } - { "DWORD" "dwType" } - { "DWORD" "dwFlags" } ; +STRUCT: DIOBJECTDATAFORMAT + { pguid GUID* } + { dwOfs DWORD } + { dwType DWORD } + { dwFlags DWORD } ; TYPEDEF: DIOBJECTDATAFORMAT* LPDIOBJECTDATAFORMAT TYPEDEF: DIOBJECTDATAFORMAT* LPCDIOBJECTDATAFORMAT -C-STRUCT: DIDATAFORMAT - { "DWORD" "dwSize" } - { "DWORD" "dwObjSize" } - { "DWORD" "dwFlags" } - { "DWORD" "dwDataSize" } - { "DWORD" "dwNumObjs" } - { "LPDIOBJECTDATAFORMAT" "rgodf" } ; +STRUCT: DIDATAFORMAT + { dwSize DWORD } + { dwObjSize DWORD } + { dwFlags DWORD } + { dwDataSize DWORD } + { dwNumObjs DWORD } + { rgodf LPDIOBJECTDATAFORMAT } ; TYPEDEF: DIDATAFORMAT* LPDIDATAFORMAT TYPEDEF: DIDATAFORMAT* LPCDIDATAFORMAT -C-STRUCT: DIPROPHEADER - { "DWORD" "dwSize" } - { "DWORD" "dwHeaderSize" } - { "DWORD" "dwObj" } - { "DWORD" "dwHow" } ; +STRUCT: DIPROPHEADER + { dwSize DWORD } + { dwHeaderSize DWORD } + { dwObj DWORD } + { dwHow DWORD } ; TYPEDEF: DIPROPHEADER* LPDIPROPHEADER TYPEDEF: DIPROPHEADER* LPCDIPROPHEADER -C-STRUCT: DIPROPDWORD - { "DIPROPHEADER" "diph" } - { "DWORD" "dwData" } ; +STRUCT: DIPROPDWORD + { diph DIPROPHEADER } + { dwData DWORD } ; TYPEDEF: DIPROPDWORD* LPDIPROPDWORD TYPEDEF: DIPROPDWORD* LPCDIPROPDWORD -C-STRUCT: DIPROPPOINTER - { "DIPROPHEADER" "diph" } - { "UINT_PTR" "uData" } ; +STRUCT: DIPROPPOINTER + { diph DIPROPHEADER } + { uData UINT_PTR } ; TYPEDEF: DIPROPPOINTER* LPDIPROPPOINTER TYPEDEF: DIPROPPOINTER* LPCDIPROPPOINTER -C-STRUCT: DIPROPRANGE - { "DIPROPHEADER" "diph" } - { "LONG" "lMin" } - { "LONG" "lMax" } ; +STRUCT: DIPROPRANGE + { diph DIPROPHEADER } + { lMin LONG } + { lMax LONG } ; TYPEDEF: DIPROPRANGE* LPDIPROPRANGE TYPEDEF: DIPROPRANGE* LPCDIPROPRANGE -C-STRUCT: DIPROPCAL - { "DIPROPHEADER" "diph" } - { "LONG" "lMin" } - { "LONG" "lCenter" } - { "LONG" "lMax" } ; +STRUCT: DIPROPCAL + { diph DIPROPHEADER } + { lMin LONG } + { lCenter LONG } + { lMax LONG } ; TYPEDEF: DIPROPCAL* LPDIPROPCAL TYPEDEF: DIPROPCAL* LPCDIPROPCAL -C-STRUCT: DIPROPGUIDANDPATH - { "DIPROPHEADER" "diph" } - { "GUID" "guidClass" } - { "WCHAR[260]" "wszPath" } ; +STRUCT: DIPROPGUIDANDPATH + { diph DIPROPHEADER } + { guidClass GUID } + { wszPath WCHAR[260] } ; TYPEDEF: DIPROPGUIDANDPATH* LPDIPROPGUIDANDPATH TYPEDEF: DIPROPGUIDANDPATH* LPCDIPROPGUIDANDPATH -C-STRUCT: DIPROPSTRING - { "DIPROPHEADER" "diph" } - { "WCHAR[260]" "wsz" } ; +STRUCT: DIPROPSTRING + { diph DIPROPHEADER } + { wsz WCHAR[260] } ; TYPEDEF: DIPROPSTRING* LPDIPROPSTRING TYPEDEF: DIPROPSTRING* LPCDIPROPSTRING -C-STRUCT: CPOINT - { "LONG" "lP" } - { "DWORD" "dwLog" } ; -C-STRUCT: DIPROPCPOINTS - { "DIPROPHEADER" "diph" } - { "DWORD" "dwCPointsNum" } - { "CPOINT[8]" "cp" } ; +STRUCT: CPOINT + { lP LONG } + { dwLog DWORD } ; +STRUCT: DIPROPCPOINTS + { diph DIPROPHEADER } + { dwCPointsNum DWORD } + { cp CPOINT[8] } ; TYPEDEF: DIPROPCPOINTS* LPDIPROPCPOINTS TYPEDEF: DIPROPCPOINTS* LPCDIPROPCPOINTS -C-STRUCT: DIENVELOPE - { "DWORD" "dwSize" } - { "DWORD" "dwAttackLevel" } - { "DWORD" "dwAttackTime" } - { "DWORD" "dwFadeLevel" } - { "DWORD" "dwFadeTime" } ; +STRUCT: DIENVELOPE + { dwSize DWORD } + { dwAttackLevel DWORD } + { dwAttackTime DWORD } + { dwFadeLevel DWORD } + { dwFadeTime DWORD } ; TYPEDEF: DIENVELOPE* LPDIENVELOPE TYPEDEF: DIENVELOPE* LPCDIENVELOPE -C-STRUCT: DIEFFECT - { "DWORD" "dwSize" } - { "DWORD" "dwFlags" } - { "DWORD" "dwDuration" } - { "DWORD" "dwSamplePeriod" } - { "DWORD" "dwGain" } - { "DWORD" "dwTriggerButton" } - { "DWORD" "dwTriggerRepeatInterval" } - { "DWORD" "cAxes" } - { "LPDWORD" "rgdwAxes" } - { "LPLONG" "rglDirection" } - { "LPDIENVELOPE" "lpEnvelope" } - { "DWORD" "cbTypeSpecificParams" } - { "LPVOID" "lpvTypeSpecificParams" } - { "DWORD" "dwStartDelay" } ; +STRUCT: DIEFFECT + { dwSize DWORD } + { dwFlags DWORD } + { dwDuration DWORD } + { dwSamplePeriod DWORD } + { dwGain DWORD } + { dwTriggerButton DWORD } + { dwTriggerRepeatInterval DWORD } + { cAxes DWORD } + { rgdwAxes LPDWORD } + { rglDirection LPLONG } + { lpEnvelope LPDIENVELOPE } + { cbTypeSpecificParams DWORD } + { lpvTypeSpecificParams LPVOID } + { dwStartDelay DWORD } ; TYPEDEF: DIEFFECT* LPDIEFFECT TYPEDEF: DIEFFECT* LPCDIEFFECT -C-STRUCT: DIEFFECTINFOW - { "DWORD" "dwSize" } - { "GUID" "guid" } - { "DWORD" "dwEffType" } - { "DWORD" "dwStaticParams" } - { "DWORD" "dwDynamicParams" } - { "WCHAR[260]" "tszName" } ; +STRUCT: DIEFFECTINFOW + { dwSize DWORD } + { guid GUID } + { dwEffType DWORD } + { dwStaticParams DWORD } + { dwDynamicParams DWORD } + { tszName WCHAR[260] } ; TYPEDEF: DIEFFECTINFOW* LPDIEFFECTINFOW TYPEDEF: DIEFFECTINFOW* LPCDIEFFECTINFOW -C-STRUCT: DIEFFESCAPE - { "DWORD" "dwSize" } - { "DWORD" "dwCommand" } - { "LPVOID" "lpvInBuffer" } - { "DWORD" "cbInBuffer" } - { "LPVOID" "lpvOutBuffer" } - { "DWORD" "cbOutBuffer" } ; +STRUCT: DIEFFESCAPE + { dwSize DWORD } + { dwCommand DWORD } + { lpvInBuffer LPVOID } + { cbInBuffer DWORD } + { lpvOutBuffer LPVOID } + { cbOutBuffer DWORD } ; TYPEDEF: DIEFFESCAPE* LPDIEFFESCAPE TYPEDEF: DIEFFESCAPE* LPCDIEFFESCAPE -C-STRUCT: DIFILEEFFECT - { "DWORD" "dwSize" } - { "GUID" "GuidEffect" } - { "LPCDIEFFECT" "lpDiEffect" } - { "CHAR[260]" "szFriendlyName" } ; +STRUCT: DIFILEEFFECT + { dwSize DWORD } + { GuidEffect GUID } + { lpDiEffect LPCDIEFFECT } + { szFriendlyName CHAR[260] } ; TYPEDEF: DIFILEEFFECT* LPDIFILEEFFECT TYPEDEF: DIFILEEFFECT* LPCDIFILEEFFECT -C-STRUCT: DIDEVICEIMAGEINFOW - { "WCHAR[260]" "tszImagePath" } - { "DWORD" "dwFlags" } - { "DWORD" "dwViewID" } - { "RECT" "rcOverlay" } - { "DWORD" "dwObjID" } - { "DWORD" "dwcValidPts" } - { "POINT[5]" "rgptCalloutLine" } - { "RECT" "rcCalloutRect" } - { "DWORD" "dwTextAlign" } ; +STRUCT: DIDEVICEIMAGEINFOW + { tszImagePath WCHAR[260] } + { dwFlags DWORD } + { dwViewID DWORD } + { rcOverlay RECT } + { dwObjID DWORD } + { dwcValidPts DWORD } + { rgptCalloutLine POINT[5] } + { rcCalloutRect RECT } + { dwTextAlign DWORD } ; TYPEDEF: DIDEVICEIMAGEINFOW* LPDIDEVICEIMAGEINFOW TYPEDEF: DIDEVICEIMAGEINFOW* LPCDIDEVICEIMAGEINFOW -C-STRUCT: DIDEVICEIMAGEINFOHEADERW - { "DWORD" "dwSize" } - { "DWORD" "dwSizeImageInfo" } - { "DWORD" "dwcViews" } - { "DWORD" "dwcButtons" } - { "DWORD" "dwcAxes" } - { "DWORD" "dwcPOVs" } - { "DWORD" "dwBufferSize" } - { "DWORD" "dwBufferUsed" } - { "DIDEVICEIMAGEINFOW*" "lprgImageInfoArray" } ; +STRUCT: DIDEVICEIMAGEINFOHEADERW + { dwSize DWORD } + { dwSizeImageInfo DWORD } + { dwcViews DWORD } + { dwcButtons DWORD } + { dwcAxes DWORD } + { dwcPOVs DWORD } + { dwBufferSize DWORD } + { dwBufferUsed DWORD } + { lprgImageInfoArray DIDEVICEIMAGEINFOW* } ; TYPEDEF: DIDEVICEIMAGEINFOHEADERW* LPDIDEVICEIMAGEINFOHEADERW TYPEDEF: DIDEVICEIMAGEINFOHEADERW* LPCDIDEVICEIMAGEINFOHEADERW -C-STRUCT: DIMOUSESTATE2 - { "LONG" "lX" } - { "LONG" "lY" } - { "LONG" "lZ" } - { "BYTE[8]" "rgbButtons" } ; +STRUCT: DIMOUSESTATE2 + { lX LONG } + { lY LONG } + { lZ LONG } + { rgbButtons BYTE[8] } ; TYPEDEF: DIMOUSESTATE2* LPDIMOUSESTATE2 TYPEDEF: DIMOUSESTATE2* LPCDIMOUSESTATE2 -C-STRUCT: DIJOYSTATE2 - { "LONG" "lX" } - { "LONG" "lY" } - { "LONG" "lZ" } - { "LONG" "lRx" } - { "LONG" "lRy" } - { "LONG" "lRz" } - { "LONG[2]" "rglSlider" } - { "DWORD[4]" "rgdwPOV" } - { "BYTE[128]" "rgbButtons" } - { "LONG" "lVX" } - { "LONG" "lVY" } - { "LONG" "lVZ" } - { "LONG" "lVRx" } - { "LONG" "lVRy" } - { "LONG" "lVRz" } - { "LONG[2]" "rglVSlider" } - { "LONG" "lAX" } - { "LONG" "lAY" } - { "LONG" "lAZ" } - { "LONG" "lARx" } - { "LONG" "lARy" } - { "LONG" "lARz" } - { "LONG[2]" "rglASlider" } - { "LONG" "lFX" } - { "LONG" "lFY" } - { "LONG" "lFZ" } - { "LONG" "lFRx" } - { "LONG" "lFRy" } - { "LONG" "lFRz" } - { "LONG[2]" "rglFSlider" } ; +STRUCT: DIJOYSTATE2 + { lX LONG } + { lY LONG } + { lZ LONG } + { lRx LONG } + { lRy LONG } + { lRz LONG } + { rglSlider LONG[2] } + { rgdwPOV DWORD[4] } + { rgbButtons BYTE[128] } + { lVX LONG } + { lVY LONG } + { lVZ LONG } + { lVRx LONG } + { lVRy LONG } + { lVRz LONG } + { rglVSlider LONG[2] } + { lAX LONG } + { lAY LONG } + { lAZ LONG } + { lARx LONG } + { lARy LONG } + { lARz LONG } + { rglASlider LONG[2] } + { lFX LONG } + { lFY LONG } + { lFZ LONG } + { lFRx LONG } + { lFRy LONG } + { lFRz LONG } + { rglFSlider LONG[2] } ; TYPEDEF: DIJOYSTATE2* LPDIJOYSTATE2 TYPEDEF: DIJOYSTATE2* LPCDIJOYSTATE2 diff --git a/basis/windows/dragdrop-listener/dragdrop-listener.factor b/basis/windows/dragdrop-listener/dragdrop-listener.factor index e9c4930b64..91dfddbbff 100644 --- a/basis/windows/dragdrop-listener/dragdrop-listener.factor +++ b/basis/windows/dragdrop-listener/dragdrop-listener.factor @@ -1,16 +1,19 @@ -USING: windows.com windows.com.wrapper combinators -windows.kernel32 windows.ole32 windows.shell32 kernel accessors +USING: alien.strings io.encodings.utf16n windows.com +windows.com.wrapper combinators windows.kernel32 windows.ole32 +windows.shell32 kernel accessors prettyprint namespaces ui.tools.listener ui.tools.workspace alien.c-types alien sequences math ; IN: windows.dragdrop-listener +<< "WCHAR" require-c-arrays >> + : filenames-from-hdrop ( hdrop -- filenames ) dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files [ 2dup f 0 DragQueryFile 1 + ! get size of filename buffer dup "WCHAR" [ swap DragQueryFile drop ] keep - alien>u16-string + utf16n alien>string ] with map ; : filenames-from-data-object ( data-object -- filenames ) diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index ea9c297c44..5a1bf74d19 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -4,6 +4,8 @@ io.encodings.string io.encodings.utf16n alien.strings arrays literals ; IN: windows.errors +<< "TCHAR" require-c-arrays >> + CONSTANT: ERROR_SUCCESS 0 CONSTANT: ERROR_INVALID_FUNCTION 1 CONSTANT: ERROR_FILE_NOT_FOUND 2 @@ -696,7 +698,7 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF : make-lang-id ( lang1 lang2 -- n ) 10 shift bitor ; inline -<< "TCHAR" require-c-type-arrays >> +<< "TCHAR" require-c-arrays >> ERROR: error-message-failed id ; :: n>win32-error-string ( id -- string ) @@ -707,7 +709,7 @@ ERROR: error-message-failed id ; f id LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id - 32768 [ "TCHAR" ] [ ] bi + 32768 [ "TCHAR" ] [ ] bi f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip utf16n alien>string [ blank? ] trim ; diff --git a/basis/windows/ole32/ole32-tests.factor b/basis/windows/ole32/ole32-tests.factor index aa02211ef3..c8358f5aa6 100644 --- a/basis/windows/ole32/ole32-tests.factor +++ b/basis/windows/ole32/ole32-tests.factor @@ -1,5 +1,6 @@ USING: kernel tools.test windows.ole32 alien.c-types -classes.struct specialized-arrays.uchar windows.kernel32 ; +classes.struct specialized-arrays.uchar windows.kernel32 +windows.com.syntax ; IN: windows.ole32.tests [ t ] [ diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor index 15ddc1a5df..47fed998c4 100644 --- a/basis/windows/shell32/shell32.factor +++ b/basis/windows/shell32/shell32.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2006, 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax -combinators io.encodings.utf16n io.files io.pathnames kernel -windows.errors windows.com windows.com.syntax windows.user32 -windows.ole32 windows specialized-arrays.ushort classes.struct ; +classes.struct combinators io.encodings.utf16n io.files +io.pathnames kernel windows.errors windows.com +windows.com.syntax windows.user32 windows.ole32 windows +specialized-arrays.ushort ; IN: windows.shell32 CONSTANT: CSIDL_DESKTOP HEX: 00 @@ -194,10 +195,13 @@ CONSTANT: STRRET_WSTR 0 CONSTANT: STRRET_OFFSET 1 CONSTANT: STRRET_CSTR 2 -C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ; +UNION-STRUCT: STRRET-union + { pOleStr LPWSTR } + { uOffset UINT } + { cStr char[260] } ; STRUCT: STRRET { uType int } - { union STRRET-union } ; + { value STRRET-union } ; COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046} HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched ) diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index 8a5c963de0..c882ba2e7f 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -330,9 +330,7 @@ STRUCT: PIXELFORMATDESCRIPTOR { dwDamageMask DWORD } ; : ( loc dim -- RECT ) - [ RECT ] 2dip - [ drop [ first >>left ] [ second >>top ] bi ] - [ v+ [ first >>right ] [ second >>bottom ] bi ] 2bi ; + dupd v+ [ first2 ] bi@ RECT ; TYPEDEF: RECT* PRECT TYPEDEF: RECT* LPRECT diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index 7395014bed..4a7fcea0e6 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -275,7 +275,7 @@ $nl "The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:" { $subsection call } { $subsection execute } -"The second set of combinators takes an effect declaration. The stack effect of the quotation or word is checked at runtime:" +"The second set of combinators takes an effect declaration. Note that the opening parenthesis is actually part of the word name; these are parsing words, and they read a stack effect until the corresponding closing parenthesis. The stack effect of the quotation or word is then checked at runtime:" { $subsection POSTPONE: call( } { $subsection POSTPONE: execute( } "The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:" @@ -303,11 +303,25 @@ ABOUT: "combinators" HELP: call-effect { $values { "quot" quotation } { "effect" effect } } -{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ; +{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } +{ $examples + "The following two lines are equivalent:" + { $code + "call( a b -- c )" + "(( a b -- c )) call-effect" + } +} ; HELP: execute-effect { $values { "word" word } { "effect" effect } } -{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ; +{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } +{ $examples + "The following two lines are equivalent:" + { $code + "execute( a b -- c )" + "(( a b -- c )) execute-effect" + } +} ; HELP: execute-effect-unsafe { $values { "word" word } { "effect" effect } } diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index cc4b080491..50c7c047c7 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -834,6 +834,14 @@ HELP: call( HELP: execute( { $syntax "execute( stack -- effect )" } -{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ; +{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } +{ $examples + { $code + "IN: scratchpad" + "" + ": eat ( -- ) ; : sleep ( -- ) ; : hack ( -- ) ;" + "{ eat sleep hack } [ execute( -- ) ] each" + } +} ; { POSTPONE: call( POSTPONE: execute( } related-words diff --git a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor index 9562e42c4e..8041bef07f 100644 --- a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor +++ b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor @@ -2,50 +2,50 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.accessors alien.c-types alien.syntax byte-arrays destructors generalizations hints kernel libc locals math math.order -sequences sequences.private ; +sequences sequences.private classes.struct accessors ; IN: benchmark.yuv-to-rgb -C-STRUCT: yuv_buffer - { "int" "y_width" } - { "int" "y_height" } - { "int" "y_stride" } - { "int" "uv_width" } - { "int" "uv_height" } - { "int" "uv_stride" } - { "void*" "y" } - { "void*" "u" } - { "void*" "v" } ; +STRUCT: yuv_buffer + { y_width int } + { y_height int } + { y_stride int } + { uv_width int } + { uv_height int } + { uv_stride int } + { y void* } + { u void* } + { v void* } ; :: fake-data ( -- rgb yuv ) [let* | w [ 1600 ] h [ 1200 ] - buffer [ "yuv_buffer" ] + buffer [ yuv_buffer ] rgb [ w h * 3 * ] | - w buffer set-yuv_buffer-y_width - h buffer set-yuv_buffer-y_height - h buffer set-yuv_buffer-uv_height - w buffer set-yuv_buffer-y_stride - w buffer set-yuv_buffer-uv_stride - w h * [ dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-y - w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-u - w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-v rgb buffer + w >>y_width + h >>y_height + h >>uv_height + w >>y_stride + w >>uv_stride + w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y + w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u + w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v ] ; : clamp ( n -- n ) 255 min 0 max ; inline : stride ( line yuv -- uvy yy ) - [ yuv_buffer-uv_stride swap 2/ * ] [ yuv_buffer-y_stride * ] 2bi ; inline + [ uv_stride>> swap 2/ * ] [ y_stride>> * ] 2bi ; inline : compute-y ( yuv uvy yy x -- y ) - + >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline + + >fixnum nip swap y>> swap alien-unsigned-1 16 - ; inline : compute-v ( yuv uvy yy x -- v ) - nip 2/ + >fixnum swap yuv_buffer-u swap alien-unsigned-1 128 - ; inline + nip 2/ + >fixnum swap u>> swap alien-unsigned-1 128 - ; inline : compute-u ( yuv uvy yy x -- v ) - nip 2/ + >fixnum swap yuv_buffer-v swap alien-unsigned-1 128 - ; inline + nip 2/ + >fixnum swap v>> swap alien-unsigned-1 128 - ; inline :: compute-yuv ( yuv uvy yy x -- y u v ) yuv uvy yy x compute-y @@ -77,16 +77,16 @@ C-STRUCT: yuv_buffer : yuv>rgb-row ( index rgb yuv y -- index ) over stride - pick yuv_buffer-y_width + pick y_width>> [ yuv>rgb-pixel ] with with with with each ; inline : yuv>rgb ( rgb yuv -- ) [ 0 ] 2dip - dup yuv_buffer-y_height + dup y_height>> [ yuv>rgb-row ] with with each drop ; -HINTS: yuv>rgb byte-array byte-array ; +HINTS: yuv>rgb byte-array yuv_buffer ; : yuv>rgb-benchmark ( -- ) [ fake-data yuv>rgb ] with-destructors ; diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor index 05baf6e8fe..44ce63692e 100755 --- a/extra/gpu/demos/bunny/bunny.factor +++ b/extra/gpu/demos/bunny/bunny.factor @@ -1,11 +1,11 @@ ! (c)2009 Joe Groff bsd license -USING: accessors alien.c-types arrays combinators combinators.short-circuit -game-worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render -gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images -images.loader io io.encodings.ascii io.files io.files.temp -kernel math math.matrices math.parser math.vectors -method-chains sequences specialized-arrays.float specialized-vectors.uint splitting -struct-vectors threads ui ui.gadgets ui.gadgets.worlds +USING: accessors alien.c-types arrays classes.struct combinators +combinators.short-circuit game-worlds gpu gpu.buffers gpu.util.wasd +gpu.framebuffers gpu.render gpu.shaders gpu.state gpu.textures gpu.util +grouping http.client images images.loader io io.encodings.ascii io.files +io.files.temp kernel math math.matrices math.parser math.vectors +method-chains sequences specialized-arrays.float specialized-vectors.uint +splitting struct-vectors threads ui ui.gadgets ui.gadgets.worlds ui.pixel-formats ; IN: gpu.demos.bunny @@ -73,9 +73,8 @@ UNIFORM-TUPLE: loading-uniforms " " split [ string>number ] map sift ; : ( vertex -- struct ) - >float-array - "bunny-vertex-struct" - [ set-bunny-vertex-struct-vertex ] keep ; + bunny-vertex-struct + swap >float-array >>vertex ; inline : (parse-bunny-model) ( vs is -- vs is ) readln [ @@ -87,7 +86,7 @@ UNIFORM-TUPLE: loading-uniforms ] when* ; : parse-bunny-model ( -- vertexes indexes ) - 100000 "bunny-vertex-struct" + 100000 bunny-vertex-struct 100000 (parse-bunny-model) ; @@ -98,23 +97,15 @@ UNIFORM-TUPLE: loading-uniforms : calc-bunny-normal ( vertexes indexes -- ) swap - [ [ nth bunny-vertex-struct-vertex ] curry { } map-as normal ] - [ - [ - nth [ bunny-vertex-struct-normal v+ ] keep - set-bunny-vertex-struct-normal - ] curry with each - ] 2bi ; + [ [ nth vertex>> ] curry { } map-as normal ] + [ [ nth [ v+ ] change-normal drop ] curry with each ] 2bi ; : calc-bunny-normals ( vertexes indexes -- ) 3 [ calc-bunny-normal ] with each ; : normalize-bunny-normals ( vertexes -- ) - [ - [ bunny-vertex-struct-normal normalize ] keep - set-bunny-vertex-struct-normal - ] each ; + [ [ normalize ] change-normal drop ] each ; : bunny-data ( filename -- vertexes indexes ) ascii [ parse-bunny-model ] with-file-reader diff --git a/extra/gpu/shaders/shaders-docs.factor b/extra/gpu/shaders/shaders-docs.factor index 33b97d7a82..8ccc65da43 100755 --- a/extra/gpu/shaders/shaders-docs.factor +++ b/extra/gpu/shaders/shaders-docs.factor @@ -1,5 +1,5 @@ ! (c)2009 Joe Groff bsd license -USING: alien.syntax classes gpu.buffers help.markup help.syntax +USING: classes classes.struct gpu.buffers help.markup help.syntax images kernel math multiline quotations sequences strings ; IN: gpu.shaders @@ -51,7 +51,7 @@ HELP: VERTEX-FORMAT: HELP: VERTEX-STRUCT: { $syntax <" VERTEX-STRUCT: struct-name format-name "> } -{ $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ; +{ $description "Defines a struct class (like " { $link POSTPONE: STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ; { POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor index 58633d4a71..a247158684 100755 --- a/extra/gpu/shaders/shaders.factor +++ b/extra/gpu/shaders/shaders.factor @@ -1,7 +1,7 @@ ! (c)2009 Joe Groff bsd license USING: accessors alien alien.c-types alien.strings -alien.structs arrays assocs byte-arrays classes.mixin -classes.parser classes.singleton combinators +arrays assocs byte-arrays classes.mixin classes.parser +classes.singleton classes.struct combinators combinators.short-circuit definitions destructors generic.parser gpu gpu.buffers hashtables images io.encodings.ascii io.files io.pathnames kernel lexer literals @@ -238,8 +238,8 @@ M: f (verify-feedback-format) { uint-integer-components [ "uint" ] } } case ; -: c-array-dim ( dim -- string ) - dup 1 = [ drop "" ] [ number>string "[" "]" surround ] if ; +: c-array-dim ( type dim -- type' ) + dup 1 = [ drop ] [ 2array ] if ; SYMBOL: padding-no padding-no [ 0 ] initialize @@ -250,11 +250,10 @@ padding-no [ 0 ] initialize "(" ")" surround padding-no inc ; -: vertex-attribute>c-type ( vertex-attribute -- {type,name} ) - [ - [ component-type>> component-type>c-type ] - [ dim>> c-array-dim ] bi append - ] [ name>> [ padding-name ] unless* ] bi 2array ; +: vertex-attribute>struct-slot ( vertex-attribute -- struct-slot-spec ) + [ name>> [ padding-name ] unless* ] + [ [ component-type>> component-type>c-type ] [ dim>> c-array-dim ] bi ] bi + { } ; : shader-filename ( shader/program -- filename ) dup filename>> [ nip ] [ name>> where first ] if* file-name ; @@ -303,13 +302,12 @@ SYNTAX: VERTEX-FORMAT: [ first4 vertex-attribute boa ] map define-vertex-format ; -: define-vertex-struct ( struct-name vertex-format -- ) - [ current-vocab ] dip - "vertex-format-attributes" word-prop [ vertex-attribute>c-type ] map - define-struct ; +: define-vertex-struct ( class vertex-format -- ) + "vertex-format-attributes" word-prop [ vertex-attribute>struct-slot ] map + define-struct-class ; SYNTAX: VERTEX-STRUCT: - scan scan-word define-vertex-struct ; + CREATE-CLASS scan-word define-vertex-struct ; TUPLE: vertex-array < gpu-object { program-instance program-instance read-only } diff --git a/extra/system-info/linux/linux.factor b/extra/system-info/linux/linux.factor index b77e1fe649..8a943927c7 100644 --- a/extra/system-info/linux/linux.factor +++ b/extra/system-info/linux/linux.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: unix alien alien.c-types kernel math sequences strings -io.backend.unix splitting io.encodings.utf8 io.encodings.string ; +io.backend.unix splitting io.encodings.utf8 io.encodings.string +specialized-arrays.char ; IN: system-info.linux : (uname) ( buf -- int ) "int" f "uname" { "char*" } alien-invoke ; : uname ( -- seq ) - 65536 "char" [ (uname) io-error ] keep + 65536 [ (uname) io-error ] keep "\0" split harvest [ utf8 decode ] map 6 "" pad-tail ; diff --git a/extra/system-info/windows/windows.factor b/extra/system-info/windows/windows.factor index 8e0dc60e25..6576ca6d53 100755 --- a/extra/system-info/windows/windows.factor +++ b/extra/system-info/windows/windows.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types classes.struct accessors kernel math namespaces windows windows.kernel32 windows.advapi32 words combinators vocabs.loader system-info.backend system -alien.strings windows.errors ; +alien.strings windows.errors specialized-arrays.ushort ; IN: system-info.windows : system-info ( -- SYSTEM_INFO ) @@ -49,11 +49,8 @@ IN: system-info.windows : sse3? ( -- ? ) PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ; -: ( n -- obj ) - "ushort" ; - : get-directory ( word -- str ) - [ MAX_UNICODE_PATH [ ] keep dupd ] dip + [ MAX_UNICODE_PATH [ ] keep dupd ] dip execute win32-error=0/f alien>native-string ; inline : windows-directory ( -- str )