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

Merge branch 'master' of git://github.com/slavapestov/factor

db4
Erik Charlebois 2010-03-03 00:04:17 -08:00
parent a0ac5a16c3 afaaf30679
commit 7d9c73c406
55 changed files with 654 additions and 304 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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 )
[
2 group [ first2 normalize-c-arg 2array ] map
unzip [ "," ?tail drop ] map
]
[ [ { } ] [ return-type-name 1array ] if-void ]
bi* <effect> ;
: 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 <effect> ;
: 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>> {

5
basis/alien/syntax/syntax-docs.factor
View File

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

12
basis/calendar/calendar.factor
View File

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

12
basis/calendar/format/format.factor
View File

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

22
basis/core-foundation/run-loop/run-loop.factor
View File

@ -99,22 +99,18 @@ TUPLE: run-loop fds sources timers ;
<PRIVATE
: ((reset-timer)) ( timer counter timestamp -- )
nip >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>

12
basis/core-foundation/time/time.factor
View File

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

4
basis/core-foundation/timers/timers.factor
View File

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

20
basis/csv/csv-docs.factor
View File

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

22
basis/csv/csv.factor
View File

@ -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 ;
@ -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 ;
<PRIVATE
: (write-csv) ( rows -- )
[ write-row ] each ;
PRIVATE>
: write-csv ( rows stream -- )
[ (write-csv) ] with-output-stream ;
: csv>string ( csv -- string )
[ (write-csv) ] with-string-writer ;
: csv>file ( rows path encoding -- ) <file-writer> write-csv ;

6
basis/delegate/delegate.factor
View File

@ -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 ;
CREATE-WORD ";"
[ [ reader-word ] [ writer-word ] bi 2array ]
map-tokens concat define-protocol ;

78
basis/game/input/dinput/dinput.factor
View File

@ -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 <void*>
+dinput+ get-global swap f <void*>
[ 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
: <buffer-size-diprop> ( size -- DIPROPDWORD )
DIPROPDWORD <struct> [
@ -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

2
basis/game/input/input.factor
View File

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

59
basis/game/input/iokit/iokit.factor
View File

@ -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-state>
device +controller-states+ get-global set-at
] }
[ ]
} cond ;
: device-matched-callback ( -- alien )
[| context result sender device |
{
{ [ device controller-device? ] [
device <device-controller-state>
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 ;

1
basis/game/input/linux/authors.txt
View File

@ -1 +0,0 @@
Erik Charlebois

47
basis/game/input/linux/linux.factor
View File

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

2
basis/game/input/x11/authors.txt Normal file
View File

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

0
basis/game/input/linux/platforms.txt → basis/game/input/x11/platforms.txt
View File

0
basis/game/input/linux/summary.txt → basis/game/input/x11/summary.txt
View File

0
basis/game/input/linux/tags.txt → basis/game/input/x11/tags.txt
View File

92
basis/game/input/x11/x11.factor Normal file
View File

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

13
basis/grouping/grouping.factor
View File

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

7
basis/locals/parser/parser.factor
View File

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

2
basis/match/match.factor
View File

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

27
basis/opengl/gl/extensions/extensions.factor
View File

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

2
basis/specialized-arrays/specialized-arrays.factor
View File

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

4
basis/specialized-vectors/specialized-vectors.factor
View File

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

3
basis/ui/gadgets/worlds/worlds.factor
View File

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

45
basis/windows/com/syntax/syntax.factor
View File

@ -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
<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 )
[ 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*
<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
[ (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*
<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-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 -- )

6
basis/windows/com/wrapper/wrapper.factor
View File

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

2
basis/windows/directx/d3d9/d3d9.factor
View File

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

14
basis/windows/user32/user32.factor
View File

@ -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 <alien> ;
: HWND_NOTOPMOST ( -- alien ) -2 <alien> ;

5
basis/x11/xlib/xlib.factor
View File

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

5
core/alien/strings/strings.factor
View File

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

25
core/classes/tuple/parser/parser.factor
View File

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

14
core/lexer/lexer-docs.factor
View File

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

66
core/lexer/lexer.factor
View File

@ -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
: <lexer> ( 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 <vector> 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 ;
: <lexer-error> ( 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 <string>
[ 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 [ <lexer-error> rethrow ] recover ; inline

10
core/parser/parser-docs.factor
View File

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

7
core/parser/parser.factor
View File

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

8
core/syntax/syntax.factor
View File

@ -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:" [

2
core/system/system.factor
View File

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

2
extra/calendar/holidays/us/us.factor
View File

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

1
extra/fullscreen/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

142
extra/fullscreen/fullscreen.factor Executable file
View File

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

1
extra/fullscreen/platforms.txt Normal file
View File

@ -0,0 +1 @@
windows

2
extra/game/loop/loop.factor
View File

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

2
extra/poker/poker.factor
View File

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

1
extra/slots/syntax/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

32
extra/slots/syntax/syntax-docs.factor Executable file
View File

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

14
extra/slots/syntax/syntax-tests.factor Executable file
View File

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

13
extra/slots/syntax/syntax.factor Executable file
View File

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

2
extra/vars/vars.factor
View File

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

2
extra/webapps/help/search.xml
View File

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

1
vm/factor.cpp
View File

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

15
vm/master.hpp
View File

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

2
vm/objects.hpp
View File

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