diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor index cf8c878589..c9ec2c3889 100644 --- a/basis/alien/parser/parser.factor +++ b/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: * append ] keep - ] bi - [ parse-c-type ] dip ; - > ; M: pointer return-type-name to>> return-type-name CHAR: * suffix ; + +: parse-pointers ( type name -- type' name' ) + "*" ?head + [ [ ] dip parse-pointers ] when ; + PRIVATE> -: parse-arglist ( parameters return -- types effect ) - [ - 2 group [ first2 normalize-c-arg 2array ] map - unzip [ "," ?tail drop ] map - ] - [ [ { } ] [ return-type-name 1array ] if-void ] - bi* ; +: scan-function-name ( -- return function ) + scan-c-type scan parse-pointers ; + +:: (scan-c-args) ( end-marker types names -- ) + scan :> type-str + type-str end-marker = [ + 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 ) - return function normalize-c-arg :> ( return function ) - function create-in dup reset-generic - return library function - parameters return parse-arglist [ function-quot ] dip ; +: function-effect ( names return -- effect ) + [ { } ] [ return-type-name 1array ] if-void ; -: parse-arg-tokens ( -- tokens ) - ";" parse-tokens [ "()" subseq? not ] filter ; +:: make-function ( return function library types names -- word quot effect ) + 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 ; - -: define-function ( return library function parameters -- ) - make-function define-declared ; + scan-function-name "c-library" get ";" scan-c-args make-function ; : callback-quot ( return types abi -- quot ) '[ [ _ _ _ ] dip alien-callback ] ; -:: make-callback-type ( lib return type-name parameters -- word quot effect ) - return type-name normalize-c-arg :> ( return type-name ) +:: make-callback-type ( lib return type-name types names -- word quot effect ) 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 callback-effect "callback-effect" set-word-prop + type-word names return function-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>> { diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index 3d1c757035..58b43cec31 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/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" } } diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 1a64ceb646..cd87701aa9 100644 --- a/basis/calendar/calendar.factor +++ b/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 -- ? ) diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index 96d76d0ce8..35e364e6aa 100644 --- a/basis/calendar/format/format.factor +++ b/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 -sequences io accessors arrays io.streams.string splitting -combinators calendar calendar.format.macros present ; +USING: accessors arrays calendar calendar.format.macros +combinators io io.streams.string kernel math math.functions +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 diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 56b5a9c798..c1316eaa16 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -99,22 +99,18 @@ TUPLE: run-loop fds sources timers ; CFAbsoluteTime CFRunLoopTimerSetNextFireDate ; +: (reset-timer) ( timer timestamp -- ) + >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ; -: nano-count>timestamp ( x -- timestamp ) - nano-count - nanoseconds now time+ ; - -: (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 ; +: nano-count>micros ( x -- n ) + nano-count - 1,000 /f system-micros + ; : 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> diff --git a/basis/core-foundation/time/time.factor b/basis/core-foundation/time/time.factor index 8f09652462..59dd8098b4 100644 --- a/basis/core-foundation/time/time.factor +++ b/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 ) - T{ timestamp { year 2001 } { month 1 } { day 1 } } time- - duration>seconds ; inline +MEMO: epoch ( -- micros ) + T{ timestamp { year 2001 } { month 1 } { day 1 } } timestamp>micros ; + +: >CFAbsoluteTime ( micros -- time ) + epoch - 1,000,000 /f ; inline diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor index cf17cb41d9..343753385a 100644 --- a/basis/core-foundation/timers/timers.factor +++ b/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 ( ) ; : ( 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 diff --git a/basis/csv/csv-docs.factor b/basis/csv/csv-docs.factor index 1f05ab639b..32c4cd53fb 100644 --- a/basis/csv/csv-docs.factor +++ b/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:" diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor index 23416d6912..1aeb2e1d19 100644 --- a/basis/csv/csv.factor +++ b/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 ) + csv ; + : file>csv ( path encoding -- csv ) csv ; @@ -96,8 +100,18 @@ PRIVATE> : write-row ( row -- ) [ delimiter get write1 ] [ escape-if-required write ] interleave nl ; inline - -: write-csv ( rows stream -- ) - [ [ write-row ] each ] with-output-stream ; + + +: write-csv ( rows stream -- ) + [ (write-csv) ] with-output-stream ; + +: csv>string ( csv -- string ) + [ (write-csv) ] with-string-writer ; + : csv>file ( rows path encoding -- ) write-csv ; diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor index 662a2840a1..dc3024b55f 100644 --- a/basis/delegate/delegate.factor +++ b/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 - [ [ reader-word ] [ writer-word ] bi 2array ] map concat - define-protocol ; \ No newline at end of file + CREATE-WORD ";" + [ [ reader-word ] [ writer-word ] bi 2array ] + map-tokens concat define-protocol ; diff --git a/basis/game/input/dinput/dinput.factor b/basis/game/input/dinput/dinput.factor index a95dbd06c3..f5b3520b12 100755 --- a/basis/game/input/dinput/dinput.factor +++ b/basis/game/input/dinput/dinput.factor @@ -30,15 +30,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ +dinput+ [ com-release f ] change-global ; : device-for-guid ( guid -- device ) - +dinput+ get swap f + +dinput+ get-global swap f [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ; : set-coop-level ( device -- ) - +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor - IDirectInputDevice8W::SetCooperativeLevel ole32-error ; + +device-change-window+ get-global DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor + IDirectInputDevice8W::SetCooperativeLevel ole32-error ; inline : set-data-format ( device format-symbol -- ) - get IDirectInputDevice8W::SetDataFormat ole32-error ; + get-global IDirectInputDevice8W::SetDataFormat ole32-error ; inline : ( size -- DIPROPDWORD ) DIPROPDWORD [ @@ -92,24 +92,25 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ +dinput+ get swap device-guid IDirectInput8W::GetDeviceStatus S_OK = ; +: (find-device-axes-callback) ( lpddoi pvRef -- BOOL ) + +controller-devices+ get-global at + swap guidType>> { + { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] } + { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] } + { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] } + { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] } + { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] } + { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] } + { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] } + [ drop ] + } cond drop + DIENUM_CONTINUE ; + : find-device-axes-callback ( -- alien ) - [ ! ( lpddoi pvRef -- BOOL ) - +controller-devices+ get at - swap guidType>> { - { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] } - { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] } - { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] } - { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] } - { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] } - { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] } - { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] } - [ drop ] - } cond drop - DIENUM_CONTINUE - ] LPDIENUMDEVICEOBJECTSCALLBACKW ; + [ (find-device-axes-callback) ] LPDIENUMDEVICEOBJECTSCALLBACKW ; : find-device-axes ( device controller-state -- controller-state ) - swap [ +controller-devices+ get set-at ] 2keep + swap [ +controller-devices+ get-global set-at ] 2keep find-device-axes-callback over DIDFT_AXIS IDirectInputDevice8W::EnumObjects ole32-error ; @@ -121,32 +122,33 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ find-device-axes ; : device-known? ( guid -- ? ) - +controller-guids+ get key? ; inline + +controller-guids+ get-global key? ; inline : (add-controller) ( guid -- ) device-for-guid { [ configure-controller ] [ controller-state-template ] - [ dup device-guid clone +controller-guids+ get set-at ] - [ +controller-devices+ get set-at ] + [ dup device-guid clone +controller-guids+ get-global set-at ] + [ +controller-devices+ get-global set-at ] } cleave ; : add-controller ( guid -- ) dup device-known? [ drop ] [ (add-controller) ] if ; : remove-controller ( device -- ) - [ +controller-devices+ get delete-at ] - [ device-guid +controller-guids+ get delete-at ] + [ +controller-devices+ get-global delete-at ] + [ device-guid +controller-guids+ get-global delete-at ] [ com-release ] tri ; +: (find-controller-callback) ( lpddi pvRef -- BOOL ) + drop guidInstance>> add-controller + DIENUM_CONTINUE ; + : find-controller-callback ( -- alien ) - [ ! ( lpddi pvRef -- BOOL ) - drop guidInstance>> add-controller - DIENUM_CONTINUE - ] LPDIENUMDEVICESCALLBACKW ; inline + [ (find-controller-callback) ] LPDIENUMDEVICESCALLBACKW ; : find-controllers ( -- ) - +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback + +dinput+ get-global DI8DEVCLASS_GAMECTRL find-controller-callback f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ; : set-up-controllers ( -- ) @@ -155,7 +157,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ find-controllers ; : find-and-remove-detached-devices ( -- ) - +controller-devices+ get keys + +controller-devices+ get-global keys [ device-attached? not ] filter [ remove-controller ] each ; @@ -251,7 +253,7 @@ M: dinput-game-input-backend (reset-game-input) ] bind ; M: dinput-game-input-backend get-controllers - +controller-devices+ get + +controller-devices+ get-global [ drop controller boa ] { } assoc>map ; M: dinput-game-input-backend product-string @@ -313,7 +315,7 @@ CONSTANT: pov-values } case ; : fill-mouse-state ( buffer count -- state ) - iota [ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ; + iota [ +mouse-state+ get-global ] 2dip swap [ nth (fill-mouse-state) ] curry each ; : get-device-state ( device DIJOYSTATE2 -- ) [ dup IDirectInputDevice8W::Poll ole32-error ] dip @@ -325,25 +327,25 @@ CONSTANT: pov-values [ fill-controller-state ] [ drop f ] with-acquisition ; M: dinput-game-input-backend read-controller - handle>> dup +controller-devices+ get at + handle>> dup +controller-devices+ get-global at [ (read-controller) ] [ drop f ] if* ; M: dinput-game-input-backend calibrate-controller handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ; M: dinput-game-input-backend read-keyboard - +keyboard-device+ get - [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ] + +keyboard-device+ get-global + [ +keyboard-state+ get-global [ keys>> underlying>> get-device-state ] keep ] [ ] [ f ] with-acquisition ; M: dinput-game-input-backend read-mouse - +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ] + +mouse-device+ get-global [ +mouse-buffer+ get-global MOUSE-BUFFER-SIZE read-device-buffer ] [ fill-mouse-state ] [ f ] with-acquisition ; M: dinput-game-input-backend reset-mouse - +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ] + +mouse-device+ get-global [ f MOUSE-BUFFER-SIZE read-device-buffer ] [ 2drop ] [ ] with-acquisition - +mouse-state+ get + +mouse-state+ get-global 0 >>dx 0 >>dy 0 >>scroll-dx diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index f27e1f36d1..9b514e77e0 100644 --- a/basis/game/input/input.factor +++ b/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 diff --git a/basis/game/input/iokit/iokit.factor b/basis/game/input/iokit/iokit.factor index efc586e1ef..083be8e74f 100644 --- a/basis/game/input/iokit/iokit.factor +++ b/basis/game/input/iokit/iokit.factor @@ -203,10 +203,10 @@ HINTS: record-keyboard { bit-array alien } ; HINTS: record-mouse { mouse-state alien } ; M: iokit-game-input-backend read-mouse - +mouse-state+ get ; + +mouse-state+ get-global ; M: iokit-game-input-backend reset-mouse - +mouse-state+ get + +mouse-state+ get-global 0 >>dx 0 >>dy 0 >>scroll-dx @@ -247,37 +247,40 @@ M: iokit-game-input-backend reset-mouse } cleave controller-state boa ; : ?add-mouse-buttons ( device -- ) - button-count +mouse-state+ get buttons>> + button-count +mouse-state+ get-global buttons>> 2dup length > [ set-length ] [ 2drop ] if ; +:: (device-matched-callback) ( context result sender device -- ) + { + { [ device mouse-device? ] [ device ?add-mouse-buttons ] } + { [ device controller-device? ] [ + device + device +controller-states+ get-global set-at + ] } + [ ] + } cond ; + : device-matched-callback ( -- alien ) - [| context result sender device | - { - { [ device controller-device? ] [ - device - device +controller-states+ get set-at - ] } - { [ device mouse-device? ] [ device ?add-mouse-buttons ] } - [ ] - } cond - ] IOHIDDeviceCallback ; + [ (device-matched-callback) ] IOHIDDeviceCallback ; + +:: (device-removed-callback) ( context result sender device -- ) + device +controller-states+ get-global delete-at ; : device-removed-callback ( -- alien ) - [| context result sender device | - device +controller-states+ get delete-at - ] IOHIDDeviceCallback ; + [ (device-removed-callback) ] IOHIDDeviceCallback ; + +:: (device-input-callback) ( context result sender value -- ) + { + { [ sender mouse-device? ] [ +mouse-state+ get-global value record-mouse ] } + { [ sender controller-device? ] [ + sender +controller-states+ get-global at value record-controller + ] } + [ +keyboard-state+ get-global value record-keyboard ] + } cond ; : device-input-callback ( -- alien ) - [| context result sender value | - { - { [ sender controller-device? ] [ - sender +controller-states+ get at value record-controller - ] } - { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] } - [ +keyboard-state+ get value record-keyboard ] - } cond - ] IOHIDValueCallback ; + [ (device-input-callback) ] IOHIDValueCallback ; : initialize-variables ( manager -- ) +hid-manager+ set-global @@ -321,7 +324,7 @@ M: iokit-game-input-backend (close-game-input) ] when ; M: iokit-game-input-backend get-controllers ( -- sequence ) - +controller-states+ get keys [ controller boa ] map ; + +controller-states+ get-global keys [ controller boa ] map ; : ?join ( pre post sep -- string ) 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ; @@ -338,10 +341,10 @@ M: iokit-game-input-backend instance-id ( controller -- integer ) handle>> kIOHIDLocationIDKey device-property ; M: iokit-game-input-backend read-controller ( controller -- controller-state ) - handle>> +controller-states+ get at clone ; + handle>> +controller-states+ get-global at clone ; M: iokit-game-input-backend read-keyboard ( -- keyboard-state ) - +keyboard-state+ get clone keyboard-state boa ; + +keyboard-state+ get-global clone keyboard-state boa ; M: iokit-game-input-backend calibrate-controller ( controller -- ) drop ; diff --git a/basis/game/input/linux/authors.txt b/basis/game/input/linux/authors.txt deleted file mode 100644 index 67cf648cf5..0000000000 --- a/basis/game/input/linux/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Erik Charlebois \ No newline at end of file diff --git a/basis/game/input/linux/linux.factor b/basis/game/input/linux/linux.factor deleted file mode 100644 index 0d451e96f0..0000000000 --- a/basis/game/input/linux/linux.factor +++ /dev/null @@ -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 keyboard-state boa ; - -M: linux-game-input-backend read-mouse - 0 0 0 0 2 mouse-state boa ; - -M: linux-game-input-backend reset-mouse - ; diff --git a/basis/game/input/x11/authors.txt b/basis/game/input/x11/authors.txt new file mode 100644 index 0000000000..d73be90188 --- /dev/null +++ b/basis/game/input/x11/authors.txt @@ -0,0 +1,2 @@ +Erik Charlebois +William Schlieper diff --git a/basis/game/input/linux/platforms.txt b/basis/game/input/x11/platforms.txt similarity index 100% rename from basis/game/input/linux/platforms.txt rename to basis/game/input/x11/platforms.txt diff --git a/basis/game/input/linux/summary.txt b/basis/game/input/x11/summary.txt similarity index 100% rename from basis/game/input/linux/summary.txt rename to basis/game/input/x11/summary.txt diff --git a/basis/game/input/linux/tags.txt b/basis/game/input/x11/tags.txt similarity index 100% rename from basis/game/input/linux/tags.txt rename to basis/game/input/x11/tags.txt diff --git a/basis/game/input/x11/x11.factor b/basis/game/input/x11/x11.factor new file mode 100644 index 0000000000..4e6f610531 --- /dev/null +++ b/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 swap [ t swap pick set-nth ] each ; + +M: x11-game-input-backend read-keyboard + dpy get 256 [ XQueryKeymap drop ] keep + x-bits>hid-bits keyboard-state boa ; + +M: x11-game-input-backend read-mouse + 0 0 0 0 2 mouse-state boa ; + +M: x11-game-input-backend reset-mouse + ; diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor index 0dced6ad9d..304fd50fcc 100644 --- a/basis/grouping/grouping.factor +++ b/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 > ] [ from>> ] bi - ; inline +M: circular-slice virtual-exemplar seq>> ; inline M: circular-slice virtual@ [ from>> + ] [ seq>> ] bi [ length slice-mod ] keep ; inline diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor index c0184ee0ef..e742b4768a 100644 --- a/basis/locals/parser/parser.factor +++ b/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 ) [ [ 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) ?rewrite-closures ; : parse-multi-def ( locals -- multi-def ) - ")" parse-tokens swap [ [ make-local ] map ] bind ; + [ ")" [ make-local ] map-tokens ] bind ; : parse-def ( name/paren locals -- def ) over "(" = [ nip parse-multi-def ] [ [ make-local ] bind ] if ; diff --git a/basis/match/match.factor b/basis/match/match.factor index b6369249b3..9baadfe1f2 100644 --- a/basis/match/match.factor +++ b/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 ; diff --git a/basis/opengl/gl/extensions/extensions.factor b/basis/opengl/gl/extensions/extensions.factor index 17813b8c82..530f3ada6c 100644 --- a/basis/opengl/gl/extensions/extensions.factor +++ b/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 +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-number-counter+ get-global - dup 1 + +gl-function-number-counter+ set-global ; +: gl-function-counter ( -- n ) + +gl-function-counter+ get-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 - parameters return parse-arglist [ abi indirect-quot ] dip + function-ptr-quot return types abi indirect-quot + names return function-effect define-declared ; SYNTAX: GL-FUNCTION: gl-function-calling-convention - scan-c-type - scan dup - scan drop "}" parse-tokens swap prefix - gl-function-number - [ gl-function-pointer ] 2curry swap - ";" parse-tokens [ "()" subseq? not ] filter - define-indirect ; + scan-function-name + "{" expect "}" parse-tokens over prefix + gl-function-counter '[ _ _ gl-function-pointer ] + ";" scan-c-args define-indirect ; diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index b052becfed..11b050d5fc 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/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 ; diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor index 0c0569ea9d..3352c226d8 100644 --- a/basis/specialized-vectors/specialized-vectors.factor +++ b/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 diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 05466f4673..bcdccb23cd 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/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 diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index 5230d9497e..49c9272d9b 100644 --- a/basis/windows/com/syntax/syntax.factor +++ b/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 ; -FROM: alien.parser.private => return-type-name ; +classes.struct windows.kernel32 locals ; +FROM: alien.parser.private => parse-pointers return-type-name ; IN: windows.com.syntax com-interface-definition -TUPLE: com-function-definition name return parameters ; +TUPLE: com-function-definition return name parameter-types parameter-names ; C: 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 ) - [ second ] - [ first parse-c-type ] - [ - 3 tail [ CHAR: , swap remove ] map - 2 group [ first2 normalize-c-arg 2array ] map - { void* "this" } prefix - ] tri +: (parse-com-function) ( return name -- definition ) + ")" scan-c-args + [ pointer: void prefix ] [ "this" prefix ] bi* ; +:: (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 - [ (parse-com-function) ] map ; + V{ } clone [ (parse-com-functions) ] keep >array ; : (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 ) - [ first ] map [ com-invoke ] 3curry ; - -: (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect ) - swap - [ [ second ] map ] - [ dup void? [ drop { } ] [ return-type-name 1array ] if ] bi* - ; - -: (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-word-for-function) ( function interface n -- ) + function interface (function-word) + n function [ return>> ] [ parameter-types>> ] bi '[ _ _ _ com-invoke ] + function [ parameter-names>> ] [ return>> ] bi function-effect define-declared ; : define-words-for-com-interface ( definition -- ) diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 623a9c8db3..25861659dc 100644 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -110,11 +110,7 @@ unless keep (next-vtbl-counter) '[ swap [ [ name>> _ _ (callback-word) ] - [ return>> ] [ - parameters>> - [ [ first ] map ] - [ length ] bi - ] tri + [ return>> ] [ parameter-types>> dup length ] tri ] [ first2 (finish-thunk) ] bi* diff --git a/basis/windows/directx/d3d9/d3d9.factor b/basis/windows/directx/d3d9/d3d9.factor index d4e06ae8c9..a612f72ccd 100644 --- a/basis/windows/directx/d3d9/d3d9.factor +++ b/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 ) diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index b9d5cc95c4..1c23c36071 100644 --- a/basis/windows/user32/user32.factor +++ b/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 -CONSTANT: SWP_NOREPOSITION SWP_NOOWNERZORDER +ALIAS: SWP_DRAWFRAME SWP_FRAMECHANGED +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 ; : HWND_NOTOPMOST ( -- alien ) -2 ; diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index e86bb5e8c3..1c5ff2e3ef 100644 --- a/basis/x11/xlib/xlib.factor +++ b/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 ) ; + diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor index 0ad4f6c85a..435ceb2a96 100644 --- a/core/alien/strings/strings.factor +++ b/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 - 9 special-object utf8 alien>string string>os \ os set-global + 8 special-object utf8 alien>string string>cpu \ cpu 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 diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 7482cce048..5016bb38f6 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -68,23 +68,28 @@ ERROR: invalid-slot-name name ; ERROR: bad-literal-tuple ; -: parse-slot-value ( -- ) - scan scan-object 2array , scan { +ERROR: bad-slot-name class slot ; + +: 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-value +: (parse-slot-values) ( class slots -- ) + 2dup parse-slot-value scan { - { f [ \ } unexpected-eof ] } + { f [ 2drop \ } unexpected-eof ] } { "{" [ (parse-slot-values) ] } - { "}" [ ] } - [ bad-literal-tuple ] + { "}" [ 2drop ] } + [ 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 ; diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor index 30888b76d8..04985a4340 100644 --- a/core/lexer/lexer-docs.factor +++ b/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." } -{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." } +{ $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." } $parsing-note ; HELP: unexpected diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index b3bd3cacdb..e03cae74db 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -5,7 +5,9 @@ io vectors arrays math.parser combinators continuations source-files.errors ; IN: lexer -TUPLE: lexer text line line-text line-length column ; +TUPLE: lexer text line line-text line-length column parsing-words ; + +TUPLE: lexer-parsing-word word line line-text column ; : next-line ( lexer -- ) dup [ line>> ] [ text>> ] bi ?nth >>line-text @@ -14,10 +16,23 @@ TUPLE: lexer text line line-text line-length column ; 0 >>column drop ; +: push-parsing-word ( word -- ) + lexer-parsing-word new + swap >>word + lexer get [ + [ line>> >>line ] + [ line-text>> >>line-text ] + [ column>> >>column ] tri + ] [ parsing-words>> push ] bi ; + +: pop-parsing-word ( -- ) + lexer get parsing-words>> pop drop ; + : new-lexer ( text class -- lexer ) new 0 >>line swap >>text + V{ } clone >>parsing-words dup next-line ; inline : ( text -- lexer ) @@ -82,37 +97,58 @@ PREDICATE: unexpected-eof < unexpected [ unexpected-eof ] if* ; -: (parse-tokens) ( accum end -- accum ) - scan 2dup = [ - 2drop - ] [ - [ pick push (parse-tokens) ] [ unexpected-eof ] if* - ] if ; +: (each-token) ( end quot -- pred quot ) + [ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline + +: each-token ( end quot -- ) + (each-token) while drop ; inline + +: map-tokens ( end quot -- seq ) + (each-token) produce nip ; inline : parse-tokens ( end -- seq ) - 100 swap (parse-tokens) >array ; + [ ] map-tokens ; -TUPLE: lexer-error line column line-text error ; +TUPLE: lexer-error line column line-text parsing-words error ; M: lexer-error error-file error>> error-file ; M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ; : ( msg -- error ) \ lexer-error new - lexer get - [ line>> >>line ] - [ column>> >>column ] - [ line-text>> >>line-text ] - tri + lexer get [ + [ line>> >>line ] + [ column>> >>column ] bi + ] [ + [ line-text>> >>line-text ] + [ parsing-words>> clone >>parsing-words ] bi + ] bi swap >>error ; -: lexer-dump ( error -- ) +: simple-lexer-dump ( error -- ) [ line>> number>string ": " append ] [ line-text>> dup string? [ drop "" ] unless ] [ column>> 0 or ] tri pick length + CHAR: \s [ write ] [ print ] [ write "^" print ] tri* ; +: (parsing-word-lexer-dump) ( error parsing-word -- ) + [ + line>> number>string + over line>> number>string length + CHAR: \s pad-head + ": " append write + ] [ line-text>> dup string? [ drop "" ] unless print ] bi + simple-lexer-dump ; + +: parsing-word-lexer-dump ( error parsing-word -- ) + 2dup [ line>> ] bi@ = + [ drop simple-lexer-dump ] + [ (parsing-word-lexer-dump) ] if ; + +: lexer-dump ( error -- ) + dup parsing-words>> [ simple-lexer-dump ] [ last parsing-word-lexer-dump ] if-empty ; + : with-lexer ( lexer quot -- newquot ) [ lexer set ] dip [ rethrow ] recover ; inline diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index b024d1d968..c04a0f568e 100644 --- a/core/parser/parser-docs.factor +++ b/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:" -{ $subsections parse-tokens } ; +"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 + 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 } } } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index e3e7d79c40..3257bd69a4 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -58,9 +58,14 @@ SYMBOL: auto-use? ERROR: staging-violation word ; +: (execute-parsing) ( accum word -- accum ) + dup push-parsing-word + execute( accum -- accum ) + pop-parsing-word ; inline + : execute-parsing ( accum word -- accum ) dup changed-definitions get key? [ staging-violation ] when - execute( accum -- accum ) ; + (execute-parsing) ; : scan-object ( -- object ) scan-word { diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 0b5b32e289..6c35a3c5c6 100644 --- a/core/syntax/syntax.factor +++ b/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 @@ -124,13 +124,11 @@ IN: bootstrap.syntax ] define-core-syntax "SYMBOLS:" [ - ";" parse-tokens - [ create-in dup reset-generic define-symbol ] each + ";" [ create-in dup reset-generic define-symbol ] each-token ] define-core-syntax "SINGLETONS:" [ - ";" parse-tokens - [ create-class-in define-singleton-class ] each + ";" [ create-class-in define-singleton-class ] each-token ] define-core-syntax "DEFER:" [ diff --git a/core/system/system.factor b/core/system/system.factor index 715564c64d..765861c62f 100644 --- a/core/system/system.factor +++ b/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 + cpu ( str -- class ) diff --git a/extra/calendar/holidays/us/us.factor b/extra/calendar/holidays/us/us.factor index a4fb19c597..538836952f 100644 --- a/extra/calendar/holidays/us/us.factor +++ b/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 ; diff --git a/extra/fullscreen/authors.txt b/extra/fullscreen/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/fullscreen/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/fullscreen/fullscreen.factor b/extra/fullscreen/fullscreen.factor new file mode 100755 index 0000000000..a233d6f4f5 --- /dev/null +++ b/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 + 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 + 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 [ 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) ; diff --git a/extra/fullscreen/platforms.txt b/extra/fullscreen/platforms.txt new file mode 100644 index 0000000000..8e1a55995e --- /dev/null +++ b/extra/fullscreen/platforms.txt @@ -0,0 +1 @@ +windows diff --git a/extra/game/loop/loop.factor b/extra/game/loop/loop.factor index 9e46535b4e..00fe14c3cd 100644 --- a/extra/game/loop/loop.factor +++ b/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 -- ) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index b33b8e5710..75af1b604a 100644 --- a/extra/poker/poker.factor +++ b/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! ; diff --git a/extra/slots/syntax/authors.txt b/extra/slots/syntax/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/slots/syntax/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/slots/syntax/syntax-docs.factor b/extra/slots/syntax/syntax-docs.factor new file mode 100755 index 0000000000..84e6e89dac --- /dev/null +++ b/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" diff --git a/extra/slots/syntax/syntax-tests.factor b/extra/slots/syntax/syntax-tests.factor new file mode 100755 index 0000000000..e4dac6e4a4 --- /dev/null +++ b/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 diff --git a/extra/slots/syntax/syntax.factor b/extra/slots/syntax/syntax.factor new file mode 100755 index 0000000000..7bfe238fa8 --- /dev/null +++ b/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! ; diff --git a/extra/vars/vars.factor b/extra/vars/vars.factor index 21c9b303f3..990b0307d0 100644 --- a/extra/vars/vars.factor +++ b/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 ; diff --git a/extra/webapps/help/search.xml b/extra/webapps/help/search.xml index bcaed59ea4..f6b364f089 100644 --- a/extra/webapps/help/search.xml +++ b/extra/webapps/help/search.xml @@ -23,7 +23,7 @@

This is the Factor documentation, generated offline from a - load-everything image. If you want, you can also browse the + load-all image. If you want, you can also browse the documentation from within the Factor UI.

You may search article titles below; for example, try searching for "HTTP".

diff --git a/vm/factor.cpp b/vm/factor.cpp index fb14336ae4..4433095173 100755 --- a/vm/factor.cpp +++ b/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; diff --git a/vm/master.hpp b/vm/master.hpp index 70736c1bd9..dca3d7473c 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -29,6 +29,21 @@ #include #include +#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 diff --git a/vm/objects.hpp b/vm/objects.hpp index fdc5758a8d..2d777ac516 100644 --- a/vm/objects.hpp +++ b/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