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

basis/alien/parser/parser.factor

@@ -59,64 +59,65 @@ ERROR: *-in-c-type-name name ;
         [ ]
     } cleave ;
 
-: normalize-c-arg ( type name -- type' name' )
-    [ length ]
-    [
-        [ CHAR: * = ] trim-head
-        [ length - CHAR: * <array> append ] keep
-    ] bi
-    [ parse-c-type ] dip ;
-
 <PRIVATE
 GENERIC: return-type-name ( type -- name )
 
 M: object return-type-name drop "void" ;
 M: word return-type-name name>> ;
 M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
+
+: parse-pointers ( type name -- type' name' )
+    "*" ?head
+    [ [ <pointer> ] dip parse-pointers ] when ;
+
 PRIVATE>
 
-: parse-arglist ( parameters return -- types effect )
+: scan-function-name ( -- return function )
-    [
+    scan-c-type scan parse-pointers ;
-        2 group [ first2 normalize-c-arg 2array ] map
+
-        unzip [ "," ?tail drop ] map
+:: (scan-c-args) ( end-marker types names -- )
-    ]
+    scan :> type-str
-    [ [ { } ] [ return-type-name 1array ] if-void ]
+    type-str end-marker = [
-    bi* <effect> ;
+        type-str { "(" ")" } member? [
+            type-str parse-c-type :> type
+            scan "," ?tail drop :> name
+            type name parse-pointers :> ( type' name' )
+            type' types push name' names push
+        ] unless
+        end-marker types names (scan-c-args)
+    ] unless ;
+
+: scan-c-args ( end-marker -- types names )
+    V{ } clone V{ } clone [ (scan-c-args) ] 2keep [ >array ] bi@ ;
 
 : function-quot ( return library function types -- quot )
     '[ _ _ _ _ alien-invoke ] ;
 
-:: make-function ( return library function parameters -- word quot effect )
+: function-effect ( names return -- effect )
-    return function normalize-c-arg :> ( return function )
+    [ { } ] [ return-type-name 1array ] if-void <effect> ;
-    function create-in dup reset-generic
-    return library function
-    parameters return parse-arglist [ function-quot ] dip ;
 
-: parse-arg-tokens ( -- tokens )
+:: make-function ( return function library types names -- word quot effect )
-    ";" parse-tokens [ "()" subseq? not ] filter ;
+    function create-in dup reset-generic
+    return library function types function-quot
+    names return function-effect ;
 
 : (FUNCTION:) ( -- word quot effect )
-    scan "c-library" get scan parse-arg-tokens make-function ;
+    scan-function-name "c-library" get ";" scan-c-args make-function ;
-
-: define-function ( return library function parameters -- )
-    make-function define-declared ;
 
 : callback-quot ( return types abi -- quot )
     '[ [ _ _ _ ] dip alien-callback ] ;
 
-:: make-callback-type ( lib return type-name parameters -- word quot effect )
+:: make-callback-type ( lib return type-name types names -- word quot effect )
-    return type-name normalize-c-arg :> ( return type-name )
     type-name current-vocab create :> type-word 
     type-word [ reset-generic ] [ reset-c-type ] bi
     void* type-word typedef
-    parameters return parse-arglist :> ( types callback-effect )
+    type-word names return function-effect "callback-effect" set-word-prop
-    type-word callback-effect "callback-effect" set-word-prop
     type-word lib "callback-library" set-word-prop
     type-word return types lib library-abi callback-quot (( quot -- alien )) ;
 
 : (CALLBACK:) ( -- word quot effect )
     "c-library" get
