diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index a9613d2c9f..390477dcac 100755 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -1,6 +1,8 @@ -USING: alien help.syntax help.markup libc kernel.private -byte-arrays math strings hashtables alien.syntax alien.strings sequences -io.encodings.string debugger destructors vocabs.loader ; +USING: alien alien.complex help.syntax help.markup libc kernel.private +byte-arrays strings hashtables alien.syntax alien.strings sequences +io.encodings.string debugger destructors vocabs.loader +classes.struct ; +QUALIFIED: math IN: alien.c-types HELP: byte-length @@ -8,7 +10,7 @@ HELP: byte-length { $contract "Outputs the size of the byte array, struct, or specialized array data in bytes." } ; HELP: heap-size -{ $values { "type" string } { "size" integer } } +{ $values { "type" string } { "size" math:integer } } { $description "Outputs the number of bytes needed for a heap-allocated value of this C type." } { $examples "On a 32-bit system, you will get the following output:" @@ -17,7 +19,7 @@ HELP: heap-size { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; HELP: stack-size -{ $values { "type" string } { "size" integer } } +{ $values { "type" string } { "size" math:integer } } { $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; @@ -49,7 +51,7 @@ HELP: c-setter { $errors "Throws an error if the type does not exist." } ; HELP: box-parameter -{ $values { "n" integer } { "ctype" string } } +{ $values { "n" math:integer } { "ctype" string } } { $description "Generates code for converting a C value stored at offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." } { $notes "This is an internal word used by the compiler when compiling callbacks." } ; @@ -73,6 +75,42 @@ HELP: define-out { $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." } { $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ; +HELP: char +{ $description "This C type represents a one-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ; +HELP: uchar +{ $description "This C type represents a one-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to eight bits; output values will be returned as " { $link math:fixnum } "s." } ; +HELP: short +{ $description "This C type represents a two-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ; +HELP: ushort +{ $description "This C type represents a two-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to sixteen bits; output values will be returned as " { $link math:fixnum } "s." } ; +HELP: int +{ $description "This C type represents a four-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: uint +{ $description "This C type represents a four-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 32 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: long +{ $description "This C type represents a four- or eight-byte signed integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: ulong +{ $description "This C type represents a four- or eight-byte unsigned integer type. On Windows and on 32-bit Unix platforms, it will be four bytes. On 64-bit Unix platforms, it will be eight bytes. Input values will be converted to " { $link math:integer } "s and truncated to 32 or 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: longlong +{ $description "This C type represents an eight-byte signed integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: ulonglong +{ $description "This C type represents an eight-byte unsigned integer type. Input values will be converted to " { $link math:integer } "s and truncated to 64 bits; output values will be returned as " { $link math:integer } "s." } ; +HELP: void +{ $description "This symbol is not a valid C type, but it can be used as the return type for a " { $link POSTPONE: FUNCTION: } " or " { $link POSTPONE: CALLBACK: } " definition, or an " { $link alien-invoke } " or " { $link alien-callback } " call." } ; +HELP: void* +{ $description "This C type represents a pointer to C memory. " { $link byte-array } " and " { $link alien } " values can be passed as inputs, but see " { $link "byte-arrays-gc" } " for notes about passing byte arrays into C functions. Output values are returned as " { $link alien } "s." } ; +HELP: char* +{ $description "This C type represents a pointer to a C string. See " { $link "c-strings" } " for details about using strings with the FFI." } ; +HELP: float +{ $description "This C type represents a single-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s and demoted to single-precision; output values will be returned as Factor " { $link math:float } "s." } ; +HELP: double +{ $description "This C type represents a double-precision IEEE 754 floating-point type. Input values will be converted to Factor " { $link math:float } "s; output values will be returned as Factor " { $link math:float } "s." } ; +HELP: complex-float +{ $description "This C type represents a single-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a single-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ; +HELP: complex-double +{ $description "This C type represents a double-precision IEEE 754 floating-point complex type. Input values will be converted from Factor " { $link math:complex } " objects into a double-precision complex float type; output values will be returned as Factor " { $link math:complex } " objects." } ; + + ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector" "The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data." $nl @@ -120,29 +158,29 @@ $nl "Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link } " and " { $link *void* } " may be used." ; ARTICLE: "c-types-specs" "C type specifiers" -"C types are identified by strings, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words, as well as " { $link POSTPONE: C-STRUCT: } ", " { $link POSTPONE: C-UNION: } " and " { $link POSTPONE: TYPEDEF: } "." +"C types are identified by special words, and type names occur as parameters to the " { $link alien-invoke } ", " { $link alien-indirect } " and " { $link alien-callback } " words. New C types can be defined by the words " { $link POSTPONE: STRUCT: } ", " { $link POSTPONE: UNION-STRUCT: } ", " { $link POSTPONE: CALLBACK: } ", and " { $link POSTPONE: TYPEDEF: } "." $nl "The following numerical types are available; a " { $snippet "u" } " prefix denotes an unsigned type:" { $table { "C type" "Notes" } - { { $snippet "char" } "always 1 byte" } - { { $snippet "uchar" } { } } - { { $snippet "short" } "always 2 bytes" } - { { $snippet "ushort" } { } } - { { $snippet "int" } "always 4 bytes" } - { { $snippet "uint" } { } } - { { $snippet "long" } { "same size as CPU word size and " { $snippet "void*" } ", except on 64-bit Windows, where it is 4 bytes" } } - { { $snippet "ulong" } { } } - { { $snippet "longlong" } "always 8 bytes" } - { { $snippet "ulonglong" } { } } - { { $snippet "float" } { } } - { { $snippet "double" } { "same format as " { $link float } " objects" } } - { { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } } - { { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } } + { { $link char } "always 1 byte" } + { { $link uchar } { } } + { { $link short } "always 2 bytes" } + { { $link ushort } { } } + { { $link int } "always 4 bytes" } + { { $link uint } { } } + { { $link long } { "same size as CPU word size and " { $link void* } ", except on 64-bit Windows, where it is 4 bytes" } } + { { $link ulong } { } } + { { $link longlong } "always 8 bytes" } + { { $link ulonglong } { } } + { { $link float } { "single-precision float (not the same as Factor's " { $link math:float } " class!)" } } + { { $link double } { "double-precision float (the same format as Factor's " { $link math:float } " objects)" } } + { { $link complex-float } { "C99 or Fortran " { $snippet "complex float" } " type, converted to and from Factor " { $link math:complex } " values" } } + { { $link complex-double } { "C99 or Fortran " { $snippet "complex double" } " type, converted to and from Factor " { $link math:complex } " values" } } } "When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." $nl -"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $snippet "void*" } ", which denotes a generic pointer; " { $snippet "void" } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned." +"Pointer types are specified by suffixing a C type with " { $snippet "*" } ", for example " { $snippet "float*" } ". One special case is " { $link void* } ", which denotes a generic pointer; " { $link void } " by itself is not a valid C type specifier. With the exception of strings (see " { $link "c-strings" } "), all pointer types are identical to " { $snippet "void*" } " as far as the C library interface is concerned." $nl "Fixed-size array types are supported; the syntax consists of a C type name followed by dimension sizes in brackets; the following denotes a 3 by 4 array of integers:" { $code "int[3][4]" } diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor index 19bfaaa8ce..685639beed 100644 --- a/basis/alien/data/data-docs.factor +++ b/basis/alien/data/data-docs.factor @@ -129,20 +129,20 @@ HELP: { $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary 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." +"C string types are arrays with shape " { $snippet "{ char* encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $link char* } " is an alias for " { $snippet "{ char* utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors." $nl "Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function." $nl "If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown." $nl -"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array." +"Care must be taken if the C function expects a " { $link char* } " with a length in bytes, rather than a null-terminated " { $link char* } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array." $nl -"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" +"Sometimes a C function has a parameter type of " { $link void* } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:" { $subsection string>alien } { $subsection malloc-string } "The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches." $nl "A word to read strings from arbitrary addresses:" { $subsection alien>string } -"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ; +"For example, if a C function returns a " { $link char* } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $link void* } ", and call one of the above words before passing the pointer to " { $link free } "." ; diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index 9a24f7cd4d..d58f9a315c 100644 --- a/basis/alien/parser/parser.factor +++ b/basis/alien/parser/parser.factor @@ -25,7 +25,7 @@ IN: alien.parser [ parse-c-type ] if ; : reset-c-type ( word -- ) - { "c-type" "pointer-c-type" } reset-props ; + { "c-type" "pointer-c-type" "callback-effect" "callback-abi" } reset-props ; : CREATE-C-TYPE ( -- word ) scan current-vocab create dup reset-c-type ; @@ -55,16 +55,37 @@ IN: alien.parser return library function parameters return parse-arglist [ function-quot ] dip ; +: parse-arg-tokens ( -- tokens ) + ";" parse-tokens [ "()" subseq? not ] filter ; + : (FUNCTION:) ( -- word quot effect ) - scan "c-library" get scan ";" parse-tokens - [ "()" subseq? not ] filter - make-function ; + scan "c-library" get scan parse-arg-tokens make-function ; : define-function ( return library function parameters -- ) make-function define-declared ; +: callback-quot ( return types abi -- quot ) + [ [ ] 3curry dip alien-callback ] 3curry ; + +:: make-callback-type ( abi return! type-name! parameters -- word quot effect ) + return type-name normalize-c-arg type-name! return! + type-name current-vocab create :> type-word + type-word [ reset-generic ] [ reset-c-type ] bi + void* type-word typedef + parameters return parse-arglist :> callback-effect :> types + type-word callback-effect "callback-effect" set-word-prop + type-word abi "callback-abi" set-word-prop + type-word return types abi callback-quot (( quot -- alien )) ; + +: (CALLBACK:) ( abi -- word quot effect ) + scan scan parse-arg-tokens make-callback-type ; + PREDICATE: alien-function-word < word def>> { [ length 5 = ] [ last \ alien-invoke eq? ] } 1&& ; + +PREDICATE: alien-callback-type-word < typedef-word + "callback-effect" word-prop ; + diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor index e17d4c0533..eea3515c8f 100644 --- a/basis/alien/prettyprint/prettyprint.factor +++ b/basis/alien/prettyprint/prettyprint.factor @@ -38,8 +38,8 @@ M: typedef-word synopsis* : pprint-function-arg ( type name -- ) [ pprint-c-type ] [ text ] bi* ; -: pprint-function-args ( word -- ) - [ def>> fourth ] [ stack-effect in>> ] bi zip [ ] [ +: pprint-function-args ( types names -- ) + zip [ ] [ unclip-last [ [ first2 "," append pprint-function-arg ] each ] dip first2 pprint-function-arg @@ -51,8 +51,33 @@ M: alien-function-word definition drop f ; M: alien-function-word synopsis* { [ seeing-word ] + [ def>> second [ \ LIBRARY: [ text ] pprint-prefix ] when* ] [ definer. ] [ def>> first pprint-c-type ] [ pprint-word ] - [ ] + [ + > fourth ] [ stack-effect in>> ] bi + pprint-function-args + ")" text block> + ] + } cleave ; + +M: alien-callback-type-word definer + "callback-abi" word-prop "stdcall" = + \ STDCALL-CALLBACK: \ CALLBACK: ? + f ; +M: alien-callback-type-word definition drop f ; +M: alien-callback-type-word synopsis* + { + [ seeing-word ] + [ definer. ] + [ def>> first pprint-c-type ] + [ pprint-word ] + [ + > second ] [ "callback-effect" word-prop in>> ] bi + pprint-function-args + ")" text block> + ] } cleave ; diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index e56c83a154..93a74c3b0a 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -81,6 +81,42 @@ HELP: C-ENUM: { $code "CONSTANT: red 0" "CONSTANT: green 1" "CONSTANT: blue 2" } } ; +HELP: CALLBACK: +{ $syntax "CALLBACK: return type ( parameters ) ;" } +{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } } +{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"cdecl\"" } " ABI." } +{ $examples + { $code + "CALLBACK: bool FakeCallback ( int message, void* payload ) ;" + ": MyFakeCallback ( -- alien )" + " [| message payload |" + " \"message #\" write" + " message number>string write" + " \" received\" write nl" + " t" + " ] FakeCallback ;" + } +} ; + +HELP: STDCALL-CALLBACK: +{ $syntax "STDCALL-CALLBACK: return type ( parameters ) ;" } +{ $values { "return" "a C return type" } { "type" "a type name" } { "parameters" "a comma-separated sequence of type/name pairs; " { $snippet "type1 arg1, type2 arg2, ..." } } } +{ $description "Defines a new function pointer C type word " { $snippet "type" } ". The newly defined word works both as a C type and as a wrapper for " { $link alien-callback } " for callbacks that accept the given return type and parameters with the " { $snippet "\"stdcall\"" } " ABI." } +{ $examples + { $code + "STDCALL-CALLBACK: bool FakeCallback ( int message, void* payload ) ;" + ": MyFakeCallback ( -- alien )" + " [| message payload |" + " \"message #\" write" + " message number>string write" + " \" received\" write nl" + " t" + " ] FakeCallback ;" + } +} ; + +{ POSTPONE: CALLBACK: POSTPONE: STDCALL-CALLBACK: } related-words + HELP: &: { $syntax "&: symbol" } { $values { "symbol" "A C library symbol name" } } @@ -88,7 +124,7 @@ HELP: &: HELP: typedef { $values { "old" "a string" } { "new" "a string" } } -{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." } +{ $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." } { $notes "Using this word in the same source file which defines C bindings can cause problems, because words are compiled before top-level forms are run. Use the " { $link POSTPONE: TYPEDEF: } " word instead." } ; { POSTPONE: TYPEDEF: typedef } related-words diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor index 0e3b569fff..611133bacb 100644 --- a/basis/alien/syntax/syntax.factor +++ b/basis/alien/syntax/syntax.factor @@ -18,6 +18,12 @@ SYNTAX: LIBRARY: scan "c-library" set ; SYNTAX: FUNCTION: (FUNCTION:) define-declared ; +SYNTAX: CALLBACK: + "cdecl" (CALLBACK:) define-inline ; + +SYNTAX: STDCALL-CALLBACK: + "stdcall" (CALLBACK:) define-inline ; + SYNTAX: TYPEDEF: scan-c-type CREATE-C-TYPE typedef ; diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 45ea841a73..18679ce77b 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -122,17 +122,6 @@ GENERIC: void-generic ( obj -- * ) [ t ] [ \ -regression optimized? ] unit-test -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ t ] [ - reversed \ foozul specific-method - reversed \ foozul method - eq? -] unit-test - ! regression : constant-fold-2 ( -- value ) f ; foldable : constant-fold-3 ( -- value ) 4 ; foldable diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 0b50632e4e..367427c716 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -52,7 +52,7 @@ M: callable splicing-nodes splicing-body ; 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [ [ in-d>> ] [ [ dispatch# ] keep ] bi* [ swap nth value-info class>> dup ] dip - specific-method + method-for-class ] if ] if ; diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index e08a21d4b9..8aa6a821d8 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -14,7 +14,7 @@ IN: compiler.tree.propagation.transforms ! If first input has a known type and second input is an ! object, we convert this to [ swap equal? ]. in-d>> first2 value-info class>> object class= [ - value-info class>> \ equal? specific-method + value-info class>> \ equal? method-for-class [ swap equal? ] f ? ] [ drop f ] if ] "custom-inlining" set-word-prop diff --git a/basis/iokit/hid/hid.factor b/basis/iokit/hid/hid.factor index 63f91ffc78..a1a4b942b7 100644 --- a/basis/iokit/hid/hid.factor +++ b/basis/iokit/hid/hid.factor @@ -130,30 +130,11 @@ TYPEDEF: void* IOHIDTransactionRef TYPEDEF: UInt32 IOHIDValueScaleType TYPEDEF: UInt32 IOHIDTransactionDirectionType -TYPEDEF: void* IOHIDCallback -: IOHIDCallback ( quot -- alien ) - [ "void" { "void*" "IOReturn" "void*" } "cdecl" ] - dip alien-callback ; inline - -TYPEDEF: void* IOHIDReportCallback -: IOHIDReportCallback ( quot -- alien ) - [ "void" { "void*" "IOReturn" "void*" "IOHIDReportType" "UInt32" "uchar*" "CFIndex" } "cdecl" ] - dip alien-callback ; inline - -TYPEDEF: void* IOHIDValueCallback -: IOHIDValueCallback ( quot -- alien ) - [ "void" { "void*" "IOReturn" "void*" "IOHIDValueRef" } "cdecl" ] - dip alien-callback ; inline - -TYPEDEF: void* IOHIDValueMultipleCallback -: IOHIDValueMultipleCallback ( quot -- alien ) - [ "void" { "void*" "IOReturn" "void*" "CFDictionaryRef" } "cdecl" ] - dip alien-callback ; inline - -TYPEDEF: void* IOHIDDeviceCallback -: IOHIDDeviceCallback ( quot -- alien ) - [ "void" { "void*" "IOReturn" "void*" "IOHIDDeviceRef" } "cdecl" ] - dip alien-callback ; inline +CALLBACK: void IOHIDCallback ( void* context, IOReturn result, void* sender ) ; +CALLBACK: void IOHIDReportCallback ( void* context, IOReturn result, void* sender, IOHIDReportType type, UInt32 reportID, uchar* report, CFIndex reportLength ) ; +CALLBACK: void IOHIDValueCallback ( void* context, IOReturn result, void* sender, IOHIDValueRef value ) ; +CALLBACK: void IOHIDValueMultipleCallback ( void* context, IOReturn result, void* sender, CFDictionaryRef multiple ) ; +CALLBACK: void IOHIDDeviceCallback ( void* context, IOReturn result, void* sender, IOHIDDeviceRef device ) ; ! IOHIDDevice diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 7c66c911de..e72d77ee1f 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -147,7 +147,7 @@ SYMBOL: fast-math-ops : math-both-known? ( word left right -- ? ) 3dup math-op [ 2drop 2drop t ] - [ drop math-class-max swap specific-method >boolean ] if ; + [ drop math-class-max swap method-for-class >boolean ] if ; : (derived-ops) ( word assoc -- words ) swap '[ swap first _ eq? nip ] assoc-filter ; diff --git a/extra/system-info/authors.txt b/basis/system-info/authors.txt similarity index 100% rename from extra/system-info/authors.txt rename to basis/system-info/authors.txt diff --git a/extra/system-info/backend/authors.txt b/basis/system-info/backend/authors.txt similarity index 100% rename from extra/system-info/backend/authors.txt rename to basis/system-info/backend/authors.txt diff --git a/extra/system-info/backend/backend.factor b/basis/system-info/backend/backend.factor similarity index 100% rename from extra/system-info/backend/backend.factor rename to basis/system-info/backend/backend.factor diff --git a/extra/system-info/linux/authors.txt b/basis/system-info/linux/authors.txt similarity index 100% rename from extra/system-info/linux/authors.txt rename to basis/system-info/linux/authors.txt diff --git a/extra/system-info/linux/linux.factor b/basis/system-info/linux/linux.factor similarity index 100% rename from extra/system-info/linux/linux.factor rename to basis/system-info/linux/linux.factor diff --git a/extra/system-info/linux/tags.txt b/basis/system-info/linux/tags.txt similarity index 100% rename from extra/system-info/linux/tags.txt rename to basis/system-info/linux/tags.txt diff --git a/extra/system-info/macosx/authors.txt b/basis/system-info/macosx/authors.txt similarity index 100% rename from extra/system-info/macosx/authors.txt rename to basis/system-info/macosx/authors.txt diff --git a/extra/system-info/macosx/macosx.factor b/basis/system-info/macosx/macosx.factor similarity index 100% rename from extra/system-info/macosx/macosx.factor rename to basis/system-info/macosx/macosx.factor diff --git a/extra/system-info/macosx/tags.txt b/basis/system-info/macosx/tags.txt similarity index 100% rename from extra/system-info/macosx/tags.txt rename to basis/system-info/macosx/tags.txt diff --git a/extra/system-info/summary.txt b/basis/system-info/summary.txt similarity index 100% rename from extra/system-info/summary.txt rename to basis/system-info/summary.txt diff --git a/extra/system-info/system-info.factor b/basis/system-info/system-info.factor similarity index 100% rename from extra/system-info/system-info.factor rename to basis/system-info/system-info.factor diff --git a/extra/system-info/windows/authors.txt b/basis/system-info/windows/authors.txt similarity index 100% rename from extra/system-info/windows/authors.txt rename to basis/system-info/windows/authors.txt diff --git a/extra/system-info/windows/ce/authors.txt b/basis/system-info/windows/ce/authors.txt similarity index 100% rename from extra/system-info/windows/ce/authors.txt rename to basis/system-info/windows/ce/authors.txt diff --git a/extra/system-info/windows/ce/ce.factor b/basis/system-info/windows/ce/ce.factor similarity index 100% rename from extra/system-info/windows/ce/ce.factor rename to basis/system-info/windows/ce/ce.factor diff --git a/extra/system-info/windows/ce/tags.txt b/basis/system-info/windows/ce/tags.txt similarity index 100% rename from extra/system-info/windows/ce/tags.txt rename to basis/system-info/windows/ce/tags.txt diff --git a/extra/system-info/windows/nt/authors.txt b/basis/system-info/windows/nt/authors.txt similarity index 100% rename from extra/system-info/windows/nt/authors.txt rename to basis/system-info/windows/nt/authors.txt diff --git a/extra/system-info/windows/nt/nt.factor b/basis/system-info/windows/nt/nt.factor similarity index 100% rename from extra/system-info/windows/nt/nt.factor rename to basis/system-info/windows/nt/nt.factor diff --git a/extra/system-info/windows/nt/tags.txt b/basis/system-info/windows/nt/tags.txt similarity index 100% rename from extra/system-info/windows/nt/tags.txt rename to basis/system-info/windows/nt/tags.txt diff --git a/extra/system-info/windows/tags.txt b/basis/system-info/windows/tags.txt similarity index 100% rename from extra/system-info/windows/tags.txt rename to basis/system-info/windows/tags.txt diff --git a/extra/system-info/windows/windows.factor b/basis/system-info/windows/windows.factor similarity index 100% rename from extra/system-info/windows/windows.factor rename to basis/system-info/windows/windows.factor diff --git a/basis/windows/dinput/dinput.factor b/basis/windows/dinput/dinput.factor index 46317ab604..598df9a389 100755 --- a/basis/windows/dinput/dinput.factor +++ b/basis/windows/dinput/dinput.factor @@ -5,35 +5,6 @@ IN: windows.dinput LIBRARY: dinput -TYPEDEF: void* LPDIENUMDEVICESCALLBACKW -: LPDIENUMDEVICESCALLBACKW ( quot -- alien ) - [ "BOOL" { "LPCDIDEVICEINSTANCEW" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDIENUMDEVICESBYSEMANTICSCBW -: LPDIENUMDEVICESBYSEMANTICSCBW ( quot -- alien ) - [ "BOOL" { "LPCDIDEVICEINSTANCEW" "IDirectInputDevice8W*" "DWORD" "DWORD" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDICONFIGUREDEVICESCALLBACK -: LPDICONFIGUREDEVICESCALLBACK ( quot -- alien ) - [ "BOOL" { "IUnknown*" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDIENUMEFFECTSCALLBACKW -: LPDIENUMEFFECTSCALLBACKW ( quot -- alien ) - [ "BOOL" { "LPCDIEFFECTINFOW" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDIENUMCREATEDEFFECTOBJECTSCALLBACK -: LPDIENUMCREATEDEFFECTOBJECTSCALLBACK ( quot -- callback ) - [ "BOOL" { "LPDIRECTINPUTEFFECT" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDIENUMEFFECTSINFILECALLBACK -: LPDIENUMEFFECTSINFILECALLBACK ( quot -- callback ) - [ "BOOL" { "LPCDIFILEEFFECT" "LPVOID" } "stdcall" ] - dip alien-callback ; inline -TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW -: LPDIENUMDEVICEOBJECTSCALLBACKW ( quot -- callback ) - [ "BOOL" { "LPCDIDEVICEOBJECTINSTANCEW" "LPVOID" } "stdcall" ] - dip alien-callback ; inline - TYPEDEF: DWORD D3DCOLOR STRUCT: DIDEVICEINSTANCEW @@ -326,6 +297,27 @@ STRUCT: DIJOYSTATE2 TYPEDEF: DIJOYSTATE2* LPDIJOYSTATE2 TYPEDEF: DIJOYSTATE2* LPCDIJOYSTATE2 +STDCALL-CALLBACK: BOOL LPDIENUMDEVICESCALLBACKW ( + LPCDIDEVICEINSTANCEW lpddi, + LPVOID pvRef +) ; +STDCALL-CALLBACK: BOOL LPDICONFIGUREDEVICESCALLBACK ( + IUnknown* lpDDSTarget, + LPVOID pvRef +) ; +STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSCALLBACKW ( + LPCDIEFFECTINFOW pdei, + LPVOID pvRef +) ; +STDCALL-CALLBACK: BOOL LPDIENUMEFFECTSINFILECALLBACK ( + LPCDIFILEEFFECT lpDiFileEf, + LPVOID pvRef +) ; +STDCALL-CALLBACK: BOOL LPDIENUMDEVICEOBJECTSCALLBACKW ( + LPCDIDEVICEOBJECTINSTANCEW lpddoi, + LPVOID pvRef +) ; + COM-INTERFACE: IDirectInputEffect IUnknown {E7E1F7C0-88D2-11D0-9AD0-00A0C9A06E35} HRESULT Initialize ( HINSTANCE hinst, DWORD dwVersion, REFGUID rguid ) HRESULT GetEffectGuid ( LPGUID pguid ) @@ -338,6 +330,11 @@ COM-INTERFACE: IDirectInputEffect IUnknown {E7E1F7C0-88D2-11D0-9AD0-00A0C9A06E35 HRESULT Unload ( ) HRESULT Escape ( LPDIEFFESCAPE pesc ) ; +STDCALL-CALLBACK: BOOL LPDIENUMCREATEDEFFECTOBJECTSCALLBACK ( + IDirectInputEffect* peff, + LPVOID pvRef +) ; + COM-INTERFACE: IDirectInputDevice8W IUnknown {54D41081-DC15-4833-A41B-748F73A38179} HRESULT GetCapabilities ( LPDIDEVCAPS lpDIDeviceCaps ) HRESULT EnumObjects ( LPDIENUMDEVICEOBJECTSCALLBACKW lpCallback, LPVOID pvRef, DWORD dwFlags ) @@ -369,6 +366,14 @@ COM-INTERFACE: IDirectInputDevice8W IUnknown {54D41081-DC15-4833-A41B-748F73A381 HRESULT SetActionMap ( LPDIACTIONFORMATW lpdiActionFormat, LPCWSTR lpwszUserName, DWORD dwFlags ) HRESULT GetImageInfo ( LPDIDEVICEIMAGEINFOHEADERW lpdiDeviceImageInfoHeader ) ; +STDCALL-CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW ( + LPCDIDEVICEINSTANCEW lpddi, + IDirectInputDevice8W* lpdid, + DWORD dwFlags, + DWORD dwRemaining, + LPVOID pvRef +) ; + COM-INTERFACE: IDirectInput8W IUnknown {BF798031-483A-4DA2-AA99-5D64ED369700} HRESULT CreateDevice ( REFGUID rguid, IDirectInputDevice8W** lplpDevice, LPUNKNOWN pUnkOuter ) HRESULT EnumDevices ( DWORD dwDevType, LPDIENUMDEVICESCALLBACKW lpCallback, LPVOID pvRef, DWORD dwFlags ) diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor index b8acf5d8d1..9e113e8c3b 100755 --- a/basis/windows/fonts/fonts.factor +++ b/basis/windows/fonts/fonts.factor @@ -1,13 +1,23 @@ USING: assocs memoize locals kernel accessors init fonts math -combinators windows.errors windows.types windows.gdi32 ; +combinators system-info.windows windows.errors windows.types +windows.gdi32 ; IN: windows.fonts -: windows-font-name ( string -- string' ) +MEMO: windows-fonts ( -- fonts ) + windows-major 6 >= + H{ + { "sans-serif" "Segoe UI" } + { "serif" "Cambria" } + { "monospace" "Consolas" } + } H{ { "sans-serif" "Tahoma" } { "serif" "Times New Roman" } { "monospace" "Courier New" } - } ?at drop ; + } ? ; + +: windows-font-name ( string -- string' ) + windows-fonts ?at drop ; MEMO:: (cache-font) ( font -- HFONT ) font size>> neg ! nHeight diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 66e67ab322..b310345464 100644 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -175,6 +175,8 @@ $nl ARTICLE: "alien-callback" "Calling Factor from C" "Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:" { $subsection alien-callback } +{ $subsection POSTPONE: CALLBACK: } +{ $subsection POSTPONE: STDCALL-CALLBACK: } "There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." { $subsection "alien-callback-gc" } { $see-also "byte-arrays-gc" } ; diff --git a/core/classes/algebra/algebra-docs.factor b/core/classes/algebra/algebra-docs.factor index cbf6acdeed..2e14af27f3 100644 --- a/core/classes/algebra/algebra-docs.factor +++ b/core/classes/algebra/algebra-docs.factor @@ -10,7 +10,6 @@ ARTICLE: "class-operations" "Class operations" { $subsection class-and } { $subsection class-or } { $subsection classes-intersect? } -{ $subsection min-class } "Low-level implementation detail:" { $subsection flatten-class } { $subsection flatten-builtin-class } @@ -37,6 +36,7 @@ $nl "Operations:" { $subsection class< } { $subsection sort-classes } +{ $subsection smallest-class } "Metaclass order:" { $subsection rank-class } ; @@ -73,6 +73,6 @@ HELP: classes-intersect? { $values { "first" class } { "second" class } { "?" "a boolean" } } { $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ; -HELP: min-class -{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } } -{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ; +HELP: smallest-class +{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } } +{ $description "Outputs a minimum class from the given sequence." } ; diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index d111d1daa2..855a15b66f 100644 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -4,7 +4,7 @@ tools.test words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors source-files compiler.units growable random stack-checker effects kernel.private sbufs math.order -classes.tuple accessors ; +classes.tuple accessors generic.private ; IN: classes.algebra.tests : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; @@ -150,6 +150,12 @@ UNION: z1 b1 c1 ; ] unit-test ! Test method inlining +[ real ] [ { real sequence } smallest-class ] unit-test +[ real ] [ { sequence real } smallest-class ] unit-test + +: min-class ( class classes -- class/f ) + interesting-classes smallest-class ; + [ f ] [ fixnum { } min-class ] unit-test [ string ] [ diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index df4f8f2563..2d67403f94 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -214,10 +214,10 @@ ERROR: topological-sort-failed ; [ dup largest-class [ over delete-nth ] dip ] produce nip ; -: min-class ( class seq -- class/f ) - over [ classes-intersect? ] curry filter - [ drop f ] [ - [ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if +: smallest-class ( classes -- class/f ) + [ f ] [ + natural-sort + [ ] [ [ class<= ] most ] map-reduce ] if-empty ; GENERIC: (flatten-class) ( class -- ) diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index a63cab1c5c..e2acbb8fe6 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -186,3 +186,20 @@ GENERIC: move-method-generic ( a -- b ) [ ] [ "IN: generic.tests.a" "move-method-test-1" parse-stream drop ] unit-test [ { string } ] [ \ move-method-generic order ] unit-test + +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ t ] [ + reversed \ foozul method-for-class + reversed \ foozul method + eq? +] unit-test + +[ t ] [ + fixnum \ <=> method-for-class + real \ <=> method + eq? +] unit-test \ No newline at end of file diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 4b398f6532..fcb7a53731 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -24,20 +24,42 @@ M: generic definition drop f ; : method ( class generic -- method/f ) "methods" word-prop at ; -: order ( generic -- seq ) - "methods" word-prop keys sort-classes ; + + +: method-classes ( generic -- classes ) + "methods" word-prop keys ; + +: order ( generic -- seq ) + method-classes sort-classes ; + +: nearest-class ( class generic -- class/f ) + method-classes interesting-classes smallest-class ; + +: method-for-class ( class generic -- method/f ) + [ nip ] [ nearest-class ] 2bi dup [ swap method ] [ 2drop f ] if ; GENERIC: effective-method ( generic -- method ) \ effective-method t "no-compile" set-word-prop : next-method-class ( class generic -- class/f ) - order [ class<= ] with filter reverse dup length 1 = - [ drop f ] [ second ] if ; + method-classes [ class< ] with filter smallest-class ; : next-method ( class generic -- method/f ) [ next-method-class ] keep method ; diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor index 5edbc54bd8..5359f473ac 100644 --- a/core/generic/hook/hook.factor +++ b/core/generic/hook/hook.factor @@ -23,4 +23,4 @@ M: hook-combination mega-cache-quot M: hook-generic definer drop \ HOOK: f ; M: hook-generic effective-method - [ "combination" word-prop var>> get ] keep (effective-method) ; \ No newline at end of file + [ "combination" word-prop var>> get ] keep method-for-object ; \ No newline at end of file diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index e0e8b91a2c..297684014b 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -50,7 +50,7 @@ ERROR: no-math-method left right generic ; : object-method ( generic -- quot ) - object bootstrap-word applicable-method ; + object bootstrap-word (math-method) ; : math-method ( word class1 class2 -- quot ) 2dup and [ [ 2array [ declare ] curry nip ] [ math-upgrade nip ] - [ math-class-max over order min-class applicable-method ] + [ math-class-max over nearest-class (math-method) ] 3tri 3append ] [ 2drop object-method diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 8a53368062..9e773fe700 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -42,8 +42,8 @@ M: single-combination next-method-quot* ( class generic combination -- quot ) ] [ 3drop f ] if ] with-combination ; -: (effective-method) ( obj word -- method ) - [ [ order [ instance? ] with find-last nip ] keep method ] +: method-for-object ( obj word -- method ) + [ [ method-classes [ instance? ] with filter smallest-class ] keep method ] [ "default-method" word-prop ] bi or ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 0d1220beac..35d299145d 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -40,7 +40,7 @@ M: standard-combination dispatch# #>> ; M: standard-generic effective-method [ datastack ] dip [ "combination" word-prop #>> swap nth ] keep - (effective-method) ; + method-for-object ; : inline-cache-quot ( word methods miss-word -- quot ) [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;