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

basis/alien/parser/parser.factor

@@ -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 ]
+    [ 2drop scan create-class-in scan-object next-enum-member "}" expect ]
-    [ [ create-in ] dip next-enum-member ] if ;
+    [ [ create-class-in ] dip next-enum-member ] if ;
 
 : parse-enum-members ( members counter token -- members )
     dup ";" = not

basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -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 ;
 

basis/compiler/tests/alien.factor

@@ -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

basis/windows/errors/errors.factor

@@ -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 ;
 

basis/windows/iphlpapi/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/windows/iphlpapi/iphlpapi.factor

@@ -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 ;

basis/windows/iphlpapi/platforms.txt

@@ -0,0 +1 @@
+windows

basis/windows/registry/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/windows/registry/platforms.txt

@@ -0,0 +1 @@
+windows

basis/windows/registry/registry-tests.factor

@@ -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

basis/windows/registry/registry.factor

@@ -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 ;

basis/windows/windows.factor

@@ -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 }

extra/webapps/mason/backend/backend-tests.factor

@@ -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
 
             counter-value
             increment-counter-value
             increment-counter-value
+        ] with-transaction
     ] with-db
 ] unit-test

extra/webapps/mason/backend/backend.factor

@@ -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 ;
-        counter-tuple [ 0 or 1 + dup ] change-value update-tuple
-    ] with-transaction ;
 
 : funny-builders ( -- crashed broken )
     builder new select-tuples

extra/webapps/mason/dashboard/dashboard.factor

@@ -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