-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
{ $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:"
{ $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." } ;
{ $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." } ;
{ $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
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
ARTICLE: "c-types-specs" "C type specifiers"
-"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]" }
{ $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 } "." ;
[ 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 ;
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 ;
+
: 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
M: alien-function-word synopsis*
{
[ seeing-word ]
+ [ def>> second [ \ LIBRARY: [ text ] pprint-prefix ] when* ]
[ definer. ]
[ def>> first pprint-c-type ]
[ pprint-word ]
- [ <block "(" text pprint-function-args ")" text block> ]
+ [
+ <block "(" text
+ [ def>> 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 ]
+ [
+ <block "(" text
+ [ def>> second ] [ "callback-effect" word-prop in>> ] bi
+ pprint-function-args
+ ")" text block>
+ ]
} cleave ;
{ $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" } }
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
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 ;
[ t ] [ \ <tuple>-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
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
- specific-method
+ method-for-class
] if
] if ;
! 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
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
: 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system ;
+IN: system-info.backend
+
+HOOK: cpus os ( -- n )
+HOOK: cpu-mhz os ( -- n )
+HOOK: memory-load os ( -- n )
+HOOK: physical-mem os ( -- n )
+HOOK: available-mem os ( -- n )
+HOOK: total-page-file os ( -- n )
+HOOK: available-page-file os ( -- n )
+HOOK: total-virtual-mem os ( -- n )
+HOOK: available-virtual-mem os ( -- n )
+HOOK: available-virtual-extended-mem os ( -- n )
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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
+specialized-arrays ;
+SPECIALIZED-ARRAY: char
+IN: system-info.linux
+
+: (uname) ( buf -- int )
+ "int" f "uname" { "char*" } alien-invoke ;
+
+: uname ( -- seq )
+ 65536 <char-array> [ (uname) io-error ] keep
+ "\0" split harvest [ utf8 decode ] map
+ 6 "" pad-tail ;
+
+: sysname ( -- string ) uname first ;
+: nodename ( -- string ) uname second ;
+: release ( -- string ) uname third ;
+: version ( -- string ) uname fourth ;
+: machine ( -- string ) uname 4 swap nth ;
+: domainname ( -- string ) uname 5 swap nth ;
+
+: kernel-version ( -- seq )
+ release ".-" split harvest 5 "" pad-tail ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings alien.syntax
+byte-arrays kernel namespaces sequences unix
+system-info.backend system io.encodings.utf8 ;
+IN: system-info.macosx
+
+! See /usr/include/sys/sysctl.h for constants
+
+LIBRARY: libc
+FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
+
+: make-int-array ( seq -- byte-array )
+ [ <int> ] map concat ;
+
+: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
+ over [ f 0 sysctl io-error ] dip ;
+
+: sysctl-query ( seq n -- byte-array )
+ [ [ make-int-array ] [ length ] bi ] dip
+ [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
+
+: sysctl-query-string ( seq -- n )
+ 4096 sysctl-query utf8 alien>string ;
+
+: sysctl-query-uint ( seq -- n )
+ 4 sysctl-query *uint ;
+
+: sysctl-query-ulonglong ( seq -- n )
+ 8 sysctl-query *ulonglong ;
+
+: machine ( -- str ) { 6 1 } sysctl-query-string ;
+: model ( -- str ) { 6 2 } sysctl-query-string ;
+M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
+: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
+M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
+: user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
+: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
+: disknames ( -- n ) { 6 8 } 8 sysctl-query ;
+: diskstats ( -- n ) { 6 9 } 8 sysctl-query ;
+: epoch ( -- n ) { 6 10 } sysctl-query-uint ;
+: floating-point ( -- n ) { 6 11 } sysctl-query-uint ;
+: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
+: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
+: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
+M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
+: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
+: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
+: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
+: l2-cache-settings ( -- n ) { 6 19 } sysctl-query-uint ;
+: l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ;
+: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
+: l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ;
+: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
+: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
+: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
--- /dev/null
+unportable
--- /dev/null
+Query the operating system for hardware information in a platform-independent way
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel math prettyprint io math.parser
+combinators vocabs.loader system-info.backend system ;
+IN: system-info
+
+: write-unit ( x n str -- )
+ [ 2^ /f number>string write bl ] [ write ] bi* ;
+
+: kb ( x -- ) 10 "kB" write-unit ;
+: megs ( x -- ) 20 "MB" write-unit ;
+: gigs ( x -- ) 30 "GB" write-unit ;
+: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
+
+<< {
+ { [ os windows? ] [ "system-info.windows" ] }
+ { [ os linux? ] [ "system-info.linux" ] }
+ { [ os macosx? ] [ "system-info.macosx" ] }
+ [ f ]
+} cond [ require ] when* >>
+
+: system-report. ( -- )
+ "CPUs: " write cpus number>string write nl
+ "CPU Speed: " write cpu-mhz ghz nl
+ "Physical RAM: " write physical-mem megs nl ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.data system-info kernel math namespaces
+windows windows.kernel32 system-info.backend system ;
+IN: system-info.windows.ce
+
+: memory-status ( -- MEMORYSTATUS )
+ "MEMORYSTATUS" <c-object>
+ "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
+ dup GlobalMemoryStatus ;
+
+M: wince cpus ( -- n ) 1 ;
+
+M: wince memory-load ( -- n )
+ memory-status MEMORYSTATUS-dwMemoryLoad ;
+
+M: wince physical-mem ( -- n )
+ memory-status MEMORYSTATUS-dwTotalPhys ;
+
+M: wince available-mem ( -- n )
+ memory-status MEMORYSTATUS-dwAvailPhys ;
+
+M: wince total-page-file ( -- n )
+ memory-status MEMORYSTATUS-dwTotalPageFile ;
+
+M: wince available-page-file ( -- n )
+ memory-status MEMORYSTATUS-dwAvailPageFile ;
+
+M: wince total-virtual-mem ( -- n )
+ memory-status MEMORYSTATUS-dwTotalVirtual ;
+
+M: wince available-virtual-mem ( -- n )
+ memory-status MEMORYSTATUS-dwAvailVirtual ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings
+kernel libc math namespaces system-info.backend
+system-info.windows windows windows.advapi32
+windows.kernel32 system byte-arrays windows.errors
+classes classes.struct accessors ;
+IN: system-info.windows.nt
+
+M: winnt cpus ( -- n )
+ system-info dwNumberOfProcessors>> ;
+
+: memory-status ( -- MEMORYSTATUSEX )
+ "MEMORYSTATUSEX" <struct>
+ dup class heap-size >>dwLength
+ dup GlobalMemoryStatusEx win32-error=0/f ;
+
+M: winnt memory-load ( -- n )
+ memory-status dwMemoryLoad>> ;
+
+M: winnt physical-mem ( -- n )
+ memory-status ullTotalPhys>> ;
+
+M: winnt available-mem ( -- n )
+ memory-status ullAvailPhys>> ;
+
+M: winnt total-page-file ( -- n )
+ memory-status ullTotalPageFile>> ;
+
+M: winnt available-page-file ( -- n )
+ memory-status ullAvailPageFile>> ;
+
+M: winnt total-virtual-mem ( -- n )
+ memory-status ullTotalVirtual>> ;
+
+M: winnt available-virtual-mem ( -- n )
+ memory-status ullAvailVirtual>> ;
+
+: computer-name ( -- string )
+ MAX_COMPUTERNAME_LENGTH 1 +
+ [ <byte-array> dup ] keep <uint>
+ GetComputerName win32-error=0/f alien>native-string ;
+
+: username ( -- string )
+ UNLEN 1 +
+ [ <byte-array> dup ] keep <uint>
+ GetUserName win32-error=0/f alien>native-string ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+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 specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
+IN: system-info.windows
+
+: system-info ( -- SYSTEM_INFO )
+ SYSTEM_INFO <struct> [ GetSystemInfo ] keep ;
+
+: page-size ( -- n )
+ system-info dwPageSize>> ;
+
+! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
+: processor-type ( -- n )
+ system-info dwProcessorType>> ;
+
+! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk
+: processor-architecture ( -- n )
+ system-info dwOemId>> HEX: ffff0000 bitand ;
+
+: os-version ( -- os-version )
+ OSVERSIONINFO <struct>
+ OSVERSIONINFO heap-size >>dwOSVersionInfoSize
+ dup GetVersionEx win32-error=0/f ;
+
+: windows-major ( -- n )
+ os-version dwMajorVersion>> ;
+
+: windows-minor ( -- n )
+ os-version dwMinorVersion>> ;
+
+: windows-build# ( -- n )
+ os-version dwBuildNumber>> ;
+
+: windows-platform-id ( -- n )
+ os-version dwPlatformId>> ;
+
+: windows-service-pack ( -- string )
+ os-version szCSDVersion>> alien>native-string ;
+
+: feature-present? ( n -- ? )
+ IsProcessorFeaturePresent zero? not ;
+
+: sse2? ( -- ? )
+ PF_XMMI64_INSTRUCTIONS_AVAILABLE feature-present? ;
+
+: sse3? ( -- ? )
+ PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
+
+: get-directory ( word -- str )
+ [ MAX_UNICODE_PATH [ <ushort-array> ] keep dupd ] dip
+ execute win32-error=0/f alien>native-string ; inline
+
+: windows-directory ( -- str )
+ \ GetWindowsDirectory get-directory ;
+
+: system-directory ( -- str )
+ \ GetSystemDirectory get-directory ;
+
+: system-windows-directory ( -- str )
+ \ GetSystemWindowsDirectory get-directory ;
+
+<<
+{
+ { [ os wince? ] [ "system-info.windows.ce" ] }
+ { [ os winnt? ] [ "system-info.windows.nt" ] }
+} cond require >>
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
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 )
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 )
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 )
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
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" } ;
{ $subsection class-and }\r
{ $subsection class-or }\r
{ $subsection classes-intersect? }\r
-{ $subsection min-class }\r
"Low-level implementation detail:"\r
{ $subsection flatten-class }\r
{ $subsection flatten-builtin-class }\r
"Operations:"\r
{ $subsection class< }\r
{ $subsection sort-classes }\r
+{ $subsection smallest-class }\r
"Metaclass order:"\r
{ $subsection rank-class } ;\r
\r
{ $values { "first" class } { "second" class } { "?" "a boolean" } }\r
{ $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." } ;\r
\r
-HELP: min-class\r
-{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }\r
-{ $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 } "." } ;\r
+HELP: smallest-class\r
+{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } }\r
+{ $description "Outputs a minimum class from the given sequence." } ;\r
classes.private classes.union classes.mixin classes.predicate\r
vectors source-files compiler.units growable random\r
stack-checker effects kernel.private sbufs math.order\r
-classes.tuple accessors ;\r
+classes.tuple accessors generic.private ;\r
IN: classes.algebra.tests\r
\r
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
] unit-test\r
\r
! Test method inlining\r
+[ real ] [ { real sequence } smallest-class ] unit-test\r
+[ real ] [ { sequence real } smallest-class ] unit-test\r
+\r
+: min-class ( class classes -- class/f )\r
+ interesting-classes smallest-class ;\r
+\r
[ f ] [ fixnum { } min-class ] unit-test\r
\r
[ string ] [\r
[ dup largest-class [ over delete-nth ] dip ]\r
produce nip ;\r
\r
-: min-class ( class seq -- class/f )\r
- over [ classes-intersect? ] curry filter\r
- [ drop f ] [\r
- [ nip ] [ [ class<= ] with all? ] 2bi [ last ] [ drop f ] if\r
+: smallest-class ( classes -- class/f )\r
+ [ f ] [\r
+ natural-sort <reversed>\r
+ [ ] [ [ class<= ] most ] map-reduce\r
] if-empty ;\r
\r
GENERIC: (flatten-class) ( class -- )\r
[ ] [ "IN: generic.tests.a" <string-reader> "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
: method ( class generic -- method/f )
"methods" word-prop at ;
+<PRIVATE
+
+: interesting-class? ( class1 class2 -- ? )
+ {
+ ! Case 1: no intersection. Discard and keep going
+ { [ 2dup classes-intersect? not ] [ 2drop t ] }
+ ! Case 2: class1 contained in class2. Add to
+ ! interesting set and keep going.
+ { [ 2dup class<= ] [ nip , t ] }
+ ! Case 3: class1 and class2 are incomparable. Give up
+ [ 2drop f ]
+ } cond ;
+
+: interesting-classes ( class classes -- interesting/f )
+ [ [ interesting-class? ] with all? ] { } make and ;
+
+PRIVATE>
+
+: method-classes ( generic -- classes )
+ "methods" word-prop keys ;
+
: order ( generic -- seq )
- "methods" word-prop keys sort-classes ;
+ method-classes sort-classes ;
+
+: nearest-class ( class generic -- class/f )
+ method-classes interesting-classes smallest-class ;
-: specific-method ( class generic -- method/f )
- [ nip ] [ order min-class ] 2bi
- dup [ swap method ] [ 2drop f ] if ;
+: 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 ;
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
<PRIVATE
-: applicable-method ( generic class -- quot )
+: (math-method) ( generic class -- quot )
over method
[ 1quotation ]
[ default-math-method ] ?if ;
PRIVATE>
: 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
] [ 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 ;
M: standard-generic effective-method
[ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
- (effective-method) ;
+ method-for-object ;
: inline-cache-quot ( word methods miss-word -- quot )
[ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: system ;
-IN: system-info.backend
-
-HOOK: cpus os ( -- n )
-HOOK: cpu-mhz os ( -- n )
-HOOK: memory-load os ( -- n )
-HOOK: physical-mem os ( -- n )
-HOOK: available-mem os ( -- n )
-HOOK: total-page-file os ( -- n )
-HOOK: available-page-file os ( -- n )
-HOOK: total-virtual-mem os ( -- n )
-HOOK: available-virtual-mem os ( -- n )
-HOOK: available-virtual-extended-mem os ( -- n )
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! 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
-specialized-arrays ;
-SPECIALIZED-ARRAY: char
-IN: system-info.linux
-
-: (uname) ( buf -- int )
- "int" f "uname" { "char*" } alien-invoke ;
-
-: uname ( -- seq )
- 65536 <char-array> [ (uname) io-error ] keep
- "\0" split harvest [ utf8 decode ] map
- 6 "" pad-tail ;
-
-: sysname ( -- string ) uname first ;
-: nodename ( -- string ) uname second ;
-: release ( -- string ) uname third ;
-: version ( -- string ) uname fourth ;
-: machine ( -- string ) uname 4 swap nth ;
-: domainname ( -- string ) uname 5 swap nth ;
-
-: kernel-version ( -- seq )
- release ".-" split harvest 5 "" pad-tail ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings alien.syntax
-byte-arrays kernel namespaces sequences unix
-system-info.backend system io.encodings.utf8 ;
-IN: system-info.macosx
-
-! See /usr/include/sys/sysctl.h for constants
-
-LIBRARY: libc
-FUNCTION: int sysctl ( int* name, uint namelen, void* oldp, size_t* oldlenp, void* newp, size_t newlen ) ;
-
-: make-int-array ( seq -- byte-array )
- [ <int> ] map concat ;
-
-: (sysctl-query) ( name namelen oldp oldlenp -- oldp )
- over [ f 0 sysctl io-error ] dip ;
-
-: sysctl-query ( seq n -- byte-array )
- [ [ make-int-array ] [ length ] bi ] dip
- [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
-
-: sysctl-query-string ( seq -- n )
- 4096 sysctl-query utf8 alien>string ;
-
-: sysctl-query-uint ( seq -- n )
- 4 sysctl-query *uint ;
-
-: sysctl-query-ulonglong ( seq -- n )
- 8 sysctl-query *ulonglong ;
-
-: machine ( -- str ) { 6 1 } sysctl-query-string ;
-: model ( -- str ) { 6 2 } sysctl-query-string ;
-M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
-: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
-M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
-: user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
-: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
-: disknames ( -- n ) { 6 8 } 8 sysctl-query ;
-: diskstats ( -- n ) { 6 9 } 8 sysctl-query ;
-: epoch ( -- n ) { 6 10 } sysctl-query-uint ;
-: floating-point ( -- n ) { 6 11 } sysctl-query-uint ;
-: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
-: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
-: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
-M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
-: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
-: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
-: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
-: l2-cache-settings ( -- n ) { 6 19 } sysctl-query-uint ;
-: l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ;
-: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
-: l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ;
-: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
-: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
-: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
+++ /dev/null
-unportable
+++ /dev/null
-Query the operating system for hardware information in a platform-independent way
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math prettyprint io math.parser
-combinators vocabs.loader system-info.backend system ;
-IN: system-info
-
-: write-unit ( x n str -- )
- [ 2^ /f number>string write bl ] [ write ] bi* ;
-
-: kb ( x -- ) 10 "kB" write-unit ;
-: megs ( x -- ) 20 "MB" write-unit ;
-: gigs ( x -- ) 30 "GB" write-unit ;
-: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
-
-<< {
- { [ os windows? ] [ "system-info.windows" ] }
- { [ os linux? ] [ "system-info.linux" ] }
- { [ os macosx? ] [ "system-info.macosx" ] }
- [ f ]
-} cond [ require ] when* >>
-
-: system-report. ( -- )
- "CPUs: " write cpus number>string write nl
- "CPU Speed: " write cpu-mhz ghz nl
- "Physical RAM: " write physical-mem megs nl ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.data system-info kernel math namespaces
-windows windows.kernel32 system-info.backend system ;
-IN: system-info.windows.ce
-
-: memory-status ( -- MEMORYSTATUS )
- "MEMORYSTATUS" <c-object>
- "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
- dup GlobalMemoryStatus ;
-
-M: wince cpus ( -- n ) 1 ;
-
-M: wince memory-load ( -- n )
- memory-status MEMORYSTATUS-dwMemoryLoad ;
-
-M: wince physical-mem ( -- n )
- memory-status MEMORYSTATUS-dwTotalPhys ;
-
-M: wince available-mem ( -- n )
- memory-status MEMORYSTATUS-dwAvailPhys ;
-
-M: wince total-page-file ( -- n )
- memory-status MEMORYSTATUS-dwTotalPageFile ;
-
-M: wince available-page-file ( -- n )
- memory-status MEMORYSTATUS-dwAvailPageFile ;
-
-M: wince total-virtual-mem ( -- n )
- memory-status MEMORYSTATUS-dwTotalVirtual ;
-
-M: wince available-virtual-mem ( -- n )
- memory-status MEMORYSTATUS-dwAvailVirtual ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings
-kernel libc math namespaces system-info.backend
-system-info.windows windows windows.advapi32
-windows.kernel32 system byte-arrays windows.errors
-classes classes.struct accessors ;
-IN: system-info.windows.nt
-
-M: winnt cpus ( -- n )
- system-info dwNumberOfProcessors>> ;
-
-: memory-status ( -- MEMORYSTATUSEX )
- "MEMORYSTATUSEX" <struct>
- dup class heap-size >>dwLength
- dup GlobalMemoryStatusEx win32-error=0/f ;
-
-M: winnt memory-load ( -- n )
- memory-status dwMemoryLoad>> ;
-
-M: winnt physical-mem ( -- n )
- memory-status ullTotalPhys>> ;
-
-M: winnt available-mem ( -- n )
- memory-status ullAvailPhys>> ;
-
-M: winnt total-page-file ( -- n )
- memory-status ullTotalPageFile>> ;
-
-M: winnt available-page-file ( -- n )
- memory-status ullAvailPageFile>> ;
-
-M: winnt total-virtual-mem ( -- n )
- memory-status ullTotalVirtual>> ;
-
-M: winnt available-virtual-mem ( -- n )
- memory-status ullAvailVirtual>> ;
-
-: computer-name ( -- string )
- MAX_COMPUTERNAME_LENGTH 1 +
- [ <byte-array> dup ] keep <uint>
- GetComputerName win32-error=0/f alien>native-string ;
-
-: username ( -- string )
- UNLEN 1 +
- [ <byte-array> dup ] keep <uint>
- GetUserName win32-error=0/f alien>native-string ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-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 specialized-arrays ;
-SPECIALIZED-ARRAY: ushort
-IN: system-info.windows
-
-: system-info ( -- SYSTEM_INFO )
- SYSTEM_INFO <struct> [ GetSystemInfo ] keep ;
-
-: page-size ( -- n )
- system-info dwPageSize>> ;
-
-! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
-: processor-type ( -- n )
- system-info dwProcessorType>> ;
-
-! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk
-: processor-architecture ( -- n )
- system-info dwOemId>> HEX: ffff0000 bitand ;
-
-: os-version ( -- os-version )
- OSVERSIONINFO <struct>
- OSVERSIONINFO heap-size >>dwOSVersionInfoSize
- dup GetVersionEx win32-error=0/f ;
-
-: windows-major ( -- n )
- os-version dwMajorVersion>> ;
-
-: windows-minor ( -- n )
- os-version dwMinorVersion>> ;
-
-: windows-build# ( -- n )
- os-version dwBuildNumber>> ;
-
-: windows-platform-id ( -- n )
- os-version dwPlatformId>> ;
-
-: windows-service-pack ( -- string )
- os-version szCSDVersion>> alien>native-string ;
-
-: feature-present? ( n -- ? )
- IsProcessorFeaturePresent zero? not ;
-
-: sse2? ( -- ? )
- PF_XMMI64_INSTRUCTIONS_AVAILABLE feature-present? ;
-
-: sse3? ( -- ? )
- PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
-
-: get-directory ( word -- str )
- [ MAX_UNICODE_PATH [ <ushort-array> ] keep dupd ] dip
- execute win32-error=0/f alien>native-string ; inline
-
-: windows-directory ( -- str )
- \ GetWindowsDirectory get-directory ;
-
-: system-directory ( -- str )
- \ GetSystemDirectory get-directory ;
-
-: system-windows-directory ( -- str )
- \ GetSystemWindowsDirectory get-directory ;
-
-<<
-{
- { [ os wince? ] [ "system-info.windows.ce" ] }
- { [ os winnt? ] [ "system-info.windows.nt" ] }
-} cond require >>
projects / factor.git / commitdiff