-    scan scan parse-arg-tokens make-callback-type ;
+    scan-function-name ";" scan-c-args make-callback-type ;
 
 PREDICATE: alien-function-word < word
     def>> {

basis/alien/syntax/syntax-docs.factor

@@ -112,11 +112,6 @@ HELP: c-struct?
 { $values { "c-type" "a C type" } { "?" "a boolean" } }
 { $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
 
-HELP: define-function
-{ $values { "return" "a C return type" } { "library" "a logical library name" } { "function" "a C function name" } { "parameters" "a sequence of C parameter types" } }
-{ $description "Defines a word named " { $snippet "function" } " in the current vocabulary (see " { $link "vocabularies" } "). The word calls " { $link alien-invoke } " with the specified parameters." }
-{ $notes "This word is used to implement the " { $link POSTPONE: FUNCTION: } " parsing word." } ;
-
 HELP: C-GLOBAL:
 { $syntax "C-GLOBAL: type name" }
 { $values { "type" "a C type" } { "name" "a C global variable name" } }

basis/calendar/calendar.factor

@@ -170,18 +170,6 @@ M: timestamp easter ( timestamp -- timestamp )
 : microseconds ( x -- duration ) 1000000 / seconds ;
 : nanoseconds ( x -- duration ) 1000000000 / seconds ;
 
-GENERIC: year ( obj -- n )
-M: integer year ;
-M: timestamp year year>> ;
-
-GENERIC: month ( obj -- n )
-M: integer month ;
-M: timestamp month month>> ;
-
-GENERIC: day ( obj -- n )
-M: integer day ;
-M: timestamp day day>> ;
-
 GENERIC: leap-year? ( obj -- ? )
 
 M: integer leap-year? ( year -- ? )

basis/calendar/format/format.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math math.order math.parser math.functions kernel
+USING: accessors arrays calendar calendar.format.macros
-sequences io accessors arrays io.streams.string splitting
+combinators io io.streams.string kernel math math.functions
-combinators calendar calendar.format.macros present ;
+math.order math.parser present sequences typed ;
 IN: calendar.format
 
 : pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
@@ -272,16 +272,16 @@ ERROR: invalid-timestamp-format ;
 : (timestamp>ymd) ( timestamp -- )
     { YYYY "-" MM "-" DD } formatted ;
 
-: timestamp>ymd ( timestamp -- str )
+TYPED: timestamp>ymd ( timestamp: timestamp -- str )
     [ (timestamp>ymd) ] with-string-writer ;
 
 : (timestamp>hms) ( timestamp -- )
     { hh ":" mm ":" ss } formatted ;
 
-: timestamp>hms ( timestamp -- str )
+TYPED: timestamp>hms ( timestamp: timestamp -- str )
     [ (timestamp>hms) ] with-string-writer ;
 
-: timestamp>ymdhms ( timestamp -- str )
+TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )
     [
         >gmt
         { (timestamp>ymd) " " (timestamp>hms) } formatted

basis/core-foundation/run-loop/run-loop.factor

@@ -99,22 +99,18 @@ TUPLE: run-loop fds sources timers ;
 
 <PRIVATE
 
-: ((reset-timer)) ( timer counter timestamp -- )
+: (reset-timer) ( timer timestamp -- )
-    nip >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
+    >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
 
-: nano-count>timestamp ( x -- timestamp )
+: nano-count>micros ( x -- n )
-    nano-count - nanoseconds now time+ ;
+    nano-count - 1,000 /f system-micros + ;
-
-: (reset-timer) ( timer counter -- )
-    yield {
-        { [ dup 0 = ] [ now ((reset-timer)) ] }
-        { [ run-queue deque-empty? not ] [ 1 - (reset-timer) ] }
-        { [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
-        [ sleep-queue heap-peek nip nano-count>timestamp ((reset-timer)) ]
-    } cond ;
 
 : reset-timer ( timer -- )
-    10 (reset-timer) ;
+    yield {
+        { [ run-queue deque-empty? not ] [ yield system-micros (reset-timer) ] }
+        { [ sleep-queue heap-empty? ] [ system-micros 1,000,000 + (reset-timer) ] }
+        [ sleep-queue heap-peek nip nano-count>micros (reset-timer) ]
+    } cond ;
 
 PRIVATE>
 

basis/core-foundation/time/time.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: calendar alien.c-types alien.syntax ;
+USING: calendar math alien.c-types alien.syntax memoize system ;
 IN: core-foundation.time
 
 TYPEDEF: double CFTimeInterval
@@ -9,6 +9,8 @@ TYPEDEF: double CFAbsoluteTime
 : >CFTimeInterval ( duration -- interval )
     duration>seconds ; inline
 
-: >CFAbsoluteTime ( timestamp -- time )
+MEMO: epoch ( -- micros )
-    T{ timestamp { year 2001 } { month 1 } { day 1 } } time-
+    T{ timestamp { year 2001 } { month 1 } { day 1 } } timestamp>micros ;
-    duration>seconds ; inline
+
+: >CFAbsoluteTime ( micros -- time )
+    epoch - 1,000,000 /f ; inline

basis/core-foundation/timers/timers.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.syntax system math kernel calendar
 core-foundation core-foundation.time ;
@@ -19,7 +19,7 @@ FUNCTION: CFRunLoopTimerRef CFRunLoopTimerCreate (
 ) ;
 
 : <CFTimer> ( callback -- timer )
-    [ f now >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
+    [ f system-micros >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
 
 FUNCTION: void CFRunLoopTimerInvalidate (
    CFRunLoopTimerRef timer

basis/csv/csv-docs.factor

@@ -1,5 +1,5 @@
 USING: help.syntax help.markup kernel prettyprint sequences
-io.pathnames ;
+io.pathnames strings ;
 IN: csv
 
 HELP: csv
@@ -21,6 +21,20 @@ HELP: csv>file
 }
 { $description "Writes a comma-separated-value structure to a file." } ;
 
+HELP: string>csv
+{ $values
+    { "string" string }
+    { "csv" "csv" }
+}
+{ $description "Parses a string into a sequence of comma-separated-value fields." } ;
+
+HELP: csv>string
+{ $values
+    { "csv" "csv" }
+    { "string" string }
+}
+{ $description "Writes a comma-separated-value structure to a string." } ;
+
 HELP: csv-row
 { $values { "stream" "an input stream" }
           { "row" "an array of fields" } } 
@@ -42,6 +56,10 @@ ARTICLE: "csv" "Comma-separated-values parsing and writing"
 { $subsections file>csv }
 "Writing a csv file:"
 { $subsections csv>file }
+"Reading a string to csv:"
+{ $subsections string>csv }
+"Writing csv to a string:"
+{ $subsections csv>string }
 "Changing the delimiter from a comma:"
 { $subsections with-delimiter }
 "Reading from a stream:"

basis/csv/csv.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007, 2008 Phil Dawes
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences io namespaces make combinators
-unicode.categories io.files combinators.short-circuit ;
+unicode.categories io.files combinators.short-circuit
+io.streams.string ;
 IN: csv
 
 SYMBOL: delimiter
@@ -65,6 +66,9 @@ PRIVATE>
     [ [ (csv) ] { } make ] with-input-stream
     dup last { "" } = [ but-last ] when ;
 
+: string>csv ( string -- csv )
+    <string-reader> csv ;
+
 : file>csv ( path encoding -- csv )
     <file-reader> csv ;
 
@@ -97,7 +101,17 @@ PRIVATE>
     [ delimiter get write1 ]
     [ escape-if-required write ] interleave nl ; inline
 
+<PRIVATE
+
+: (write-csv) ( rows -- )
+    [ write-row ] each ;
+    
+PRIVATE>
+
 : write-csv ( rows stream -- )
-    [ [ write-row ] each ] with-output-stream ;
+    [ (write-csv) ] with-output-stream ;
+
+: csv>string ( csv -- string )
+    [ (write-csv) ] with-string-writer ;
     
 : csv>file ( rows path encoding -- ) <file-writer> write-csv ;

basis/delegate/delegate.factor

@@ -157,6 +157,6 @@ M: protocol definer drop \ PROTOCOL: \ ; ;
 M: protocol group-words protocol-words ;
 
 SYNTAX: SLOT-PROTOCOL:
-    CREATE-WORD ";" parse-tokens
+    CREATE-WORD ";"
-    [ [ reader-word ] [ writer-word ] bi 2array ] map concat
+    [ [ reader-word ] [ writer-word ] bi 2array ]
-    define-protocol ;
+    map-tokens concat define-protocol ;

basis/game/input/input.factor

@@ -108,6 +108,6 @@ SYMBOLS: pressed released ;
 {
     { [ os windows? ] [ "game.input.xinput" require ] }
     { [ os macosx? ] [ "game.input.iokit" require ] }
-    { [ os linux? ] [ "game.input.linux" require ] }
+    { [ os linux? ] [ "game.input.x11" require ] }
     [ ]
 } cond

basis/game/input/linux/authors.txt

@@ -1 +0,0 @@
-Erik Charlebois

basis/game/input/linux/linux.factor

@@ -1,47 +0,0 @@
-! Copyright (C) 2010 Erik Charlebois.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel game.input namespaces classes bit-arrays vectors ;
-IN: game.input.linux
-
-SINGLETON: linux-game-input-backend
-
-linux-game-input-backend game-input-backend set-global
-
-M: linux-game-input-backend (open-game-input)
-    ;
-
-M: linux-game-input-backend (close-game-input)
-    ;
-
-M: linux-game-input-backend (reset-game-input)
-    ;
-
-M: linux-game-input-backend get-controllers
-    { } ;
-
-M: linux-game-input-backend product-string
-    drop "" ;
-     
-M: linux-game-input-backend product-id
-    drop f ;
-     
-M: linux-game-input-backend instance-id
-    drop f ;
-     
-M: linux-game-input-backend read-controller
-    drop controller-state new ;
-     
-M: linux-game-input-backend calibrate-controller
-    drop ;
-     
-M: linux-game-input-backend vibrate-controller
-    3drop ;
-     
-M: linux-game-input-backend read-keyboard
-    256 <bit-array> keyboard-state boa ;
-     
-M: linux-game-input-backend read-mouse
-    0 0 0 0 2 <vector> mouse-state boa ;
-     
-M: linux-game-input-backend reset-mouse
-    ;

basis/game/input/x11/authors.txt

@@ -0,0 +1,2 @@
+Erik Charlebois
+William Schlieper

basis/game/input/x11/x11.factor

@@ -0,0 +1,92 @@
+! Copyright (C) 2010 Erik Charlebois, William Schlieper.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel game.input namespaces
+classes bit-arrays system sequences vectors x11 x11.xlib ;
+IN: game.input.x11
+
+SINGLETON: x11-game-input-backend
+
+x11-game-input-backend game-input-backend set-global
+
+M: x11-game-input-backend (open-game-input)
+    ;
+
+M: x11-game-input-backend (close-game-input)
+    ;
+
+M: x11-game-input-backend (reset-game-input)
+    ;
+
+M: x11-game-input-backend get-controllers
+    { } ;
+
+M: x11-game-input-backend product-string
+    drop "" ;
+     
+M: x11-game-input-backend product-id
+    drop f ;
+     
+M: x11-game-input-backend instance-id
+    drop f ;
+     
+M: x11-game-input-backend read-controller
+    drop controller-state new ;
+     
+M: x11-game-input-backend calibrate-controller
+    drop ;
+     
+M: x11-game-input-backend vibrate-controller
+    3drop ;
+
+HOOK: x>hid-bit-order os ( -- x )
+
+M: linux x>hid-bit-order
+    {
+        0 0 0 0 0 0 0 0 
+        0 41 30 31 32 33 34 35 
+        36 37 38 39 45 46 42 43 
+        20 26 8 21 23 28 24 12 
+        18 19 47 48 40 224 4 22 
+        7 9 10 11 13 14 15 51 
+        52 53 225 49 29 27 6 25 
+        5 17 16 54 55 56 229 85 
+        226 44 57 58 59 60 61 62 
+        63 64 65 66 67 83 71 95 
+        96 97 86 92 93 94 87 91 
+        90 89 98 99 0 0 0 68 
+        69 0 0 0 0 0 0 0 
+        88 228 84 70 0 0 74 82 
+        75 80 79 77 81 78 73 76 
+        127 129 128 102 103 0 72 0 
+        0 0 0 227 231 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+        0 0 0 0 0 0 0 0 
+    } ; inline
+     
+: x-bits>hid-bits ( bit-array -- bit-array )
+    256 iota [ 2array ] { } 2map-as [ first ] filter [ second ] map
+    x>hid-bit-order [ nth ] curry map
+    256 <bit-array> swap [ t swap pick set-nth ] each ;
+        
+M: x11-game-input-backend read-keyboard
+    dpy get 256 <bit-array> [ XQueryKeymap drop ] keep
+    x-bits>hid-bits keyboard-state boa ;
+     
+M: x11-game-input-backend read-mouse
+    0 0 0 0 2 <vector> mouse-state boa ;
+     
+M: x11-game-input-backend reset-mouse
+    ;

basis/grouping/grouping.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.order strings arrays vectors sequences
-sequences.private accessors fry combinators.short-circuit ;
+sequences.private accessors fry combinators.short-circuit
+combinators ;
 IN: grouping
 
 <PRIVATE
@@ -114,7 +115,15 @@ INSTANCE: sliced-clumps abstract-clumps
 
 : all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
 
-TUPLE: circular-slice < slice ;
+TUPLE: circular-slice
+    { from read-only }
+    { to   read-only }
+    { seq  read-only } ;
+INSTANCE: circular-slice virtual-sequence
+M: circular-slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
+M: circular-slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
+M: circular-slice length [ to>> ] [ from>> ] bi - ; inline
+M: circular-slice virtual-exemplar seq>> ; inline
 M: circular-slice virtual@
     [ from>> + ] [ seq>> ] bi [ length slice-mod ] keep ; inline
 

basis/locals/parser/parser.factor

@@ -21,6 +21,9 @@ SYMBOL: in-lambda?
 : make-locals ( seq -- words assoc )
     [ [ make-local ] map ] H{ } make-assoc ;
 
+: parse-local-defs ( -- words assoc )
+    [ "|" [ make-local ] map-tokens ] H{ } make-assoc ;
+
 : make-local-word ( name def -- word )
     [ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
     "local-word-def" set-word-prop ;
@@ -42,12 +45,12 @@ SYMBOL: locals
     [ \ ] parse-until >quotation ] ((parse-lambda)) ;
 
 : parse-lambda ( -- lambda )
-    "|" parse-tokens make-locals
+    parse-local-defs
     (parse-lambda) <lambda>
     ?rewrite-closures ;
 
 : parse-multi-def ( locals -- multi-def )
-    ")" parse-tokens swap [ [ make-local ] map ] bind <multi-def> ;
+    [ ")" [ make-local ] map-tokens ] bind <multi-def> ;
 
 : parse-def ( name/paren locals -- def )
     over "(" = [ nip parse-multi-def ] [ [ make-local ] bind <def> ] if ;

basis/match/match.factor

@@ -17,7 +17,7 @@ SYMBOL: _
     [ define-match-var ] each ;
 
 SYNTAX: MATCH-VARS: ! vars ...
-    ";" parse-tokens define-match-vars ;
+    ";" [ define-match-var ] each-token ;
 
 : match-var? ( symbol -- bool )
     dup word? [ "match-var" word-prop ] [ drop f ] if ;

basis/opengl/gl/extensions/extensions.factor

@@ -11,11 +11,11 @@ ERROR: unknown-gl-platform ;
     [ unknown-gl-platform ]
 } cond use-vocab >>
 
-SYMBOL: +gl-function-number-counter+
+SYMBOL: +gl-function-counter+
 SYMBOL: +gl-function-pointers+
 
 : reset-gl-function-number-counter ( -- )
-    0 +gl-function-number-counter+ set-global ;
+    0 +gl-function-counter+ set-global ;
 : reset-gl-function-pointers ( -- )
     100 <hashtable> +gl-function-pointers+ set-global ;
     
@@ -23,9 +23,9 @@ SYMBOL: +gl-function-pointers+
 reset-gl-function-pointers
 reset-gl-function-number-counter
 
-: gl-function-number ( -- n )
+: gl-function-counter ( -- n )
-    +gl-function-number-counter+ get-global
+    +gl-function-counter+ get-global
-    dup 1 + +gl-function-number-counter+ set-global ;
+    dup 1 + +gl-function-counter+ set-global ;
 
 : gl-function-pointer ( names n -- funptr )
     gl-function-context 2array dup +gl-function-pointers+ get-global at
@@ -41,18 +41,15 @@ reset-gl-function-number-counter
 : indirect-quot ( function-ptr-quot return types abi -- quot )
     '[ @  _ _ _ alien-indirect ] ;
 
-:: define-indirect ( abi return function-ptr-quot function-name parameters -- )
+:: define-indirect ( abi return function-name function-ptr-quot types names -- )
     function-name create-in dup reset-generic
-    function-ptr-quot return
+    function-ptr-quot return types abi indirect-quot
-    parameters return parse-arglist [ abi indirect-quot ] dip
+    names return function-effect
     define-declared ;
 
 SYNTAX: GL-FUNCTION:
     gl-function-calling-convention
-    scan-c-type
+    scan-function-name
-    scan dup
+    "{" expect "}" parse-tokens over prefix
-    scan drop "}" parse-tokens swap prefix
+    gl-function-counter '[ _ _ gl-function-pointer ]
-    gl-function-number
+    ";" scan-c-args define-indirect ;
-    [ gl-function-pointer ] 2curry swap
-    ";" parse-tokens [ "()" subseq? not ] filter
-    define-indirect ;

basis/specialized-arrays/specialized-arrays.factor

@@ -168,7 +168,7 @@ M: c-type-word c-direct-array-constructor
 M: pointer c-direct-array-constructor drop void* c-direct-array-constructor ;
 
 SYNTAX: SPECIALIZED-ARRAYS:
-    ";" parse-tokens [ parse-c-type define-array-vocab use-vocab ] each ;
+    ";" [ parse-c-type define-array-vocab use-vocab ] each-token ;
 
 SYNTAX: SPECIALIZED-ARRAY:
     scan-c-type define-array-vocab use-vocab ;

basis/specialized-vectors/specialized-vectors.factor

@@ -56,11 +56,11 @@ PRIVATE>
     generate-vocab ;
 
 SYNTAX: SPECIALIZED-VECTORS:
-    ";" parse-tokens [
+    ";" [
         parse-c-type
         [ define-array-vocab use-vocab ]
         [ define-vector-vocab use-vocab ] bi
-    ] each ;
+    ] each-token ;
 
 SYNTAX: SPECIALIZED-VECTOR:
     scan-c-type

basis/ui/gadgets/worlds/worlds.factor

@@ -33,7 +33,8 @@ CONSTANT: default-world-window-controls
     }
 
 TUPLE: world < track
-    active? focused? grab-input?
+    active? focused? grab-input? fullscreen?
+    saved-position
     layers
     title status status-owner
     text-handle handle images

basis/windows/com/syntax/syntax.factor

@@ -2,8 +2,8 @@ USING: alien alien.c-types alien.accessors alien.parser
 effects kernel windows.ole32 parser lexer splitting grouping
 sequences namespaces assocs quotations generalizations
 accessors words macros alien.syntax fry arrays layouts math
-classes.struct windows.kernel32 ;
+classes.struct windows.kernel32 locals ;
-FROM: alien.parser.private => return-type-name ;
+FROM: alien.parser.private => parse-pointers return-type-name ;
 IN: windows.com.syntax
 
 <PRIVATE
@@ -18,7 +18,7 @@ MACRO: com-invoke ( n return parameters -- )
 TUPLE: com-interface-definition word parent iid functions ;
 C: <com-interface-definition> com-interface-definition
 
-TUPLE: com-function-definition name return parameters ;
+TUPLE: com-function-definition return name parameter-types parameter-names ;
 C: <com-function-definition> com-function-definition
 
 SYMBOL: +com-interface-definitions+
@@ -37,19 +37,20 @@ ERROR: no-com-interface interface ;
 : save-com-interface-definition ( definition -- )
     dup word>> +com-interface-definitions+ get-global set-at ;
 
-: (parse-com-function) ( tokens -- definition )
+: (parse-com-function) ( return name -- definition )
-    [ second ]
+    ")" scan-c-args
-    [ first parse-c-type ]
+    [ pointer: void prefix ] [ "this" prefix ] bi*
-    [
-        3 tail [ CHAR: , swap remove ] map
-        2 group [ first2 normalize-c-arg 2array ] map
-        { void* "this" } prefix
-    ] tri
     <com-function-definition> ;
 
+:: (parse-com-functions) ( functions -- )
+    scan dup ";" = [ drop ] [
+        parse-c-type scan parse-pointers
+        (parse-com-function) functions push
+        functions (parse-com-functions)
+    ] if ;
+
 : parse-com-functions ( -- functions )
-    ";" parse-tokens { ")" } split harvest
+    V{ } clone [ (parse-com-functions) ] keep >array ;
-    [ (parse-com-function) ] map ;
 
 : (iid-word) ( definition -- word )
     word>> name>> "-iid" append create-in ;
@@ -66,20 +67,10 @@ ERROR: no-com-interface interface ;
     dup parent>> [ family-tree-functions ] [ { } ] if*
     swap functions>> append ;
 
-: (invocation-quot) ( function return parameters -- quot )
+:: (define-word-for-function) ( function interface n -- )
-    [ first ] map [ com-invoke ] 3curry ;
+    function interface (function-word)
-
+    n function [ return>> ] [ parameter-types>> ] bi '[ _ _ _ com-invoke ]
-: (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
+    function [ parameter-names>> ] [ return>> ] bi function-effect
-    swap
-    [ [ second ] map ]
-    [ dup void? [ drop { } ] [ return-type-name 1array ] if ] bi*
-    <effect> ;
-
-: (define-word-for-function) ( function interface n -- )
-    -rot [ (function-word) swap ] 2keep drop
-    [ return>> ] [ parameters>> ] bi
-    [ (invocation-quot) ] 2keep
-    (stack-effect-from-return-and-parameters)
     define-declared ;
 
 : define-words-for-com-interface ( definition -- )

basis/windows/com/wrapper/wrapper.factor

@@ -110,11 +110,7 @@ unless
     keep (next-vtbl-counter) '[
         swap [
             [ name>> _ _ (callback-word) ]
-            [ return>> ] [
+            [ return>> ] [ parameter-types>> dup length ] tri
-                parameters>>
-                [ [ first ] map ]
-                [ length ] bi
-            ] tri
         ] [
             first2 (finish-thunk)
         ] bi*

basis/windows/directx/d3d9/d3d9.factor

@@ -109,7 +109,7 @@ COM-INTERFACE: IDirect3DDevice9 IUnknown {D0223B96-BF7A-43fd-92BD-A43B0D82B9EB}
     HRESULT Clear ( DWORD Count, D3DRECT* pRects, DWORD Flags, D3DCOLOR Color, float Z, DWORD Stencil )
     HRESULT SetTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix )
     HRESULT GetTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix )
-    HRESULT MultiplyTransform ( D3DTRANSFORMSTATETYPE, D3DMATRIX* )
+    HRESULT MultiplyTransform ( D3DTRANSFORMSTATETYPE State, D3DMATRIX* pMatrix )
     HRESULT SetViewport ( D3DVIEWPORT9* pViewport )
     HRESULT GetViewport ( D3DVIEWPORT9* pViewport )
     HRESULT SetMaterial ( D3DMATERIAL9* pMaterial )

basis/windows/user32/user32.factor

@@ -580,8 +580,8 @@ CONSTANT: SWP_HIDEWINDOW 128
 CONSTANT: SWP_NOCOPYBITS 256
 CONSTANT: SWP_NOOWNERZORDER 512
 CONSTANT: SWP_NOSENDCHANGING 1024
-CONSTANT: SWP_DRAWFRAME SWP_FRAMECHANGED
+ALIAS: SWP_DRAWFRAME SWP_FRAMECHANGED
-CONSTANT: SWP_NOREPOSITION SWP_NOOWNERZORDER
+ALIAS: SWP_NOREPOSITION SWP_NOOWNERZORDER
 CONSTANT: SWP_DEFERERASE 8192
 CONSTANT: SWP_ASYNCWINDOWPOS 16384
 
@@ -1250,7 +1250,7 @@ FUNCTION: UINT EnumClipboardFormats ( UINT format ) ;
 ! FUNCTION: EnumDesktopWindows
 ! FUNCTION: EnumDisplayDevicesA
 ! FUNCTION: EnumDisplayDevicesW
-! FUNCTION: EnumDisplayMonitors
+! FUNCTION: BOOL EnumDisplayMonitors ( HDC hdc, LPCRECT lprcClip, MONITORENUMPROC lpfnEnum, LPARAM dwData ) ;
 ! FUNCTION: EnumDisplaySettingsA
 ! FUNCTION: EnumDisplaySettingsExA
 ! FUNCTION: EnumDisplaySettingsExW
@@ -1327,7 +1327,7 @@ FUNCTION: HWND GetDesktopWindow ( ) ;
 ! FUNCTION: GetDlgItemTextW
 FUNCTION: uint GetDoubleClickTime ( ) ;
 FUNCTION: HWND GetFocus ( ) ;
-! FUNCTION: GetForegroundWindow
+FUNCTION: HWND GetForegroundWindow ( ) ;
 ! FUNCTION: GetGuiResources
 ! FUNCTION: GetGUIThreadInfo
 ! FUNCTION: GetIconInfo
@@ -1428,7 +1428,8 @@ FUNCTION: HWND GetWindow ( HWND hWnd, UINT uCmd ) ;
 FUNCTION: LONG_PTR GetWindowLongW ( HANDLE hWnd, int index ) ;
 ALIAS: GetWindowLong GetWindowLongW
 
-FUNCTION: LONG_PTR GetWindowLongPtr ( HWND hWnd, int nIndex ) ;
+FUNCTION: LONG_PTR GetWindowLongPtrW ( HWND hWnd, int nIndex ) ;
+ALIAS: GetWindowLongPtr GetWindowLongPtrW
 ! FUNCTION: GetWindowModuleFileName
 ! FUNCTION: GetWindowModuleFileNameA
 ! FUNCTION: GetWindowModuleFileNameW
@@ -1776,7 +1777,8 @@ ALIAS: SetWindowLong SetWindowLongW
 ! FUNCTION: SetWindowPlacement
 FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
 
-FUNCTION: LONG_PTR SetWindowLongPtr ( HWND hWnd, int nIndex, LONG_PTR dwNewLong ) ;
+FUNCTION: LONG_PTR SetWindowLongPtrW ( HWND hWnd, int nIndex, LONG_PTR dwNewLong ) ;
+ALIAS: SetWindowLongPtr SetWindowLongPtrW
 
 : HWND_BOTTOM ( -- alien ) 1 <alien> ;
 : HWND_NOTOPMOST ( -- alien ) -2 <alien> ;

basis/x11/xlib/xlib.factor

@@ -1406,3 +1406,8 @@ X-FUNCTION: c-string setlocale ( int category, c-string name ) ;
 X-FUNCTION: Bool XSupportsLocale ( ) ;
 
 X-FUNCTION: c-string XSetLocaleModifiers ( c-string modifier_list ) ;
+
+! uncategorized xlib bindings
+
+X-FUNCTION: int XQueryKeymap ( Display* display, char[32] keys_return ) ;
+

core/alien/strings/strings.factor

@@ -66,6 +66,7 @@ M: string string>symbol string>symbol* ;
 M: sequence string>symbol [ string>symbol* ] map ;
 
 [
-    8 special-object utf8 alien>string string>cpu \ cpu set-global
+     8 special-object utf8 alien>string string>cpu \ cpu set-global
-    9 special-object utf8 alien>string string>os \ os set-global
+     9 special-object utf8 alien>string string>os \ os set-global
+    67 special-object utf8 alien>string \ vm-compiler set-global
 ] "alien.strings" add-startup-hook

core/classes/tuple/parser/parser.factor

@@ -68,23 +68,28 @@ ERROR: invalid-slot-name name ;
 
 ERROR: bad-literal-tuple ;
 
-: parse-slot-value ( -- )
+ERROR: bad-slot-name class slot ;
-    scan scan-object 2array , scan {
+
+: check-slot-name ( class slots name -- name )
+    2dup swap slot-named* nip [ 2nip ] [ nip bad-slot-name ] if ;
+
+: parse-slot-value ( class slots -- )
+    scan check-slot-name scan-object 2array , scan {
         { f [ \ } unexpected-eof ] }
         { "}" [ ] }
         [ bad-literal-tuple ]
     } case ;
 
-: (parse-slot-values) ( -- )
+: (parse-slot-values) ( class slots -- )
-    parse-slot-value
+    2dup parse-slot-value
     scan {
-        { f [ \ } unexpected-eof ] }
+        { f [ 2drop \ } unexpected-eof ] }
         { "{" [ (parse-slot-values) ] }
-        { "}" [ ] }
+        { "}" [ 2drop ] }
-        [ bad-literal-tuple ]
+        [ 2nip bad-literal-tuple ]
     } case ;
 
-: parse-slot-values ( -- values )
+: parse-slot-values ( class slots -- values )
     [ (parse-slot-values) ] { } make ;
 
 GENERIC# boa>object 1 ( class slots -- tuple )
@@ -92,8 +97,6 @@ GENERIC# boa>object 1 ( class slots -- tuple )
 M: tuple-class boa>object
     swap prefix >tuple ;
 
-ERROR: bad-slot-name class slot ;
-
 : check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index )
     over [ drop ] [ nip nip nip bad-slot-name ] if ;
 
