assocs classes combinators combinators.short-circuit
compiler.units effects grouping kernel parser sequences
splitting words fry locals lexer namespaces summary math
-vocabs.parser words.constant ;
+vocabs.parser words.constant classes.parser ;
IN: alien.parser
SYMBOL: current-library
: parse-enum-member ( members name value -- members value' )
over "{" =
- [ 2drop scan create-in scan-object next-enum-member "}" expect ]
- [ [ create-in ] dip next-enum-member ] if ;
+ [ 2drop scan create-class-in scan-object next-enum-member "}" expect ]
+ [ [ create-class-in ] dip next-enum-member ] if ;
: parse-enum-members ( members counter token -- members )
dup ";" = not
[ [ temp-vregs ] dip '[ _ record-temp ] each ]
2tri ;
+! Extend lifetime intervals of base pointers, so that their
+! values are available even if the base pointer is never used
+! again.
+
+GENERIC: uses-vregs* ( insn -- seq )
+
+M: gc-map-insn uses-vregs* ( insn -- )
+ [ uses-vregs ] [ gc-map>> derived-roots>> values ] bi append ;
+
+M: vreg-insn uses-vregs* uses-vregs ;
+
+M: insn uses-vregs* drop f ;
+
M: clobber-insn compute-live-intervals* ( insn -- )
dup insn#>>
[ [ defs-vregs ] dip '[ _ f record-def ] each ]
- [ [ uses-vregs ] dip '[ _ t record-use ] each ]
+ [ [ uses-vregs* ] dip '[ _ t record-use ] each ]
[ [ temp-vregs ] dip '[ _ record-temp ] each ]
2tri ;
M: hairy-clobber-insn compute-live-intervals* ( insn -- )
dup insn#>>
[ [ defs-vregs ] dip '[ _ t record-def ] each ]
- [ [ uses-vregs ] dip '[ _ t record-use ] each ]
+ [ [ uses-vregs* ] dip '[ _ t record-use ] each ]
[ [ temp-vregs ] dip '[ _ record-temp ] each ]
2tri ;
quotations sequences specialized-arrays stack-checker
stack-checker.errors system threads tools.test words
alien.complex concurrency.promises alien.data
-byte-arrays classes compiler.test ;
+byte-arrays classes compiler.test libc ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
aa-indirect-1 >>x
] compile-call
] unit-test
+
+! GC maps regression
+: anton's-regression ( -- )
+ f (free) f (free) ;
+
+[ ] [ anton's-regression ] unit-test
: win32-error<0 ( n -- ) 0 < [ win32-error ] when ;
: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ;
+: n>win32-error-check ( n -- )
+ dup ERROR_SUCCESS = [
+ drop
+ ] [
+ dup n>win32-error-string windows-error
+ ] if ;
+
: check-invalid-handle ( handle -- handle )
dup INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.syntax
+classes.struct io.encodings.string io.encodings.utf8 kernel
+make sequences windows.errors windows.types ;
+IN: windows.iphlpapi
+
+LIBRARY: iphlpapi
+
+<<
+CONSTANT: DEFAULT_MINIMUM_ENTITIES 32
+CONSTANT: MAX_ADAPTER_ADDRESS_LENGTH 8
+CONSTANT: MAX_ADAPTER_DESCRIPTION_LENGTH 128
+CONSTANT: MAX_ADAPTER_NAME_LENGTH 256
+CONSTANT: MAX_DOMAIN_NAME_LEN 128
+CONSTANT: MAX_HOSTNAME_LEN 128
+CONSTANT: MAX_SCOPE_ID_LEN 256
+CONSTANT: BROADCAST_NODETYPE 1
+CONSTANT: PEER_TO_PEER_NODETYPE 2
+CONSTANT: MIXED_NODETYPE 4
+CONSTANT: HYBRID_NODETYPE 8
+CONSTANT: IF_OTHER_ADAPTERTYPE 0
+CONSTANT: IF_ETHERNET_ADAPTERTYPE 1
+CONSTANT: IF_TOKEN_RING_ADAPTERTYPE 2
+CONSTANT: IF_FDDI_ADAPTERTYPE 3
+CONSTANT: IF_PPP_ADAPTERTYPE 4
+CONSTANT: IF_LOOPBACK_ADAPTERTYPE 5
+>>
+
+CONSTANT: MAX_DOMAIN_NAME_LEN+4 132
+CONSTANT: MAX_HOSTNAME_LEN+4 132
+CONSTANT: MAX_SCOPE_ID_LEN+4 260
+
+STRUCT: IP_ADDRESS_STRING
+ { String char[16] } ;
+
+TYPEDEF: IP_ADDRESS_STRING* PIP_ADDRESS_STRING
+TYPEDEF: IP_ADDRESS_STRING IP_MASK_STRING
+TYPEDEF: IP_MASK_STRING* PIP_MASK_STRING
+
+STRUCT: IP_ADDR_STRING
+ { Next IP_ADDR_STRING* }
+ { IpAddress IP_ADDRESS_STRING }
+ { IpMask IP_MASK_STRING }
+ { Context DWORD } ;
+
+TYPEDEF: IP_ADDR_STRING* PIP_ADDR_STRING
+
+STRUCT: FIXED_INFO
+ { HostName char[MAX_HOSTNAME_LEN+4] }
+ { DomainName char[MAX_DOMAIN_NAME_LEN+4] }
+ { CurrentDnsServer PIP_ADDR_STRING }
+ { DnsServerList IP_ADDR_STRING }
+ { NodeType UINT }
+ { ScopeId char[MAX_SCOPE_ID_LEN+4] }
+ { EnableRouting UINT }
+ { EnableProxy UINT }
+ { EnableDns UINT }
+ { ExtraSpace char[4096] } ;
+
+TYPEDEF: FIXED_INFO* PFIXED_INFO
+
+FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ;
+
+: get-fixed-info ( -- FIXED_INFO )
+ FIXED_INFO <struct> dup byte-length <ulong>
+ [ GetNetworkParams n>win32-error-check ] 2keep drop ;
+
+: dns-server-ips ( -- sequence )
+ get-fixed-info DnsServerList>> [
+ [
+ [ IpAddress>> String>> [ 0 = ] trim-tail utf8 decode , ]
+ [ Next>> ] bi dup
+ ] loop drop
+ ] { } make ;
\ No newline at end of file
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test windows.advapi32 windows.registry ;
+IN: windows.registry.tests
+
+[ ]
+[ HKEY_CURRENT_USER "SOFTWARE\\\\Microsoft" read-registry drop ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types byte-arrays kernel locals sequences
+windows.advapi32 windows.errors math windows
+windows.kernel32 windows.time accessors alien.data
+nested-comments windows.types classes.struct continuations ;
+IN: windows.registry
+
+ERROR: open-key-failed key subkey mode error-string ;
+ERROR: create-key-failed hKey lpSubKey lpClass dwOptions
+samDesired lpSecurityAttributes phkResult lpdwDisposition ;
+
+CONSTANT: registry-value-max-length 16384
+
+:: open-key ( key subkey mode -- hkey )
+ key subkey 0 mode HKEY <c-object>
+ [
+ RegOpenKeyEx dup ERROR_SUCCESS = [
+ drop
+ ] [
+ [ key subkey mode ] dip n>win32-error-string
+ open-key-failed
+ ] if
+ ] keep *uint ;
+
+:: create-key* ( hKey lpSubKey lpClass dwOptions samDesired lpSecurityAttributes -- hkey new? )
+ hKey lpSubKey 0 lpClass dwOptions samDesired lpSecurityAttributes
+ HKEY <c-object>
+ DWORD <c-object>
+ f :> ret!
+ [ RegCreateKeyEx ret! ] 2keep
+ [ *uint ]
+ [ *uint REG_CREATED_NEW_KEY = ] bi*
+ ret ERROR_SUCCESS = [
+ [
+ hKey lpSubKey 0 lpClass dwOptions samDesired
+ lpSecurityAttributes
+ ] dip n>win32-error-string
+ create-key-failed
+ ] unless ;
+
+: create-key ( hkey lsubkey -- hkey )
+ f 0 KEY_ALL_ACCESS f create-key* drop ;
+
+: close-key ( hkey -- )
+ RegCloseKey dup ERROR_SUCCESS = [
+ drop
+ ] [
+ n>win32-error-string throw
+ ] if ;
+
+:: with-open-registry-key ( key subkey mode quot -- )
+ key subkey mode open-key :> hkey
+ [ hkey quot call ]
+ [ hkey close-key ]
+ [ ] cleanup ; inline
+
+:: with-create-registry-key ( key subkey quot -- )
+ key subkey create-key :> hkey
+ [ hkey quot call ]
+ [ hkey close-key ]
+ [ ] cleanup ; inline
+
+<PRIVATE
+
+: grow-buffer ( byte-array -- byte-array' )
+ length 2 * <byte-array> ;
+
+:: reg-query-value-ex ( key subkey ptr1 ptr2 buffer -- buffer )
+ buffer length <uint> :> pdword
+ key subkey ptr1 ptr2 buffer pdword [ RegQueryValueEx ] 2keep
+ rot :> ret
+ ret ERROR_SUCCESS = [
+ *uint head
+ ] [
+ ret ERROR_MORE_DATA = [
+ 2drop
+ key subkey ptr1 ptr2 buffer
+ grow-buffer reg-query-value-ex
+ ] [
+ ret n>win32-error-string throw
+ ] if
+ ] if ;
+
+TUPLE: registry-info
+key
+class-name
+sub-keys
+longest-subkey
+longest-class-string
+#values
+max-value
+max-value-data
+security-descriptor
+last-write-time ;
+
+TUPLE: registry-enum-key ;
+
+
+:: reg-enum-keys ( registry-info -- seq )
+ registry-info sub-keys>> iota [
+ [ registry-info key>> ] dip
+ registry-value-max-length TCHAR <c-array> dup :> registry-value
+ registry-value length dup :> registry-value-length
+ f
+ DWORD <c-object> dup :> type
+ f ! BYTE <c-object> dup :> data
+ f ! BYTE <c-object> dup :> buffer
+ RegEnumKeyEx dup ERROR_SUCCESS = [
+
+ ] [
+ ] if
+ ] map ;
+
+:: reg-query-info-key ( key -- n )
+ key
+ MAX_PATH
+ dup TCHAR <c-array> dup :> class-buffer
+ swap <int> dup :> class-buffer-length
+ f
+ DWORD <c-object> dup :> sub-keys
+ DWORD <c-object> dup :> longest-subkey
+ DWORD <c-object> dup :> longest-class-string
+ DWORD <c-object> dup :> #values
+ DWORD <c-object> dup :> max-value
+ DWORD <c-object> dup :> max-value-data
+ DWORD <c-object> dup :> security-descriptor
+ FILETIME <struct> dup :> last-write-time
+ RegQueryInfoKey :> ret
+ ret ERROR_SUCCESS = [
+ key
+ class-buffer
+ sub-keys *uint
+ longest-subkey *uint
+ longest-class-string *uint
+ #values *uint
+ max-value *uint
+ max-value-data *uint
+ security-descriptor *uint
+ last-write-time FILETIME>timestamp
+ registry-info boa
+ ] [
+ ret n>win32-error-string
+ ] if ;
+
+: set-reg-key ( hkey value type lpdata cbdata -- )
+ [ 0 ] 3dip
+ RegSetValueEx dup ERROR_SUCCESS = [
+ drop
+ ] [
+ "omg" throw
+ ] if ;
+
+: set-reg-binary ( hkey value lpdata cbdata -- )
+ [ REG_BINARY ] 2dip set-reg-key ;
+
+: set-reg-dword ( hkey value lpdata cbdata -- )
+ [ REG_DWORD ] 2dip set-reg-key ;
+
+: set-reg-dword-le ( hkey value lpdata cbdata -- )
+ [ REG_DWORD_LITTLE_ENDIAN ] 2dip set-reg-key ;
+
+: set-reg-dword-be ( hkey value lpdata cbdata -- )
+ [ REG_DWORD_BIG_ENDIAN ] 2dip set-reg-key ;
+
+: set-reg-expand-sz ( hkey value lpdata cbdata -- )
+ [ REG_EXPAND_SZ ] 2dip set-reg-key ;
+
+: set-reg-link ( hkey value lpdata cbdata -- )
+ [ REG_LINK ] 2dip set-reg-key ;
+
+: set-reg-multi-sz ( hkey value lpdata cbdata -- )
+ [ REG_MULTI_SZ ] 2dip set-reg-key ;
+
+: set-reg-none ( hkey value lpdata cbdata -- )
+ [ REG_NONE ] 2dip set-reg-key ;
+
+: set-reg-qword ( hkey value lpdata cbdata -- )
+ [ REG_QWORD ] 2dip set-reg-key ;
+
+: set-reg-qword-le ( hkey value lpdata cbdata -- )
+ [ REG_QWORD_LITTLE_ENDIAN ] 2dip set-reg-key ;
+
+: set-reg-sz ( hkey value lpdata cbdata -- )
+ [ REG_SZ ] 2dip set-reg-key ;
+
+PRIVATE>
+
+: windows-performance-data ( -- byte-array )
+ HKEY_PERFORMANCE_DATA "Global" f f
+ 21 2^ <byte-array> reg-query-value-ex ;
+
+: read-registry ( key subkey -- registry-info )
+ KEY_READ [ reg-query-info-key ] with-open-registry-key ;
\ No newline at end of file
{ "winsock" "ws2_32.dll" stdcall }
{ "mswsock" "mswsock.dll" stdcall }
{ "shell32" "shell32.dll" stdcall }
+ { "iphlpapi" "iphlpapi.dll" stdcall }
{ "libc" "msvcrt.dll" cdecl }
{ "libm" "msvcrt.dll" cdecl }
{ "gl" "opengl32.dll" stdcall }
[ "test.db" temp-file delete-file ] ignore-errors
[ 0 1 2 ] [
+ ! Do it in a with-transaction to simulate semantics of
+ ! with-mason-db
"test.db" temp-file <sqlite-db> [
- init-mason-db
+ [
+ init-mason-db
- counter-value
- increment-counter-value
- increment-counter-value
+ counter-value
+ increment-counter-value
+ increment-counter-value
+ ] with-transaction
] with-db
] unit-test
[ counter new dup insert-tuple ] unless* ;
: counter-value ( -- n )
- [ counter-tuple value>> 0 or ] with-transaction ;
+ counter-tuple value>> 0 or ;
: increment-counter-value ( -- n )
- [
- counter-tuple [ 0 or 1 + dup ] change-value update-tuple
- ] with-transaction ;
+ counter-tuple [ 0 or 1 + dup ] change-value update-tuple ;
: funny-builders ( -- crashed broken )
builder new select-tuples
[
[
funny-builders
- [ builder-list ] tri@
+ [ builder-list ] bi@
[ "crashed" set-value ]
[ "broken" set-value ] bi*
] with-mason-db
projects / factor.git / commitdiff