steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Anton Gorenko 2010-10-01 10:13:19 +06:00
parent 711e3336fa b052aa61cb
commit 0ad5f6bd44
15 changed files with 324 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/alien/parser/parser.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien alien.c-types alien.libraries arrays
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
@ -96,8 +96,8 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
: 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

17
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -132,17 +132,30 @@ M: vreg-insn compute-live-intervals* ( insn -- )
[ [ 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 ;

8
basis/compiler/tests/alien.factor
View File

@ -6,7 +6,7 @@ math memory namespaces namespaces.private parser
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
@ -823,3 +823,9 @@ TUPLE: some-tuple x ;
aa-indirect-1 >>x
] compile-call
] unit-test
! GC maps regression
: anton's-regression ( -- )
f (free) f (free) ;
[ ] [ anton's-regression ] unit-test

7
basis/windows/errors/errors.factor
View File

@ -734,6 +734,13 @@ ERROR: windows-error n string ;
: 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 ;

1
basis/windows/iphlpapi/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

75
basis/windows/iphlpapi/iphlpapi.factor Normal file
View File

@ -0,0 +1,75 @@
! 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 ;

1
basis/windows/iphlpapi/platforms.txt Normal file
View File

@ -0,0 +1 @@
windows

1
basis/windows/registry/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/windows/registry/platforms.txt Normal file
View File

@ -0,0 +1 @@
windows

7
basis/windows/registry/registry-tests.factor Normal file
View File

@ -0,0 +1,7 @@
! 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

194
basis/windows/registry/registry.factor Normal file
View File

@ -0,0 +1,194 @@
! 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 ;

1
basis/windows/windows.factor
View File

@ -14,6 +14,7 @@ CONSTANT: MAX_UNICODE_PATH 32768
{ "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 }

12
extra/webapps/mason/backend/backend-tests.factor
View File

@ -5,11 +5,15 @@ IN: webapps.mason.backend.tests
[ "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

6
extra/webapps/mason/backend/backend.factor
View File

@ -58,12 +58,10 @@ counter "COUNTER" {
[ 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

2
extra/webapps/mason/dashboard/dashboard.factor
View File

@ -18,7 +18,7 @@ IN: webapps.mason.downloads
[
[
funny-builders
[ builder-list ] tri@
[ builder-list ] bi@
[ "crashed" set-value ]
[ "broken" set-value ] bi*
] with-mason-db