[ ]
} 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>> {
{ $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" } }
CONSTANT: url URL" http://factorcode.org/images/latest/"
: download-checksums ( -- alist )
- url "checksums.txt" >url derive-url http-data
+ url "checksums.txt" >url derive-url http-get nip
string-lines [ " " split1 ] { } map>assoc ;
: need-new-image? ( image -- ? )
: 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 -- ? )
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: math math.order math.parser math.functions kernel\r
-sequences io accessors arrays io.streams.string splitting\r
-combinators calendar calendar.format.macros present ;\r
+USING: accessors arrays calendar calendar.format.macros\r
+combinators io io.streams.string kernel math math.functions\r
+math.order math.parser present sequences typed ;\r
IN: calendar.format\r
\r
: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;\r
: (timestamp>ymd) ( timestamp -- )\r
{ YYYY "-" MM "-" DD } formatted ;\r
\r
-: timestamp>ymd ( timestamp -- str )\r
+TYPED: timestamp>ymd ( timestamp: timestamp -- str )\r
[ (timestamp>ymd) ] with-string-writer ;\r
\r
: (timestamp>hms) ( timestamp -- )\r
{ hh ":" mm ":" ss } formatted ;\r
\r
-: timestamp>hms ( timestamp -- str )\r
+TYPED: timestamp>hms ( timestamp: timestamp -- str )\r
[ (timestamp>hms) ] with-string-writer ;\r
\r
-: timestamp>ymdhms ( timestamp -- str )\r
+TYPED: timestamp>ymdhms ( timestamp: timestamp -- str )\r
[\r
>gmt\r
{ (timestamp>ymd) " " (timestamp>hms) } formatted\r
<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+ ;
+: nano-count>micros ( x -- n )
+ nano-count - 1,000 /f system-micros + ;
-: (reset-timer) ( timer counter -- )
+: reset-timer ( timer -- )
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)) ]
+ { [ 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 ;
-: reset-timer ( timer -- )
- 10 (reset-timer) ;
-
PRIVATE>
: reset-run-loop ( -- )
-! 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
: >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
-! 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 ;
) ;
: <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
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 ;
+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> [
+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 ;
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 ( -- )
find-controllers ;
: find-and-remove-detached-devices ( -- )
- +controller-devices+ get keys
+ +controller-devices+ get-global keys
[ device-attached? not ] filter
[ remove-controller ] each ;
] 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
} 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
[ 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
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
} 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
] 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 ;
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 ;
{ $description "Downloads the contents of a URL." }
{ $errors "Throws an error if the HTTP request fails." } ;
-HELP: http-data
-{ $values { "url" "a " { $link url } " or " { $link string } } { "data" sequence } }
-{ $description "Downloads the contents of a URL. To view the HTTP response, use " { $link http-get } "." }
-{ $errors "Throws an error if the HTTP request fails." } ;
-
HELP: http-post
{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } }
{ $description "Submits an HTTP POST request." }
ARTICLE: "http.client.get" "GET requests with the HTTP client"
"Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"
-{ $subsections http-get http-data }
+{ $subsections http-get }
"Utilities to retrieve a " { $link url } " and save the contents to a file:"
{ $subsections
download
: http-get ( url -- response data )
<get-request> http-request ;
-: http-data ( url -- data )
- http-get nip ;
-
: with-http-get ( url quot -- response )
[ <get-request> ] dip with-http-request ; inline
[ t ] [
"vocab:http/test/foo.html" ascii file-contents
- "http://localhost/nested/foo.html" add-port http-data =
+ "http://localhost/nested/foo.html" add-port http-get nip =
] unit-test
-[ "http://localhost/redirect-loop" add-port http-data ]
+[ "http://localhost/redirect-loop" add-port http-get nip ]
[ too-many-redirects? ] must-fail-with
[ "Goodbye" ] [
- "http://localhost/quit" add-port http-data
+ "http://localhost/quit" add-port http-get nip
] unit-test
! HTTP client redirect bug
] unit-test
[ "Goodbye" ] [
- "http://localhost/redirect" add-port http-data
+ "http://localhost/redirect" add-port http-get nip
] unit-test
: 404? ( response -- ? ) [ download-failed? ] [ response>> code>> 404 = ] bi and ;
! This should give a 404 not an infinite redirect loop
-[ "http://localhost/d/blah" add-port http-data ] [ 404? ] must-fail-with
+[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with
! This should give a 404 not an infinite redirect loop
-[ "http://localhost/blah/" add-port http-data ] [ 404? ] must-fail-with
+[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with
-[ "Goodbye" ] [ "http://localhost/quit" add-port http-data ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
[ ] [
<dispatcher>
test-httpd
] unit-test
-[ "Hi" ] [ "http://localhost/" add-port http-data ] unit-test
+[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test
-[ "Goodbye" ] [ "http://localhost/quit" add-port http-data ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
USING: html.components html.forms
xml xml.traversal validators
[ 4 ] [ a get-global ] unit-test
-[ "Goodbye" ] [ "http://localhost/quit" add-port http-data ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
! Test cloning
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
] unit-test
[ t ] [
- "http://localhost/" add-port http-data
+ "http://localhost/" add-port http-get nip
"vocab:http/test/foo.html" ascii file-contents =
] unit-test
: 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 ;
[ \ ] 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 ;
[ 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 ;
[ 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 ;
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
: 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 ;
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 ;
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
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
- http-data parse-feed ;
+ http-get nip parse-feed ;
! Atom generation
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
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+
: 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 ;
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 -- )
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*
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 )
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
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 )
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 ;
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 ;
{ $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
[ 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 parsing-words error ;
$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."
{ $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 } } }
"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
] 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:" [
: os ( -- class ) \ os get-global ; foldable
+: vm-compiler ( -- string ) \ vm-compiler get-global ; foldable
+
<PRIVATE
: string>cpu ( str -- class )
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 ;
: (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 -- )
IN: images.http
: load-http-image ( path -- image )
- [ http-data ] [ image-class ] bi load-image* ;
+ [ http-get nip ] [ image-class ] bi load-image* ;
: http-image. ( path -- )
load-http-image image. ;
string>value value>hand-name ;
SYNTAX: HAND{
- "}" parse-tokens [ card> ] { } map-as suffix! ;
+ "}" [ card> ] map-tokens suffix! ;
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 ;"
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{ } ;
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
\ No newline at end of file
+[ { } ] [ T{ slot-test f 1 2 3 } slots{ } ] unit-test
sequences slots ;
IN: slots.syntax
+SYNTAX: slots[
+ "]" [ reader-word 1quotation ] map-tokens
+ '[ _ cleave ] append! ;
+
SYNTAX: slots{
- "}" parse-tokens
- [ reader-word 1quotation ] map
- '[ [ _ cleave ] output>array ] append! ;
\ No newline at end of file
+ "}" [ reader-word 1quotation ] map-tokens
+ '[ [ _ cleave ] output>array ] append! ;
[ define-var ] each ;
SYNTAX: VARS: ! vars ...
- ";" parse-tokens define-vars ;
+ ";" [ define-var ] each-token ;
: do-compile-url ( url -- response )
[
- absolute-url http-data 'expression' parse fjsc-compile write "();" write
+ absolute-url http-get nip 'expression' parse fjsc-compile write "();" write
] with-string-writer
"application/javascript" <content> ;
swap >>query ;
: search-yahoo ( search -- seq )
- query http-data string>xml parse-yahoo ;
+ query http-get nip string>xml parse-yahoo ;
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;
#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
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
projects / factor.git / commitdiff