@@ -109,7 +112,7 @@ ERROR: bad-slot-name class slot ;
     scan {
         { f [ unexpected-eof ] }
         { "f" [ drop \ } parse-until boa>object ] }
-        { "{" [ parse-slot-values assoc>object ] }
+        { "{" [ 2dup parse-slot-values assoc>object ] }
         { "}" [ drop new ] }
         [ bad-literal-tuple ]
     } case ;

core/lexer/lexer-docs.factor

@@ -66,10 +66,20 @@ HELP: still-parsing?
 { $values { "lexer" lexer } { "?" "a boolean" } }
 { $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ;
 
+HELP: each-token
+{ $values { "end" string } { "quot" { $quotation "( token -- )" } } }
+{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read." }
+{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." }
+$parsing-note ;
+
+HELP: map-tokens
+{ $values { "end" string } { "quot" { $quotation "( token -- object )" } } { "seq" "a new sequence of " { $snippet "object" } "s" } }
+{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". " { $snippet "quot" } " is called on each token as it is read, and the results are collected into a new output sequence." }
+$parsing-note ;
+
 HELP: parse-tokens
 { $values { "end" string } { "seq" "a new sequence of strings" } }
-{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." }
+{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way. This word is equivalent to " { $link map-tokens } " with an empty quotation." }
-{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." }
 $parsing-note ;
 
 HELP: unexpected

core/lexer/lexer.factor

@@ -82,15 +82,17 @@ PREDICATE: unexpected-eof < unexpected
     [ unexpected-eof ]
     if* ;
 
-: (parse-tokens) ( accum end -- accum )
+: (each-token) ( end quot -- pred quot )
-    scan 2dup = [
+    [ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline
-        2drop
+
-    ] [
+: each-token ( end quot -- )
-        [ pick push (parse-tokens) ] [ unexpected-eof ] if*
+    (each-token) while drop ; inline
-    ] if ;
+
+: map-tokens ( end quot -- seq )
+    (each-token) produce nip ; inline
 
 : parse-tokens ( end -- seq )
-    100 <vector> swap (parse-tokens) >array ;
+    [ ] map-tokens ;
 
 TUPLE: lexer-error line column line-text error ;
 

core/parser/parser-docs.factor

@@ -52,8 +52,12 @@ ARTICLE: "parsing-tokens" "Parsing raw tokens"
 $nl
 "One example is the " { $link POSTPONE: USING: } " parsing word."
 { $see POSTPONE: USING: } 
-"It reads a list of vocabularies terminated by " { $link POSTPONE: ; } ". However, the vocabulary names do not name words, except by coincidence; so " { $link parse-until } " cannot be used here. Instead, a lower-level word is called:"
+"It reads a list of vocabularies terminated by " { $link POSTPONE: ; } ". However, the vocabulary names do not name words, except by coincidence; so " { $link parse-until } " cannot be used here. Instead, a set of lower-level combinators can be used:"
-{ $subsections parse-tokens } ;
+{ $subsections
+    each-token
+    map-tokens
+    parse-tokens
+} ;
 
 ARTICLE: "parsing-words" "Parsing words"
 "The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
@@ -164,7 +168,7 @@ HELP: parse-until
 { $examples "This word is used to implement " { $link POSTPONE: ARTICLE: } "." }
 $parsing-note ;
 
-{ parse-tokens (parse-until) parse-until } related-words
+{ parse-tokens each-token map-tokens (parse-until) parse-until } related-words
 
 HELP: (parse-lines)
 { $values { "lexer" lexer } { "quot" "a new " { $link quotation } } }

core/syntax/syntax.factor

@@ -51,7 +51,7 @@ IN: bootstrap.syntax
 
     "UNUSE:" [ scan unuse-vocab ] define-core-syntax
 
-    "USING:" [ ";" parse-tokens [ use-vocab ] each ] define-core-syntax
+    "USING:" [ ";" [ use-vocab ] each-token ] define-core-syntax
 
     "QUALIFIED:" [ scan dup add-qualified ] define-core-syntax
 
@@ -125,13 +125,11 @@ IN: bootstrap.syntax
     ] define-core-syntax
 
     "SYMBOLS:" [
-        ";" parse-tokens
+        ";" [ create-in dup reset-generic define-symbol ] each-token
-        [ create-in dup reset-generic define-symbol ] each
     ] define-core-syntax
 
     "SINGLETONS:" [
-        ";" parse-tokens
+        ";" [ create-class-in define-singleton-class ] each-token
-        [ create-class-in define-singleton-class ] each
     ] define-core-syntax
 
     "DEFER:" [

core/system/system.factor

@@ -24,6 +24,8 @@ UNION: unix bsd solaris linux haiku ;
 
 : os ( -- class ) \ os get-global ; foldable
 
+: vm-compiler ( -- string ) \ vm-compiler get-global ; foldable
+
 <PRIVATE
 
 : string>cpu ( str -- class )

extra/calendar/holidays/us/us.factor

@@ -33,7 +33,7 @@ HOLIDAY-NAME: new-years-day us-federal "New Year's Day"
 HOLIDAY: martin-luther-king-day january 3 monday-of-month ;
 HOLIDAY-NAME: martin-luther-king-day us-federal "Martin Luther King Day"
 
-HOLIDAY: inauguration-day year dup 4 neg rem + january 20 >>day ;
+HOLIDAY: inauguration-day january 20 >>day [ dup 4 neg rem + ] change-year ;
 HOLIDAY-NAME: inauguration-day us "Inauguration Day"
 
 HOLIDAY: washingtons-birthday february 3 monday-of-month ;

extra/fullscreen/authors.txt

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

extra/fullscreen/fullscreen.factor

@@ -0,0 +1,142 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays classes.struct fry kernel
+literals locals make math math.bitwise multiline sequences
+slots.syntax ui.backend.windows vocabs.loader windows.errors
+windows.gdi32 windows.kernel32 windows.types windows.user32
+ui.gadgets.worlds ;
+IN: fullscreen
+
+: hwnd>hmonitor ( HWND -- HMONITOR )
+    MONITOR_DEFAULTTOPRIMARY MonitorFromWindow ;
+
+: desktop-hmonitor ( -- HMONITOR )
+    GetDesktopWindow hwnd>hmonitor ;
+
+:: (monitor-info>devmodes) ( monitor-info n -- )
+    DEVMODE <struct>
+        DEVMODE heap-size >>dmSize
+        { DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } flags >>dmFields
+    :> devmode
+
+    monitor-info szDevice>>
+    n
+    devmode
+    EnumDisplaySettings 0 = [
+        devmode ,
+        monitor-info n 1 + (monitor-info>devmodes)
+    ] unless ;
+
+: monitor-info>devmodes ( monito-info -- devmodes )
+    [ 0 (monitor-info>devmodes) ] { } make ;
+
+: hmonitor>monitor-info ( HMONITOR -- monitor-info )
+    MONITORINFOEX <struct>
+        MONITORINFOEX heap-size >>cbSize
+    [ GetMonitorInfo win32-error=0/f ] keep ;
+
+: hwnd>monitor-info ( HWND -- monitor-info )
+    hwnd>hmonitor hmonitor>monitor-info ;
+
+: hmonitor>devmodes ( HMONITOR -- devmodes )
+    hmonitor>monitor-info monitor-info>devmodes ;
+
+: desktop-devmodes ( -- DEVMODEs )
+    desktop-hmonitor hmonitor>devmodes ;
+
+: desktop-monitor-info ( -- monitor-info )
+    desktop-hmonitor hmonitor>monitor-info ;
+
+: desktop-RECT ( -- RECT )
+    GetDesktopWindow RECT <struct> [ GetWindowRect win32-error=0/f ] keep ;
+
+ERROR: display-change-error n ;
+
+: fullscreen-mode ( monitor-info devmode -- )
+    [ szDevice>> ] dip f CDS_FULLSCREEN f
+    ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
+    [ drop ] [ display-change-error ] if ;
+
+: non-fullscreen-mode ( monitor-info devmode -- )
+    [ szDevice>> ] dip f 0 f
+    ChangeDisplaySettingsEx dup DISP_CHANGE_SUCCESSFUL =
+    [ drop ] [ display-change-error ] if ;
+
+: get-style ( hwnd n -- style )
+    GetWindowLongPtr [ win32-error=0/f ] keep ;
+    
+: set-style ( hwnd n style -- )
+    SetWindowLongPtr win32-error=0/f ;
+
+: change-style ( hwnd n quot -- )
+    [ 2dup get-style ] dip call set-style ; inline
+
+: set-fullscreen-styles ( hwnd -- )
+    [ GWL_STYLE [ WS_OVERLAPPEDWINDOW unmask ] change-style ]
+    [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags bitor ] change-style ] bi ;
+
+: set-non-fullscreen-styles ( hwnd -- )
+    [ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ]
+    [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags unmask ] change-style ] bi ;
+
+ERROR: unsupported-resolution triple ;
+
+:: find-devmode ( triple hwnd -- devmode )
+    hwnd hwnd>hmonitor hmonitor>devmodes
+    [
+        slots{ dmPelsWidth dmPelsHeight dmBitsPerPel }
+        triple =
+    ] find nip [ triple unsupported-resolution ] unless* ;
+
+:: set-fullscreen-window-position ( hwnd triple -- )
+    hwnd f
+    desktop-monitor-info rcMonitor>> slots{ left top } first2
+    triple first2
+    {
+        SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER
+        SWP_NOREPOSITION SWP_NOZORDER
+    } flags
+    SetWindowPos win32-error=0/f ;
+
+:: enable-fullscreen ( triple hwnd -- rect )
+    hwnd hwnd>RECT :> rect
+    
+    desktop-monitor-info
+    triple GetDesktopWindow find-devmode
+    hwnd set-fullscreen-styles
+    fullscreen-mode
+
+    hwnd triple set-fullscreen-window-position
+    rect ;
+
+:: set-window-position ( hwnd rect -- )
+    hwnd f rect get-RECT-dimensions SWP_FRAMECHANGED
+    SetWindowPos win32-error=0/f ;
+
+:: disable-fullscreen ( rect triple hwnd -- )
+    desktop-monitor-info
+    triple
+    GetDesktopWindow find-devmode non-fullscreen-mode
+    hwnd set-non-fullscreen-styles
+    hwnd rect set-window-position ;
+
+: enable-factor-fullscreen ( triple -- rect )
+    GetForegroundWindow enable-fullscreen ;
+
+: disable-factor-fullscreen ( rect triple -- )
+    GetForegroundWindow disable-fullscreen ;
+
+:: (set-fullscreen) ( world triple fullscreen? -- )
+    world fullscreen?>> fullscreen? xor [
+        triple
+        world handle>> hWnd>>
+        fullscreen? [
+            enable-fullscreen world (>>saved-position)
+        ] [
+            [ world saved-position>> ] 2dip disable-fullscreen
+        ] if
+        fullscreen? world (>>fullscreen?)
+    ] when ;
+
+: set-fullscreen ( gadget triple fullscreen? -- )
+    [ find-world ] 2dip (set-fullscreen) ;

extra/fullscreen/platforms.txt

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

extra/game/loop/loop.factor

@@ -66,7 +66,7 @@ TUPLE: game-loop-error game-loop error ;
 
 : (run-loop) ( loop -- )
     dup running?>>
-    [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ]
+    [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
     [ drop ] if ;
 
 : run-loop ( loop -- )

extra/poker/poker.factor

@@ -263,4 +263,4 @@ ERROR: bad-suit-symbol ch ;
     string>value value>hand-name ;
 
 SYNTAX: HAND{
-    "}" parse-tokens [ card> ] { } map-as suffix! ;
+    "}" [ card> ] map-tokens suffix! ;

extra/slots/syntax/authors.txt

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

extra/slots/syntax/syntax-docs.factor

@@ -0,0 +1,32 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: slots.syntax
+
+HELP: slots[
+{ $description "Outputs several slot values to the stack." }
+{ $example "USING: kernel prettyprint slots.syntax ;"
+           "IN: slots.syntax.example"
+           "TUPLE: rectangle width height ;"
+           "T{ rectangle { width 3 } { height 5 } } slots[ width height ] [ . ] bi@"
+           """3
+5"""
+} ;
+
+HELP: slots{
+{ $description "Outputs an array of slot values from a tuple." }
+{ $example "USING: prettyprint slots.syntax ;"
+           "IN: slots.syntax.example"
+           "TUPLE: rectangle width height ;"
+           "T{ rectangle { width 3 } { height 5 } } slots{ width height } ."
+           "{ 3 5 }"
+} ;
+
+ARTICLE: "slots.syntax" "Slots syntax sugar"
+"The " { $vocab-link "slots.syntax" } " vocabulary provides an alternative syntax for taking a sequence of slots from a tuple." $nl
+"Syntax sugar for cleaving slots to the stack:"
+{ $subsections POSTPONE: slots[ }
+"Syntax sugar for cleaving slots to an array:"
+{ $subsections POSTPONE: slots{ } ;
+
+ABOUT: "slots.syntax"

extra/slots/syntax/syntax-tests.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test slots.syntax ;
+IN: slots.syntax.tests
+
+TUPLE: slot-test a b c ;
+
+[ 1 2 3 ] [ T{ slot-test f 1 2 3 } slots[ a b c ] ] unit-test
+[ 3 ] [ T{ slot-test f 1 2 3 } slots[ c ] ] unit-test
+[ ] [ T{ slot-test f 1 2 3 } slots[ ] ] unit-test
+
+[ { 1 2 3 } ] [ T{ slot-test f 1 2 3 } slots{ a b c } ] unit-test
+[ { 3 } ] [ T{ slot-test f 1 2 3 } slots{ c } ] unit-test
+[ { } ] [ T{ slot-test f 1 2 3 } slots{ } ] unit-test

extra/slots/syntax/syntax.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators combinators.smart fry lexer quotations
+sequences slots  ;
+IN: slots.syntax
+
+SYNTAX: slots[
+    "]" [ reader-word 1quotation ] map-tokens
+    '[ _ cleave ] append! ;
+
+SYNTAX: slots{
+    "}" [ reader-word 1quotation ] map-tokens
+    '[ [ _ cleave ] output>array ] append! ;

extra/vars/vars.factor

@@ -28,4 +28,4 @@ SYNTAX: VAR: ! var
     [ define-var ] each ;
 
 SYNTAX: VARS: ! vars ...
-    ";" parse-tokens define-vars ;
+    ";" [ define-var ] each-token ;

extra/webapps/help/search.xml

@@ -23,7 +23,7 @@
 
 		<p>This is the <a href="http://factorcode.org" target="_top">Factor</a>
 		documentation, generated offline from a
-		<code>load-everything</code> image. If you want, you can also browse the
+		<code>load-all</code> image. If you want, you can also browse the
 		documentation from within the <a href="http://factorcode.org" target="_top">Factor</a> UI.</p>
 		
 		<p>You may search article titles below; for example, try searching for "HTTP".</p>

vm/factor.cpp

@@ -136,6 +136,7 @@ void factor_vm::init_factor(vm_parameters *p)
 	special_objects[OBJ_EXECUTABLE] = allot_alien(false_object,(cell)p->executable_path);
 	special_objects[OBJ_ARGS] = false_object;
 	special_objects[OBJ_EMBEDDED] = false_object;
+	special_objects[OBJ_VM_COMPILER] = allot_alien(false_object,(cell)FACTOR_COMPILER_VERSION);
 
 	/* We can GC now */
 	gc_off = false;

vm/master.hpp

@@ -29,6 +29,21 @@
 #include <vector>
 #include <iostream>
 
+#define FACTOR_STRINGIZE(x) #x
+
+/* Record compiler version */
+#if defined(__clang__)
+	#define FACTOR_COMPILER_VERSION "Clang (GCC " __VERSION__ ")"
+#elif defined(__INTEL_COMPILER)
+	#define FACTOR_COMPILER_VERSION "Intel C Compiler " FACTOR_STRINGIZE(__INTEL_COMPILER)
+#elif defined(__GNUC__)
+	#define FACTOR_COMPILER_VERSION "GCC " __VERSION__
+#elif defined(_MSC_FULL_VER)
+	#define FACTOR_COMPILER_VERSION "Microsoft Visual C++ " FACTOR_STRINGIZE(_MSC_FULL_VER)
+#else
+	#define FACTOR_COMPILER_VERSION "unknown"
+#endif
+
 /* Detect target CPU type */
 #if defined(__arm__)
 	#define FACTOR_ARM

vm/objects.hpp

@@ -95,6 +95,8 @@ enum special_object {
 	OBJ_THREADS = 64,
 	OBJ_RUN_QUEUE = 65,
 	OBJ_SLEEP_QUEUE = 66,
+
+	OBJ_VM_COMPILER = 67,    /* version string of the compiler we were built with */
 };
 
 /* save-image-and-exit discards special objects that are filled in on startup