!IF DEFINED(PLATFORM)
LINK_FLAGS = /nologo shell32.lib
-CL_FLAGS = /nologo /O2 /W3 /D_CRT_SECURE_NO_WARNINGS
+CL_FLAGS = /nologo /O2 /WX /W3 /D_CRT_SECURE_NO_WARNINGS
!IF DEFINED(DEBUG)
LINK_FLAGS = $(LINK_FLAGS) /DEBUG
+++ /dev/null
-USING: help.markup help.syntax calendar quotations system ;\r
-IN: alarms\r
-\r
-HELP: alarm\r
-{ $class-description "An alarm. Can be passed to " { $link stop-alarm } "." } ;\r
-\r
-HELP: start-alarm\r
-{ $values { "alarm" alarm } }\r
-{ $description "Starts an alarm." } ;\r
-\r
-HELP: restart-alarm\r
-{ $values { "alarm" alarm } }\r
-{ $description "Starts or restarts an alarm. Restarting an alarm causes the a sleep of initial delay nanoseconds before looping. An alarm's parameters may be modified and restarted with this word." } ;\r
-\r
-HELP: stop-alarm\r
-{ $values { "alarm" alarm } }\r
-{ $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ;\r
-\r
-HELP: every\r
-{ $values\r
- { "quot" quotation } { "interval-duration" duration }\r
- { "alarm" alarm } }\r
-{ $description "Creates an alarm that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the alarm will stop." }\r
-{ $examples\r
- { $unchecked-example\r
- "USING: alarms io calendar ;"\r
- """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
- ""\r
- }\r
-} ;\r
-\r
-HELP: later\r
-{ $values { "quot" quotation } { "delay-duration" duration } { "alarm" alarm } }\r
-{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the alarm before " { $snippet "quot" } " runs. This alarm is not repeated." }\r
-{ $examples\r
- { $unchecked-example\r
- "USING: alarms io calendar ;"\r
- """[ "Break's over!" print flush ] 15 minutes later drop"""\r
- ""\r
- }\r
-} ;\r
-\r
-HELP: delayed-every\r
-{ $values\r
- { "quot" quotation } { "duration" duration }\r
- { "alarm" alarm } }\r
-{ $description "Creates an alarm that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the alarm will stop." }\r
-{ $examples\r
- { $unchecked-example\r
- "USING: alarms io calendar ;"\r
- """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
- ""\r
- }\r
-} ;\r
-\r
-ARTICLE: "alarms" "Alarms"\r
-"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per alarm and consist of a quotation, a delay duration, and an interval duration. After starting an alarm, the alarm thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the alarm. If a recurring alarm's quotation would be scheduled to run again before the previous quotation has finished processing, the alarm will be run again immediately afterwards. This may result in the alarm falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring alarms that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the alarm from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl\r
-"The alarm class:"\r
-{ $subsections alarm }\r
-"Create an alarm before starting it:"\r
-{ $subsections <alarm> }\r
-"Starting an alarm:"\r
-{ $subsections start-alarm restart-alarm }\r
-"Stopping an alarm:"\r
-{ $subsections stop-alarm }\r
-\r
-"A recurring alarm without an initial delay:"\r
-{ $subsections every }\r
-"A one-time alarm with an initial delay:"\r
-{ $subsections later }\r
-"A recurring alarm with an initial delay:"\r
-{ $subsections delayed-every } ;\r
-\r
-ABOUT: "alarms"\r
+++ /dev/null
-USING: alarms alarms.private calendar concurrency.count-downs\r
-concurrency.promises fry kernel math math.order sequences\r
-threads tools.test tools.time ;\r
-IN: alarms.tests\r
-\r
-[ ] [\r
- 1 <count-down>\r
- { f } clone 2dup\r
- [ first stop-alarm count-down ] 2curry 1 seconds later\r
- swap set-first\r
- await\r
-] unit-test\r
-\r
-[ ] [\r
- self [ resume ] curry instant later drop\r
- "test" suspend drop\r
-] unit-test\r
-\r
-[ t ] [\r
- [\r
- <promise>\r
- [ '[ t _ fulfill ] 2 seconds later drop ]\r
- [ 5 seconds ?promise-timeout drop ] bi\r
- ] benchmark 1,500,000,000 2,500,000,000 between?\r
-] unit-test\r
-\r
-[ { 3 } ] [\r
- { 3 } dup\r
- '[ 4 _ set-first ] 2 seconds later\r
- 1/2 seconds sleep\r
- stop-alarm\r
-] unit-test\r
-\r
-[ { 1 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later\r
- [ stop-alarm ] [ start-alarm ] bi\r
- 4 seconds sleep\r
-] unit-test\r
-\r
-[ { 0 } ] [\r
- { 0 }\r
- dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later\r
- 2 seconds sleep stop-alarm\r
- 1/2 seconds sleep\r
-] unit-test\r
-\r
-[ { 0 } ] [\r
- { 0 }\r
- dup '[ 1 _ set-first ] 300 milliseconds later\r
- 150 milliseconds sleep\r
- [ restart-alarm ] [ 200 milliseconds sleep stop-alarm ] bi\r
-] unit-test\r
-\r
-[ { 1 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later\r
- 100 milliseconds sleep restart-alarm 300 milliseconds sleep\r
-] unit-test\r
-\r
-[ { 4 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds\r
- <alarm> dup start-alarm\r
- 700 milliseconds sleep dup restart-alarm\r
- 700 milliseconds sleep stop-alarm 500 milliseconds sleep\r
-] unit-test\r
-! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
+! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs calendar combinators.short-circuit fry
-heaps init kernel math math.functions math.parser namespaces
-quotations sequences system threads ;
+USING: ;
IN: alarms
-TUPLE: alarm
- { quot callable initial: [ ] }
- start-nanos
- delay-nanos
- interval-nanos
- iteration-start-nanos
- quotation-running?
- restart?
- thread ;
-
-<PRIVATE
-
-GENERIC: >nanoseconds ( obj -- duration/f )
-M: f >nanoseconds ;
-M: real >nanoseconds >integer ;
-M: duration >nanoseconds duration>nanoseconds >integer ;
-
-: set-next-alarm-time ( alarm -- alarm )
- ! start + delay + ceiling((now - (start + delay)) / interval) * interval
- nano-count
- over start-nanos>> -
- over delay-nanos>> [ - ] when*
- over interval-nanos>> / ceiling
- over interval-nanos>> *
- over start-nanos>> +
- over delay-nanos>> [ + ] when*
- >>iteration-start-nanos ;
-
-: stop-alarm? ( alarm -- ? )
- { [ thread>> self eq? not ] [ restart?>> ] } 1|| ;
-
-DEFER: call-alarm-loop
-
-: loop-alarm ( alarm -- )
- nano-count over
- [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
- [ set-next-alarm-time ] dip
- [ dup iteration-start-nanos>> ] [ 0 ] if
- 0 or sleep-until call-alarm-loop ;
-
-: maybe-loop-alarm ( alarm -- )
- dup { [ stop-alarm? ] [ interval-nanos>> not ] } 1||
- [ drop ] [ loop-alarm ] if ;
-
-: call-alarm-loop ( alarm -- )
- dup stop-alarm? [
- drop
- ] [
- [
- [ t >>quotation-running? drop ]
- [ quot>> call( -- ) ]
- [ f >>quotation-running? drop ] tri
- ] keep
- maybe-loop-alarm
- ] if ;
-
-: sleep-delay ( alarm -- )
- dup stop-alarm? [
- drop
- ] [
- nano-count >>start-nanos
- delay-nanos>> [ sleep ] when*
- ] if ;
-
-: alarm-loop ( alarm -- )
- [ sleep-delay ]
- [ nano-count >>iteration-start-nanos call-alarm-loop ]
- [ dup restart?>> [ f >>restart? alarm-loop ] [ drop ] if ] tri ;
-
-PRIVATE>
-
-: <alarm> ( quot delay-duration/f interval-duration/f -- alarm )
- alarm new
- swap >nanoseconds >>interval-nanos
- swap >nanoseconds >>delay-nanos
- swap >>quot ; inline
-
-: start-alarm ( alarm -- )
- [
- '[ _ alarm-loop ] "Alarm execution" spawn
- ] keep thread<< ;
-
-: stop-alarm ( alarm -- )
- dup quotation-running?>> [
- f >>thread drop
- ] [
- [ [ interrupt ] when* f ] change-thread drop
- ] if ;
-
-: restart-alarm ( alarm -- )
- t >>restart?
- dup quotation-running?>> [
- drop
- ] [
- dup thread>> [ nip interrupt ] [ start-alarm ] if*
- ] if ;
-
-<PRIVATE
-
-: (start-alarm) ( quot start-duration interval-duration -- alarm )
- <alarm> [ start-alarm ] keep ;
-
-PRIVATE>
-
-: every ( quot interval-duration -- alarm )
- [ f ] dip (start-alarm) ;
-
-: later ( quot delay-duration -- alarm )
- f (start-alarm) ;
-
-: delayed-every ( quot duration -- alarm )
- dup (start-alarm) ;
+++ /dev/null
-One-time and recurring events
M: string-type c-type-getter
drop [ alien-cell ] ;
+M: string-type c-type-copier
+ drop [ ] ;
+
M: string-type c-type-setter
drop [ set-alien-cell ] ;
M: c-type c-type-getter getter>> ;
+GENERIC: c-type-copier ( name -- quot )
+
+M: c-type c-type-copier drop [ ] ;
+
GENERIC: c-type-setter ( name -- quot )
M: c-type c-type-setter setter>> ;
MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
[ c-type-getter ] [ c-type-boxer-quot ] bi append ;
+MACRO: alien-copy-value ( c-type -- quot: ( c-ptr offset -- value ) )
+ [ c-type-getter ] [ c-type-copier ] [ c-type-boxer-quot ] tri 3append ;
+
MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
[ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
[ c-type-setter ]
c-type-unboxer-quot
c-type-rep
c-type-getter
+ c-type-copier
c-type-setter
c-type-align
c-type-align-first
USING: alien alien.c-types help.syntax help.markup libc
kernel.private byte-arrays math strings hashtables alien.syntax
alien.strings sequences io.encodings.string debugger destructors
-vocabs.loader classes.struct ;
+vocabs.loader classes.struct quotations ;
IN: alien.data
HELP: <c-array>
{ string>alien alien>string malloc-string } related-words
+HELP: with-scoped-allocation
+{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } }
+{ $description "Allocates values on the call stack, calls the quotation, then deallocates the values as soon as the quotation returns."
+$nl
+"A scoped allocation specifier is either:"
+{ $list
+ "a C type name,"
+ { "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." }
+}
+"If no initial value is specified, the contents of the allocated memory are undefined." }
+{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." }
+{ $examples
+ { $example
+ "USING: accessors alien.c-types alien.data
+classes.struct kernel math math.functions
+prettyprint ;
+IN: scratchpad
+
+STRUCT: point { x int } { y int } ;
+
+: scoped-allocation-test ( -- x )
+ { point } [
+ 3 >>x 4 >>y
+ [ x>> sq ] [ y>> sq ] bi + sqrt
+ ] with-scoped-allocation ;
+
+scoped-allocation-test ."
+"5.0"
+ }
+} ;
+
+HELP: with-out-parameters
+{ $values { "c-types" "a list of scoped allocation specifiers" } { "quot" quotation } { "values..." "zero or more values" } }
+{ $description "Allocates values on the call stack, calls the quotation, then copies all stack allocated values to the data heap after the quotation returns."
+$nl
+"A scoped allocation specifier is either:"
+{ $list
+ "a C type name,"
+ { "or a triple with shape " { $snippet "{ c-type initial: initial }" } ", where " { $snippet "c-type" } " is a C type name and " { $snippet "initial" } " is a literal value." }
+}
+"If no initial value is specified, the contents of the allocated memory are undefined." }
+{ $warning "Reading or writing a scoped allocation buffer outside of the given quotation will cause memory corruption." } ;
+
ARTICLE: "malloc" "Manual memory management"
"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
$nl
USING: accessors alien alien.c-types alien.arrays alien.strings
arrays byte-arrays cpu.architecture fry io io.encodings.binary
io.files io.streams.memory kernel libc math math.functions
-sequences words macros combinators generalizations ;
+sequences words macros combinators generalizations
+stack-checker.dependencies combinators.short-circuit ;
QUALIFIED: math
IN: alien.data
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
-M: value-type c-type-setter ( type -- quot )
+M: value-type c-type-copier
+ heap-size '[ _ memory>byte-array ] ;
+
+M: value-type c-type-setter
[ c-type-getter ] [ heap-size ] bi '[ @ swap _ memcpy ] ;
M: array c-type-boxer-quot
! to still be abl to access scope-allocated data.
;
+MACRO: (simple-local-allot) ( c-type -- quot )
+ [ depends-on-c-type ]
+ [ dup '[ _ heap-size _ c-type-align (local-allot) ] ] bi ;
+
+: [hairy-local-allot] ( c-type initial -- quot )
+ over '[ _ (simple-local-allot) _ over 0 _ set-alien-value ] ;
+
+: hairy-local-allot? ( obj -- ? )
+ {
+ [ array? ]
+ [ length 3 = ]
+ [ second initial: eq? ]
+ } 1&& ;
+
+MACRO: (hairy-local-allot) ( obj -- quot )
+ dup hairy-local-allot?
+ [ first3 nip [hairy-local-allot] ]
+ [ '[ _ (simple-local-allot) ] ]
+ if ;
+
MACRO: (local-allots) ( c-types -- quot )
- [ '[ _ [ heap-size ] [ c-type-align ] bi (local-allot) ] ] map [ ] join ;
+ [ '[ _ (hairy-local-allot) ] ] map [ ] join ;
MACRO: box-values ( c-types -- quot )
[ c-type-boxer-quot ] map '[ _ spread ] ;
MACRO: out-parameters ( c-types -- quot )
- [ length ] [ [ '[ 0 _ alien-value ] ] map ] bi
+ [ dup hairy-local-allot? [ first ] when ] map
+ [ length ] [ [ '[ 0 _ alien-copy-value ] ] map ] bi
'[ _ nkeep _ spread ] ;
PRIVATE>
[ [ (local-allots) ] [ box-values ] bi ] dip call
(cleanup-allot) ; inline
-: with-out-parameters ( c-types quot finish -- values )
- [ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call
+: with-out-parameters ( c-types quot -- values... )
+ [ drop (local-allots) ] [ swap out-parameters ] 2bi
(cleanup-allot) ; inline
GENERIC: binary-zero? ( value -- ? )
M: integer binary-zero? zero? ; inline
M: math:float binary-zero? double>bits zero? ; inline
M: complex binary-zero? >rect [ binary-zero? ] both? ; inline
-
(parse-c-type) dup valid-c-type? [ no-c-type ] unless ;
: scan-c-type ( -- c-type )
- scan {
+ scan-token {
{ [ dup "{" = ] [ drop \ } parse-until >array ] }
{ [ dup "pointer:" = ] [ drop scan-c-type <pointer> ] }
[ parse-c-type ]
(FUNCTION:) make-function define-declared ;
SYNTAX: FUNCTION-ALIAS:
- scan create-function
+ scan-token create-function
(FUNCTION:) (make-function) define-declared ;
SYNTAX: CALLBACK:
[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
-[ t ] [ now timestamp>micros system-micros - 1000000 < ] unit-test
[ t ] [ 0 micros>timestamp unix-1970 = ] unit-test
[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
HOOK: gmt-offset os ( -- hours minutes seconds )
+HOOK: gmt os ( -- timestamp )
+
TUPLE: duration
{ year real }
{ month real }
: timestamp>micros ( timestamp -- n )
unix-1970 (time-) 1000000 * >integer ;
-: gmt ( -- timestamp )
- #! GMT time, right now
- unix-1970 system-micros microseconds time+ ;
-
: now ( -- timestamp ) gmt >local-time ;
: hence ( duration -- timestamp ) now swap time+ ;
: ago ( duration -- timestamp ) now swap time- ;
accessors classes.struct ;
IN: calendar.unix
-: timeval>seconds ( timeval -- seconds )
+: timeval>duration ( timeval -- duration )
[ sec>> seconds ] [ usec>> microseconds ] bi time+ ;
: timeval>unix-time ( timeval -- timestamp )
- timeval>seconds since-1970 ;
+ timeval>duration since-1970 ;
: timespec>seconds ( timespec -- seconds )
[ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
M: unix gmt-offset ( -- hours minutes seconds )
get-time gmtoff>> 3600 /mod 60 /mod ;
+
+: current-timeval ( -- timeval )
+ timeval <struct> f [ gettimeofday io-error ] 2keep drop ;
+
+: system-micros ( -- n )
+ current-timeval
+ [ sec>> 1,000,000 * ] [ usec>> ] bi + ;
+
+M: unix gmt
+ current-timeval timeval>unix-time ;
USING: calendar namespaces alien.c-types system
windows.kernel32 kernel math combinators windows.errors
-accessors classes.struct ;
+accessors classes.struct calendar.format math.functions ;
IN: calendar.windows
+: timestamp>SYSTEMTIME ( timestamp -- SYSTEMTIME )
+ {
+ [ year>> ]
+ [ month>> ]
+ [ day-of-week ]
+ [ day>> ]
+ [ hour>> ]
+ [ minute>> ]
+ [
+ second>> dup floor
+ [ nip >integer ]
+ [ - 1000 * >integer ] 2bi
+ ]
+ } cleave \ SYSTEMTIME <struct-boa> ;
+
+: SYSTEMTIME>timestamp ( SYSTEMTIME -- timestamp )
+ {
+ [ wYear>> ]
+ [ wMonth>> ]
+ [ wDay>> ]
+ [ wHour>> ]
+ [ wMinute>> ]
+ [ [ wSecond>> ] [ wMilliseconds>> 1000 / ] bi + ]
+ } cleave instant <timestamp> ;
+
M: windows gmt-offset ( -- hours minutes seconds )
TIME_ZONE_INFORMATION <struct>
dup GetTimeZoneInformation {
{ TIME_ZONE_ID_STANDARD [ Bias>> ] }
{ TIME_ZONE_ID_DAYLIGHT [ [ Bias>> ] [ DaylightBias>> ] bi + ] }
} case neg 60 /mod 0 ;
+
+M: windows gmt
+ SYSTEMTIME <struct> [ GetSystemTime ] keep SYSTEMTIME>timestamp ;
: digest-value ( ctx -- value )
handle>>
{ { int EVP_MAX_MD_SIZE } int }
- [ EVP_DigestFinal_ex ssl-error ]
- [ memory>byte-array ]
- with-out-parameters ;
+ [ EVP_DigestFinal_ex ssl-error ] with-out-parameters
+ memory>byte-array ;
PRIVATE>
7 >>a
8 >>b
] unit-test
-
scan scan-c-type \ } parse-until <struct-slot-spec> ;
: parse-struct-slots ( slots -- slots' more? )
- scan {
+ scan-token {
{ ";" [ f ] }
{ "{" [ parse-struct-slot suffix! t ] }
- { f [ unexpected-eof ] }
[ invalid-struct-slot ]
} case ;
{ $values { "receiver" "an " { $snippet "NSObject" } } { "delegate" "an Objective C class" } }
{ $description "Sets the receiver's delegate to a new instance of the delegate class." } ;
-HELP: objc-error
-{ $error-description "Thrown by the Objective C runtime when an error occurs, for example, sending a message to an object with an unrecognized selector." } ;
-
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
"Utilities:"
{ $subsections
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.strings cocoa.messages cocoa cocoa.classes
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
-TUPLE: objc-error alien reason ;
-
-: objc-error ( alien -- * )
- dup -> reason CF>string \ objc-error boa throw ;
-
-M: objc-error summary ( error -- )
- drop "Objective C exception" ;
-
-[ [ objc-error ] 19 set-special-object ] "cocoa.application" add-startup-hook
-
: running.app? ( -- ? )
#! Test if we're running a .app.
".app"
+++ /dev/null
-Kevin P. Reid
+++ /dev/null
-! Copyright (C) 2005, 2006 Kevin Reid.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types assocs kernel namespaces cocoa
-cocoa.classes cocoa.runtime cocoa.subclassing debugger ;
-IN: cocoa.callbacks
-
-SYMBOL: callbacks
-
-: reset-callbacks ( -- )
- H{ } clone callbacks set-global ;
-
-reset-callbacks
-
-CLASS: {
- { +name+ "FactorCallback" }
- { +superclass+ "NSObject" }
-}
-
-{ "perform:" void { id SEL id }
- [ 2drop callbacks get at try ]
-}
-
-{ "dealloc" void { id SEL }
- [
- drop
- dup callbacks get delete-at
- SUPER-> dealloc
- ]
-} ;
-
-: <FactorCallback> ( quot -- id )
- FactorCallback -> alloc -> init
- [ callbacks get set-at ] keep ;
+++ /dev/null
-Allows you to use Factor quotations as Cocoa actions
FROM: alien.c-types => int void ;
IN: cocoa.tests
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Foo" }
-} {
- "foo:"
- void
- { id SEL NSRect }
- [ gc "x" set 2drop ]
-} ;
+CLASS: Foo < NSObject
+[
+ METHOD: void foo: NSRect rect [
+ gc rect "x" set
+ ]
+]
: test-foo ( -- )
Foo -> alloc -> init
[ 101.0 ] [ "x" get CGRect-w ] unit-test
[ 102.0 ] [ "x" get CGRect-h ] unit-test
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Bar" }
-} {
- "bar"
- NSRect
- { id SEL }
- [ 2drop test-foo "x" get ]
-} ;
+CLASS: Bar < NSObject
+[
+ METHOD: NSRect bar [ test-foo "x" get ]
+]
Bar [
-> alloc -> init
[ 102.0 ] [ "x" get CGRect-h ] unit-test
! Make sure that we can add methods
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Bar" }
-} {
- "bar"
- NSRect
- { id SEL }
- [ 2drop test-foo "x" get ]
-} {
- "babb"
- int
- { id SEL int }
- [ 2nip sq ]
-} ;
+CLASS: Bar < NSObject
+[
+ METHOD: NSRect bar [ test-foo "x" get ]
+
+ METHOD: int babb: int x [ x sq ]
+]
[ 144 ] [
Bar [
-> alloc -> init
- dup 12 -> babb
+ dup 12 -> babb:
swap -> release
] compile-call
] unit-test
objc-methods get set-at ;
: each-method-in-class ( class quot -- )
- [ { uint } [ class_copyMethodList ] [ ] with-out-parameters ] dip
+ [ { uint } [ class_copyMethodList ] with-out-parameters ] dip
over 0 = [ 3drop ] [
[ <direct-void*-array> ] dip
[ each ] [ drop (free) ] 2bi
: nib-objects ( anNSNib -- objects/f )
f
- { void* } [ -> instantiateNibWithOwner:topLevelObjects: ] [ ]
+ { void* } [ -> instantiateNibWithOwner:topLevelObjects: ]
with-out-parameters
swap [ CF>array ] [ drop f ] if ;
\ No newline at end of file
: (read-plist) ( NSData -- id )
NSPropertyListSerialization swap kCFPropertyListImmutable f
{ void* }
- [ -> propertyListFromData:mutabilityOption:format:errorDescription: ] [ ]
+ [ -> propertyListFromData:mutabilityOption:format:errorDescription: ]
with-out-parameters
[ -> release "read-plist failed" throw ] when* ;
USING: help.markup help.syntax strings alien hashtables ;
IN: cocoa.subclassing
-HELP: define-objc-class
-{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } }
-{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
- { $list
- { { $link +name+ } " - a string naming the new class. Required." }
- { { $link +superclass+ } " - a string naming the superclass. Required." }
- { { $link +protocols+ } " - an array of strings naming protocols implemented by the superclass. Optional." }
- }
-"Every element of " { $snippet "imeth" } " defines an instance method, and is an array having the shape "
-{ $snippet "{ name return args quot }" }
-".:"
-{ $table
- { "name" { "a selector name" } }
- { "name" { "a C type name; see " { $link "c-data" } } }
- { "args" { "a sequence of C type names; see " { $link "c-data" } } }
- { "quot" { "a quotation to be run as a callback when the method is invoked; see " { $link alien-callback } } }
-}
-"The quotation is run with the following values on the stack:"
-{ $list
- { "the receiver of the message; an " { $link alien } " pointing to an instance of this class" }
- { "the selector naming the message; in most cases this value can be ignored" }
- "arguments passed to the message, if any"
-}
-"There is no way to define instance variables or class methods using this mechanism. However, instance variables can be simulated by using the receiver to key into a hashtable." } ;
-
HELP: CLASS:
-{ $syntax "CLASS: spec imeth... ;" }
-{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions" } }
-{ $description "A sugared form of the following:"
- { $code "{ imeth... } \"spec\" define-objc-class" }
+{ $syntax "CLASS: name < superclass protocols... [ imeth... ]" }
+{ $values { "name" "a new class name" } { "superclass" "a superclass name" } { "protocols" "zero or more protocol names" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } }
+{ $description "Defines a new Objective C class. Instance methods are defined with the " { $link POSTPONE: METHOD: } " parsing word."
+$nl
"This word is preferred to calling " { $link define-objc-class } ", because it creates a class word in the " { $vocab-link "cocoa.classes" } " vocabulary at parse time, allowing code to refer to the class word in the same source file where the class is defined." } ;
-{ define-objc-class POSTPONE: CLASS: } related-words
+{ define-objc-class POSTPONE: CLASS: POSTPONE: METHOD: } related-words
+
+HELP: METHOD:
+{ $syntax "METHOD: return foo: type1 arg1 bar: type2 arg2 baz: ... [ body ]" }
+{ $values { "return" "a C type name" } { "type1" "a C type name" } { "arg1" "a local variable name" } { "body" "arbitrary code" } }
+{ $description "Defines a method inside of a " { $link POSTPONE: CLASS: } " form." } ;
ARTICLE: "objc-subclassing" "Subclassing Objective C classes"
-"Objective C classes can be subclassed, with new methods defined in Factor, using a parsing word:"
-{ $subsections POSTPONE: CLASS: }
-"This word is actually syntax sugar for an ordinary word:"
-{ $subsections define-objc-class }
+"Objective C classes can be subclassed, with new methods defined in Factor, using parsing words:"
+{ $subsections POSTPONE: CLASS: POSTPONE: METHOD: }
"Objective C class definitions are saved in the image. If the image is saved and Factor is restarted with the saved image, custom class definitions are made available to the Objective C runtime when they are first accessed from within Factor." ;
IN: cocoa.subclassing
-! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
+! Copyright (C) 2006, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs
-combinators compiler hashtables kernel libc math namespaces
-parser sequences words cocoa.messages cocoa.runtime locals
-compiler.units io.encodings.utf8 continuations make fry ;
+USING: alien alien.c-types alien.parser alien.strings arrays
+assocs combinators compiler hashtables kernel lexer libc
+locals.parser locals.types math namespaces parser sequences
+words cocoa.messages cocoa.runtime locals compiler.units
+io.encodings.utf8 continuations make fry effects stack-checker
+stack-checker.errors ;
IN: cocoa.subclassing
: init-method ( method -- sel imp types )
: add-protocols ( protocols class -- )
'[ [ _ ] dip objc-protocol add-protocol ] each ;
-: (define-objc-class) ( imeth protocols superclass name -- )
+: (define-objc-class) ( methods protocols superclass name -- )
[ objc-class ] dip 0 objc_allocateClassPair
[ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
tri ;
] with-compilation-unit ;
:: (redefine-objc-method) ( class method -- )
- method init-method [| sel imp types |
- class sel class_getInstanceMethod [
- imp method_setImplementation drop
- ] [
- class sel imp types add-method
- ] if*
- ] call ;
+ method init-method :> ( sel imp types )
+
+ class sel class_getInstanceMethod [
+ imp method_setImplementation drop
+ ] [
+ class sel imp types add-method
+ ] if* ;
-: redefine-objc-methods ( imeth name -- )
+: redefine-objc-methods ( methods name -- )
dup class-exists? [
objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
] [ 2drop ] if ;
-SYMBOL: +name+
-SYMBOL: +protocols+
-SYMBOL: +superclass+
-
-: define-objc-class ( imeth hash -- )
- clone [
- prepare-methods
- +name+ get "cocoa.classes" create drop
- +name+ get 2dup redefine-objc-methods swap
- +protocols+ get +superclass+ get +name+ get
- '[ _ _ _ _ (define-objc-class) ]
- import-objc-class
- ] bind ;
+:: define-objc-class ( name superclass protocols methods -- )
+ methods prepare-methods :> methods
+ name "cocoa.classes" create drop
+ methods name redefine-objc-methods
+ name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
SYNTAX: CLASS:
- parse-definition unclip
- >hashtable define-objc-class ;
+ scan-token
+ "<" expect
+ scan-token
+ "[" parse-tokens
+ \ ] parse-until define-objc-class ;
+
+: (parse-selector) ( -- )
+ scan-token {
+ { [ dup "[" = ] [ drop ] }
+ { [ dup ":" tail? ] [ scan-c-type scan-token 3array , (parse-selector) ] }
+ [ f f 3array , "[" expect ]
+ } cond ;
+
+: parse-selector ( -- selector types names )
+ [ (parse-selector) ] { } make
+ flip first3
+ [ concat ]
+ [ sift { id SEL } prepend ]
+ [ sift { "self" "selector" } prepend ] tri* ;
+
+: parse-method-body ( names -- quot )
+ [ [ make-local ] map ] H{ } make-assoc
+ (parse-lambda) <lambda> ?rewrite-closures first ;
+
+: method-effect ( quadruple -- effect )
+ [ third ] [ second void? { } { "x" } ? ] bi <effect> ;
+
+: check-method ( quadruple -- )
+ [ fourth infer ] [ method-effect ] bi
+ 2dup effect<= [ 2drop ] [ effect-error ] if ;
+
+SYNTAX: METHOD:
+ scan-c-type
+ parse-selector
+ parse-method-body [ swap ] 2dip 4array
+ dup check-method
+ suffix! ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations math sequences
-stack-checker ;
+USING: classes.tuple help.markup help.syntax kernel math
+quotations sequences stack-checker ;
IN: combinators.smart
HELP: input<sequence
{ drop-outputs keep-inputs } related-words
+HELP: dropping
+{ $values
+ { "quot" quotation }
+ { "quot" quotation }
+}
+{ $description "Outputs a quotation that, when called, will have the effect of dropping the number of inputs to the original quotation." }
+{ $examples
+ { $example
+ """USING: combinators.smart math prettyprint ;
+[ + + ] dropping ."""
+"""[ 3 ndrop ]"""
+ }
+} ;
+
+HELP: input<sequence-unsafe
+{ $values
+ { "quot" quotation }
+ { "quot" quotation }
+}
+{ $description "An unsafe version of " { $link input<sequence-unsafe } "." } ;
+
+HELP: map-reduce-outputs
+{ $values
+ { "quot" quotation } { "mapper" quotation } { "reducer" quotation }
+ { "quot" quotation }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and, treating those outputs as a sequence, calls " { $link map-reduce } " on them." }
+{ $examples
+ { $example
+"""USING: math combinators.smart prettyprint ;
+[ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ."""
+"14"
+ }
+} ;
+
+HELP: nullary
+{ $values
+ { "quot" quotation }
+ { "quot" quotation }
+}
+{ $description "Infers the number of inputs to a quotation and drops them from the stack." }
+{ $examples
+ { $example
+ """USING: combinators.smart kernel math ;
+1 2 [ + ] nullary"""
+""
+ }
+} ;
+
+HELP: preserving
+{ $values
+ { "quot" quotation }
+ { "quot" quotation }
+}
+{ $description "Calls a quotation and leaves any consumed inputs on the stack beneath the quotation's outputs." }
+{ $examples
+ { $example
+ """USING: combinators.smart kernel math prettyprint ;
+1 2 [ + ] preserving [ . ] tri@"""
+"""1
+2
+3"""
+ }
+} ;
+
+HELP: smart-apply
+{ $values
+ { "quot" quotation } { "n" integer }
+ { "quot" quotation }
+}
+{ $description "Applies a quotation to the datastack " { $snippet "n" } " times, starting lower on the stack and working up in increments of the number of inferred inputs to the quotation." }
+{ $examples
+ { $example
+ """USING: combinators.smart prettyprint math kernel ;
+1 2 3 4 [ + ] 2 smart-apply [ . ] bi@"""
+"""3
+7"""
+ }
+} ;
+
+HELP: smart-if
+{ $values
+ { "pred" quotation } { "true" quotation } { "false" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link if } " that takes three quotations, where the first quotation is a predicate that preserves any inputs it consumes." } ;
+
+HELP: smart-if*
+{ $values
+ { "pred" quotation } { "true" quotation } { "false" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link if } " that takes three quotations, where the first quotation is a predicate that preserves any inputs it consumes, the second is the " { $snippet "true" } " branch, and the third is the " { $snippet "false" } " branch. If the " { $snippet "true" } " branch is taken, the values are left on the stack and the quotation is called. If the " { $snippet "false" } " branch is taken, the number of inputs inferred from predicate quotation is dropped and the quotation is called." } ;
+
+HELP: smart-unless
+{ $values
+ { "pred" quotation } { "false" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link unless } " that takes two quotations, where the first quotation is a predicate that preserves any inputs it consumes and the second is the " { $snippet "false" } " branch." } ;
+
+HELP: smart-unless*
+{ $values
+ { "pred" quotation } { "false" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link unless } " that takes two quotations, where the first quotation is a predicate that preserves any inputs it consumes and the second is the " { $snippet "false" } " branch. If the " { $snippet "true" } " branch is taken, the values are left on the stack. If the " { $snippet "false" } " branch is taken, the number of inputs inferred from predicate quotation is dropped and the quotation is called." } ;
+
+HELP: smart-when
+{ $values
+ { "pred" quotation } { "true" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link when } " that takes two quotations, where the first quotation is a predicate that preserves any inputs it consumes and the second is the " { $snippet "true" } " branch." } ;
+
+HELP: smart-when*
+{ $values
+ { "pred" quotation } { "true" quotation }
+ { "quot" quotation }
+}
+{ $description "A version of " { $link when } " that takes two quotations, where the first quotation is a predicate that preserves any inputs it consumes and the second is the " { $snippet "true" } " branch. If the " { $snippet "true" } " branch is taken, the values are left on the stack and the quotation is called. If the " { $snippet "false" } " branch is taken, the number of inputs inferred from predicate quotation is dropped." } ;
+
ARTICLE: "combinators.smart" "Smart combinators"
"A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
-"Call a quotation and discard all output values or preserve all input values:"
+"Take all input values from a sequence:"
{ $subsections
- drop-outputs
- keep-inputs
+ input<sequence
+ input<sequence-unsafe
}
-"Take all input values from a sequence:"
-{ $subsections input<sequence }
"Store all output values to a sequence:"
{ $subsections
output>sequence
output>array
}
"Reducing the set of output values:"
-{ $subsections reduce-outputs }
+{ $subsections
+ reduce-outputs
+ map-reduce-outputs
+}
+"Applying a quotation to groups of elements on the stack:"
+{ $subsections smart-apply }
"Summing output values:"
{ $subsections sum-outputs }
"Concatenating output values:"
append-outputs
append-outputs-as
}
+"Drop the outputs after calling a quotation:"
+{ $subsections drop-outputs }
+"Cause a quotation to act as a no-op and drop the inputs:"
+{ $subsection nullary }
+"Preserve the inputs below or above the outputs of the quotation:"
+{ $subsections preserving keep-inputs }
+"Versions of if that infer how many inputs to keep from the predicate quotation:"
+{ $subsections smart-if smart-when smart-unless }
+"Versions of if* that infer how many inputs to keep from the predicate quotation:"
+{ $subsections smart-if* smart-when* smart-unless* }
"New smart combinators can be created by defining " { $link "macros" } " which call " { $link infer } "." ;
ABOUT: "combinators.smart"
MACRO: preserving ( quot -- )
[ inputs ] keep '[ _ ndup @ ] ;
-MACRO: nullary ( quot -- quot' )
- dup outputs '[ @ _ ndrop ] ;
-
MACRO: dropping ( quot -- quot' )
inputs '[ [ _ ndrop ] ] ;
-MACRO: balancing ( quot -- quot' )
- '[ _ [ preserving ] [ dropping ] bi ] ;
+MACRO: nullary ( quot -- quot' ) dropping ;
MACRO: smart-if ( pred true false -- quot )
'[ _ preserving _ _ if ] ;
'[ _ [ ] _ smart-if ] ;
MACRO: smart-if* ( pred true false -- quot )
- '[ _ balancing _ swap _ compose if ] ;
+ '[ _ [ preserving ] [ dropping ] bi _ swap _ compose if ] ;
MACRO: smart-when* ( pred true -- quot )
'[ _ _ [ ] smart-if* ] ;
T{ ##compare f 6 5 1 cc= }
} test-alias-analysis
] unit-test
+
+! We can't make any assumptions about heap-ac between alien
+! calls, since they might callback into Factor code
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
+ T{ ##slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##peek f 1 D 1 }
+ T{ ##peek f 2 D 2 }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
+ T{ ##set-slot-imm f 2 0 1 0 }
+ } test-alias-analysis
+] unit-test
+
+[
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ }
+] [
+ V{
+ T{ ##peek f 0 D 0 }
+ T{ ##slot-imm f 1 0 1 0 }
+ T{ ##alien-invoke f { } { } { } 0 0 "free" }
+ T{ ##set-slot-imm f 1 0 1 0 }
+ } test-alias-analysis
+] unit-test
slot# vreg kill-constant-set-slot
] [ vreg kill-computed-set-slot ] if ;
+: init-alias-analysis ( -- )
+ H{ } clone vregs>acs set
+ H{ } clone acs>vregs set
+ H{ } clone live-slots set
+ H{ } clone copies set
+ H{ } clone recent-stores set
+ HS{ } clone dead-stores set
+ 0 ac-counter set ;
+
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
! anywhere its used as a tagged pointer. Boxing allocates
! a new value, except boxing instructions haven't been
! inserted yet.
- dup defs-vreg [
- over defs-vreg-rep { int-rep tagged-rep } member?
+ dup [
+ { int-rep tagged-rep } member?
[ set-heap-ac ] [ set-new-ac ] if
- ] when* ;
+ ] each-def-rep ;
M: ##phi analyze-aliases
- dup defs-vreg set-heap-ac ;
+ dup dst>> set-heap-ac ;
M: ##allocation analyze-aliases
#! A freshly allocated object is distinct from any other
analyze-aliases
] when ;
-GENERIC: eliminate-dead-stores ( insn -- ? )
-
-M: ##set-slot-imm eliminate-dead-stores
- insn#>> dead-stores get in? not ;
-
-M: insn eliminate-dead-stores drop t ;
-
-: init-alias-analysis ( -- )
- H{ } clone vregs>acs set
- H{ } clone acs>vregs set
- H{ } clone live-slots set
- H{ } clone copies set
- H{ } clone recent-stores set
- HS{ } clone dead-stores set
- 0 ac-counter set ;
-
: reset-alias-analysis ( -- )
recent-stores get clear-assoc
vregs>acs get clear-assoc
\ ##vm-field set-new-ac
\ ##alien-global set-new-ac ;
+M: factor-call-insn analyze-aliases
+ heap-ac get ac>vregs [
+ [ live-slots get at clear-assoc ]
+ [ recent-stores get at clear-assoc ] bi
+ ] each ;
+
+GENERIC: eliminate-dead-stores ( insn -- ? )
+
+M: ##set-slot-imm eliminate-dead-stores
+ insn#>> dead-stores get in? not ;
+
+M: insn eliminate-dead-stores drop t ;
+
: alias-analysis-step ( insns -- insns' )
reset-alias-analysis
[ local-live-in [ set-heap-ac ] each ]
! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit kernel
-math math.order sequences assocs namespaces vectors fry arrays
-splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
-compiler.cfg.predecessors compiler.cfg.renaming
+locals math math.order sequences assocs namespaces vectors fry
+arrays splitting compiler.cfg.def-use compiler.cfg
+compiler.cfg.rpo compiler.cfg.predecessors compiler.cfg.renaming
compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
1vector >>predecessors
] with map ;
-: update-predecessor-successor ( pred copy old-bb -- )
- '[
- [ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
- ] change-successors drop ;
-
: update-predecessor-successors ( copies old-bb -- )
[ predecessors>> swap ] keep
- '[ _ update-predecessor-successor ] 2each ;
+ '[ [ _ ] 2dip update-predecessors ] 2each ;
-: update-successor-predecessor ( copies old-bb succ -- )
- [
- swap 1array split swap join V{ } like
- ] change-predecessors drop ;
+:: update-successor-predecessor ( copies old-bb succ -- )
+ succ
+ [ { old-bb } split copies join V{ } like ] change-predecessors
+ drop ;
: update-successor-predecessors ( copies old-bb -- )
- dup successors>> [
- update-successor-predecessor
- ] with with each ;
+ dup successors>>
+ [ update-successor-predecessor ] with with each ;
: split-branch ( bb -- )
[ new-blocks ] keep
allot-area-align [ a max ] change
allot-area-size [ a align [ insn offset<< ] [ s + ] bi ] change ;
-M: ##stack-frame compute-stack-frame*
+M: alien-call-insn compute-stack-frame*
frame-required
- stack-frame>> param-area-size [ max ] change ;
+ stack-size>> param-area-size [ max ] change ;
: vm-frame-required ( -- )
frame-required
M: ##box compute-stack-frame* drop vm-frame-required ;
M: ##unbox compute-stack-frame* drop vm-frame-required ;
M: ##box-long-long compute-stack-frame* drop vm-frame-required ;
-M: ##begin-callback compute-stack-frame* drop vm-frame-required ;
-M: ##end-callback compute-stack-frame* drop vm-frame-required ;
+M: ##callback-inputs compute-stack-frame* drop vm-frame-required ;
+M: ##callback-outputs compute-stack-frame* drop vm-frame-required ;
M: ##unary-float-function compute-stack-frame* drop vm-frame-required ;
M: ##binary-float-function compute-stack-frame* drop vm-frame-required ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs arrays layouts math math.order math.parser
-combinators combinators.short-circuit fry make sequences
-sequences.generalizations alien alien.private alien.strings
-alien.c-types alien.libraries classes.struct namespaces kernel
-strings libc locals quotations words cpu.architecture
-compiler.utilities compiler.tree compiler.cfg
+USING: accessors assocs arrays layouts math math.order
+math.parser combinators combinators.short-circuit fry make
+sequences sequences.generalizations alien alien.private
+alien.strings alien.c-types alien.libraries classes.struct
+namespaces kernel strings libc locals quotations words
+cpu.architecture compiler.utilities compiler.tree compiler.cfg
compiler.cfg.builder compiler.cfg.builder.alien.params
compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
compiler.cfg.instructions compiler.cfg.stack-frame
-compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
+compiler.cfg.stacks compiler.cfg.stacks.local
+compiler.cfg.registers compiler.cfg.hats ;
FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien
+: with-param-regs* ( quot -- reg-values stack-values )
+ '[
+ V{ } clone reg-values set
+ V{ } clone stack-values set
+ @
+ reg-values get
+ stack-values get
+ stack-params get
+ struct-return-area get
+ ] with-param-regs
+ struct-return-area set
+ stack-params set ; inline
+
: unbox-parameters ( parameters -- vregs reps )
[
[ length iota <reversed> ] keep
- [ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
+ [ [ <ds-loc> peek-loc ] [ base-type ] bi* unbox-parameter ]
2 2 mnmap [ concat ] bi@
]
- [ length neg ##inc-d ] bi ;
+ [ length neg inc-d ] bi ;
: prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
dup large-struct? [
] keep
] [ drop f ] if ;
-: caller-parameter ( vreg rep on-stack? -- insn )
- [ dup reg-class-of reg-class-full? ] dip or
- [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
- [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
- if ;
-
: (caller-parameters) ( vregs reps -- )
- ! Place ##store-stack-param instructions first. This ensures
- ! that no registers are used after the ##store-reg-param
- ! instructions.
- [ first2 caller-parameter ] 2map
- [ ##store-stack-param? ] partition [ % ] bi@ ;
+ [ first2 next-parameter ] 2each ;
-: caller-parameters ( params -- stack-size )
+: caller-parameters ( params -- reg-inputs stack-inputs )
[ abi>> ] [ parameters>> ] [ return>> ] tri
'[
_ unbox-parameters
_ prepare-struct-caller struct-return-area set
(caller-parameters)
- stack-params get
- struct-return-area get
- ] with-param-regs
- struct-return-area set ;
+ ] with-param-regs* ;
-: box-return* ( node -- )
- return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
+: prepare-caller-return ( params -- reg-outputs )
+ return>> [ { } ] [ base-type load-return ] if-void ;
+
+: caller-stack-frame ( params -- cleanup stack-size )
+ [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup
+ stack-params get ;
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
} 2cleave
4array ;
-: alien-invoke-dlsym ( params -- symbols dll )
+: caller-linkage ( params -- symbols dll )
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
[ library>> load-library ]
bi 2dup check-dlsym ;
-: alien-node-height ( params -- )
- [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
-
-: emit-alien-block ( node quot: ( params -- ) -- )
- '[
- make-kill-block
- params>>
- _ [ alien-node-height ] bi
- ] emit-trivial-block ; inline
-
-: emit-stack-frame ( stack-size params -- )
- [ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
- [ drop ##stack-frame ]
- 2bi ;
+: caller-return ( params -- )
+ return>> [ ] [
+ [
+ building get last reg-outputs>>
+ flip [ { } { } ] [ first2 ] if-empty
+ ] dip
+ base-type box-return ds-push
+ ] if-void ;
M: #alien-invoke emit-node
+ params>>
[
{
[ caller-parameters ]
- [ ##prepare-var-args alien-invoke-dlsym ##alien-invoke ]
- [ emit-stack-frame ]
- [ box-return* ]
+ [ prepare-caller-return ]
+ [ caller-stack-frame ]
+ [ caller-linkage ]
} cleave
- ] emit-alien-block ;
+ <gc-map> ##alien-invoke
+ ]
+ [ caller-return ]
+ bi ;
-M:: #alien-indirect emit-node ( node -- )
- node [
- D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
- [ caller-parameters src ##alien-indirect ]
- [ emit-stack-frame ]
- [ box-return* ]
- tri
- ] emit-alien-block ;
+M: #alien-indirect emit-node ( node -- )
+ params>>
+ [
+ [ ds-pop ^^unbox-any-c-ptr ] dip
+ [ caller-parameters ]
+ [ prepare-caller-return ]
+ [ caller-stack-frame ] tri
+ <gc-map> ##alien-indirect
+ ]
+ [ caller-return ]
+ bi ;
M: #alien-assembly emit-node
+ params>>
[
{
[ caller-parameters ]
- [ quot>> ##alien-assembly ]
- [ emit-stack-frame ]
- [ box-return* ]
- } cleave
- ] emit-alien-block ;
+ [ prepare-caller-return ]
+ [ caller-stack-frame ]
+ [ quot>> ]
+ } cleave <gc-map> ##alien-assembly
+ ]
+ [ caller-return ]
+ bi ;
-: callee-parameter ( rep on-stack? -- dst insn )
- [ next-vreg dup ] 2dip
- [ dup reg-class-of reg-class-full? ] dip or
- [ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]
- [ [ next-reg-param ] keep \ ##load-reg-param new-insn ]
- if ;
+: callee-parameter ( rep on-stack? -- dst )
+ [ next-vreg dup ] 2dip next-parameter ;
: prepare-struct-callee ( c-type -- vreg )
large-struct?
- [ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;
+ [ int-rep struct-return-on-stack? callee-parameter ] [ f ] if ;
: (callee-parameters) ( params -- vregs reps )
[ flatten-parameter-type ] map
- [
- [ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap
- concat [ ##load-reg-param? ] partition [ % ] bi@
- ]
+ [ [ [ first2 callee-parameter ] map ] map ]
[ [ keys ] map ]
bi ;
: box-parameters ( vregs reps params -- )
- ##begin-callback
- next-vreg next-vreg ##restore-context
- [
- next-vreg next-vreg ##save-context
- box-parameter
- 1 ##inc-d D 0 ##replace
- ] 3each ;
+ parameters>> [ base-type box-parameter ds-push ] 3each ;
-: callee-parameters ( params -- stack-size )
+: callee-parameters ( params -- vregs reps reg-outputs stack-outputs )
[ abi>> ] [ return>> ] [ parameters>> ] tri
'[
_ prepare-struct-callee struct-return-area set
- _ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi
- stack-params get
- struct-return-area get
- ] with-param-regs
- struct-return-area set ;
-
-: callback-stack-cleanup ( stack-size params -- )
- [ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
+ _ [ base-type ] map (callee-parameters)
+ ] with-param-regs* ;
+
+: callee-return ( params -- reg-inputs )
+ return>> [ { } ] [
+ [ ds-pop ] dip
+ base-type unbox-return store-return
+ ] if-void ;
+
+: callback-stack-cleanup ( params -- )
+ [ xt>> ]
+ [ [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup ] bi
"stack-cleanup" set-word-prop ;
: needs-frame-pointer ( -- )
cfg get t >>frame-pointer? drop ;
M: #alien-callback emit-node
- dup params>> xt>> dup
+ params>> dup xt>> dup
[
needs-frame-pointer
- ##prologue
- [
- {
- [ callee-parameters ]
- [ quot>> ##alien-callback ]
+ begin-word
+
+ {
+ [ callee-parameters ##callback-inputs ]
+ [ box-parameters ]
+ [
[
- return>> [ ##end-callback ] [
- [ D 0 ^^peek ] dip
- ##end-callback
- base-type unbox-return
- ] if-void
- ]
- [ callback-stack-cleanup ]
- } cleave
- ] emit-alien-block
- ##epilogue
- ##return
+ make-kill-block
+ quot>> ##alien-callback
+ ] emit-trivial-block
+ ]
+ [ callee-return ##callback-outputs ]
+ [ callback-stack-cleanup ]
+ } cleave
+
+ end-word
] with-cfg-builder ;
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays assocs classes.struct fry
-kernel layouts locals math namespaces sequences
-sequences.generalizations system
+USING: accessors alien.c-types arrays assocs combinators
+classes.struct fry kernel layouts locals math namespaces
+sequences sequences.generalizations system
compiler.cfg.builder.alien.params compiler.cfg.hats
-compiler.cfg.instructions cpu.architecture ;
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.intrinsics.allot cpu.architecture ;
IN: compiler.cfg.builder.alien.boxing
SYMBOL: struct-return-area
GENERIC: unbox ( src c-type -- vregs reps )
M: c-type unbox
- [ unboxer>> ] [ rep>> ] bi
- [ ^^unbox 1array ] [ nip f 2array 1array ] 2bi ;
+ [ rep>> ] [ unboxer>> ] bi
+ [
+ {
+ ! { "to_float" [ drop ] }
+ ! { "to_double" [ drop ] }
+ ! { "alien_offset" [ drop ^^unbox-any-c-ptr ] }
+ [ swap ^^unbox ]
+ } case 1array
+ ]
+ [ drop f 2array 1array ] 2bi ;
M: long-long-type unbox
- [ 8 cell f ^^local-allot ] dip '[ _ unboxer>> ##unbox-long-long ] keep
- 0 cell [ int-rep f ^^load-memory-imm ] bi-curry@ bi 2array
+ [ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long 2array
int-rep long-long-on-stack? 2array dup 2array ;
-M: struct-c-type unbox ( src c-type -- vregs )
+M: struct-c-type unbox ( src c-type -- vregs reps )
[ ^^unbox-any-c-ptr ] dip explode-struct ;
: frob-struct ( c-type -- c-type )
1array { { int-rep f } }
] if ;
-GENERIC: unbox-return ( src c-type -- )
+: store-return ( vregs reps -- triples )
+ [ [ dup next-return-reg 3array ] 2map ] with-return-regs ;
-: store-return ( vregs reps -- )
- [
- [ [ next-return-reg ] keep ##store-reg-param ] 2each
- ] with-return-regs ;
+GENERIC: unbox-return ( src c-type -- vregs reps )
-: (unbox-return) ( src c-type -- vregs reps )
+M: abstract-c-type unbox-return
! Don't care about on-stack? flag when looking at return
! values.
unbox keys ;
-M: c-type unbox-return (unbox-return) store-return ;
-
-M: long-long-type unbox-return (unbox-return) store-return ;
-
M: struct-c-type unbox-return
dup return-struct-in-registers?
- [ (unbox-return) store-return ]
- [ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ;
+ [ call-next-method ]
+ [ [ struct-return-area get ] 2dip unbox keys implode-struct { } { } ] if ;
GENERIC: flatten-parameter-type ( c-type -- reps )
-M: c-type flatten-parameter-type flatten-c-type ;
-
-M: long-long-type flatten-parameter-type flatten-c-type ;
+M: abstract-c-type flatten-parameter-type flatten-c-type ;
M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
GENERIC: box ( vregs reps c-type -- dst )
M: c-type box
- [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ;
+ [ [ first ] bi@ ] [ boxer>> ] bi*
+ {
+ ! { "from_float" [ drop ] }
+ ! { "from_double" [ drop ] }
+ ! { "allot_alien" [ drop ^^box-alien ] }
+ [ swap <gc-map> ^^box ]
+ } case ;
M: long-long-type box
- [ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ;
+ [ first2 ] [ drop ] [ boxer>> ] tri*
+ <gc-map> ^^box-long-long ;
M: struct-c-type box
'[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
GENERIC: box-parameter ( vregs reps c-type -- dst )
-M: c-type box-parameter box ;
-
-M: long-long-type box-parameter box ;
+M: abstract-c-type box-parameter box ;
M: struct-c-type box-parameter
dup value-struct?
[ [ [ drop first ] dip explode-struct keys ] keep ] unless
box ;
-GENERIC: box-return ( c-type -- dst )
+GENERIC: load-return ( c-type -- triples )
-: load-return ( c-type -- vregs reps )
+M: abstract-c-type load-return
[
flatten-c-type keys
- [ [ [ next-return-reg ] keep ^^load-reg-param ] map ] keep
+ [ [ next-vreg ] dip dup next-return-reg 3array ] map
] with-return-regs ;
-M: c-type box-return [ load-return ] keep box ;
+M: struct-c-type load-return
+ dup return-struct-in-registers?
+ [ call-next-method ] [ drop { } ] if ;
+
+GENERIC: box-return ( vregs reps c-type -- dst )
-M: long-long-type box-return [ load-return ] keep box ;
+M: abstract-c-type box-return box ;
M: struct-c-type box-return
+ dup return-struct-in-registers?
+ [ call-next-method ]
[
- dup return-struct-in-registers?
- [ load-return ]
- [ [ struct-return-area get ] dip explode-struct keys ] if
- ] keep box ;
+ [
+ [ [ { } assert-sequence= ] bi@ struct-return-area get ] dip
+ explode-struct keys
+ ] keep box
+ ] if ;
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cpu.architecture fry kernel layouts math math.order
-namespaces sequences vectors assocs ;
+namespaces sequences vectors assocs arrays ;
IN: compiler.cfg.builder.alien.params
SYMBOL: stack-params
: with-param-regs ( abi quot -- )
'[ param-regs init-regs 0 stack-params set @ ] with-scope ; inline
+SYMBOLS: stack-values reg-values ;
+
+: next-parameter ( vreg rep on-stack? -- )
+ [ dup dup reg-class-of reg-class-full? ] dip or
+ [ alloc-stack-param stack-values ] [ next-reg-param reg-values ] if
+ [ 3array ] dip get push ;
+
: next-return-reg ( rep -- reg ) reg-class-of get pop ;
: with-return-regs ( quot -- )
: set-successors ( branches -- )
! Set the successor of each branch's final basic block to the
! current block.
- basic-block get dup [
- '[ [ [ _ ] dip first successors>> push ] when* ] each
- ] [ 2drop ] if ;
-
-: merge-heights ( branches -- )
- ! If all elements are f, that means every branch ended with a backward
- ! jump so the height is irrelevant since this block is unreachable.
- [ ] find nip [ second current-height set ] [ end-basic-block ] if* ;
+ [ [ [ basic-block get ] dip first successors>> push ] when* ] each ;
: emit-conditional ( branches -- )
! branches is a sequence of pairs as above
end-basic-block
- [ merge-heights begin-basic-block ]
- [ set-successors ]
- bi ;
-
+ dup [ ] find nip dup [
+ second current-height set
+ begin-basic-block
+ set-successors
+ ] [ 2drop ] if ;
dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
! #return
-: emit-return ( -- )
+: end-word ( -- )
##branch
begin-basic-block
make-kill-block
##epilogue
##return ;
-M: #return emit-node drop emit-return ;
+M: #return emit-node drop end-word ;
M: #return-recursive emit-node
- label>> id>> loops get key? [ emit-return ] unless ;
+ label>> id>> loops get key? [ end-word ] unless ;
! #terminate
M: #terminate emit-node drop ##no-tco end-basic-block ;
] if ;
M: vreg-insn visit-insn
- defs-vreg [ dup record-copy ] when* ;
+ defs-vregs [ dup record-copy ] each ;
M: insn visit-insn drop ;
GENERIC: build-liveness-graph ( insn -- )
-: add-edges ( insn register -- )
- [ uses-vregs ] dip liveness-graph get [ union ] change-at ;
+: add-edges ( uses def -- )
+ liveness-graph get [ union ] change-at ;
: setter-liveness-graph ( insn vreg -- )
- dup allocation? [ add-edges ] [ 2drop ] if ;
+ dup allocation? [ [ uses-vregs ] dip add-edges ] [ 2drop ] if ;
M: ##set-slot build-liveness-graph
dup obj>> setter-liveness-graph ;
[ dst>> allocations get adjoin ] [ call-next-method ] bi ;
M: vreg-insn build-liveness-graph
- dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
+ [ uses-vregs ] [ defs-vregs ] bi [ add-edges ] with each ;
M: insn build-liveness-graph drop ;
M: ##write-barrier-imm compute-live-vregs
dup src>> setter-live-vregs ;
-M: ##fixnum-add compute-live-vregs record-live ;
+M: flushable-insn compute-live-vregs drop ;
-M: ##fixnum-sub compute-live-vregs record-live ;
-
-M: ##fixnum-mul compute-live-vregs record-live ;
-
-M: vreg-insn compute-live-vregs
- dup defs-vreg [ drop ] [ record-live ] if ;
+M: vreg-insn compute-live-vregs record-live ;
M: insn compute-live-vregs drop ;
M: ##write-barrier-imm live-insn? src>> live-vreg? ;
-M: ##fixnum-add live-insn? drop t ;
-
-M: ##fixnum-sub live-insn? drop t ;
-
-M: ##fixnum-mul live-insn? drop t ;
-
-M: vreg-insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
+M: flushable-insn live-insn? defs-vregs [ live-vreg? ] any? ;
-M: insn live-insn? defs-vreg drop t ;
+M: insn live-insn? drop t ;
: eliminate-dead-code ( cfg -- cfg' )
! Even though we don't use predecessors directly, we depend
post-order [
instructions>> [
[ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
- [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
- bi [ suffix ] when*
+ [ [ defs-vregs ] [ defs-vreg-reps ] bi zip ]
+ bi append
] map concat
] map concat >hashtable representations set ;
5 6 edge
cfg new 1 get >>entry 0 set
-[ ] [ 0 get [ compute-defs ] [ compute-uses ] bi ] unit-test
+[ ] [ 0 get compute-defs ] unit-test
FROM: sets => members ;
IN: compiler.cfg.def-use
-GENERIC: defs-vreg ( insn -- vreg/f )
+GENERIC: defs-vregs ( insn -- seq )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
-M: insn defs-vreg drop f ;
+M: insn defs-vregs drop { } ;
M: insn temp-vregs drop { } ;
M: insn uses-vregs drop { } ;
-M: ##phi uses-vregs inputs>> values ;
-
<PRIVATE
: slot-array-quot ( slots -- quot )
[ '[ _ cleave _ narray ] ]
} case ;
-: define-defs-vreg-method ( insn -- )
- dup insn-def-slot dup [
- [ \ defs-vreg create-method ]
- [ name>> reader-word 1quotation ] bi*
+: define-vregs-method ( insn slots word -- )
+ [ [ drop ] ] dip '[
+ [ _ create-method ]
+ [ [ name>> ] map slot-array-quot ] bi*
define
- ] [ 2drop ] if ;
+ ] if-empty ; inline
+
+: define-defs-vregs-method ( insn -- )
+ dup insn-def-slots \ defs-vregs define-vregs-method ;
: define-uses-vregs-method ( insn -- )
- dup insn-use-slots [ drop ] [
- [ \ uses-vregs create-method ]
- [ [ name>> ] map slot-array-quot ] bi*
- define
- ] if-empty ;
+ dup insn-use-slots \ uses-vregs define-vregs-method ;
: define-temp-vregs-method ( insn -- )
- dup insn-temp-slots [ drop ] [
- [ \ temp-vregs create-method ]
- [ [ name>> ] map slot-array-quot ] bi*
- define
- ] if-empty ;
+ dup insn-temp-slots \ temp-vregs define-vregs-method ;
PRIVATE>
+CONSTANT: special-vreg-insns
+{ ##phi ##alien-invoke ##alien-indirect ##alien-assembly ##callback-inputs ##callback-outputs }
+
+M: ##phi defs-vregs dst>> 1array ;
+
+M: alien-call-insn defs-vregs
+ reg-outputs>> [ first ] map ;
+
+M: ##callback-inputs defs-vregs
+ [ reg-outputs>> ] [ stack-outputs>> ] bi append [ first ] map ;
+
+M: ##callback-outputs defs-vregs drop { } ;
+
+M: ##phi uses-vregs inputs>> values ;
+
+M: alien-call-insn uses-vregs
+ [ reg-inputs>> ] [ stack-inputs>> ] bi append [ first ] map ;
+
+M: ##alien-indirect uses-vregs
+ [ call-next-method ] [ src>> ] bi prefix ;
+
+M: ##callback-inputs uses-vregs
+ drop { } ;
+
+M: ##callback-outputs uses-vregs
+ reg-inputs>> [ first ] map ;
+
[
insn-classes get
- [ [ define-defs-vreg-method ] each ]
- [ { ##phi } diff [ define-uses-vregs-method ] each ]
+ [ special-vreg-insns diff [ define-defs-vregs-method ] each ]
+ [ special-vreg-insns diff [ define-uses-vregs-method ] each ]
[ [ define-temp-vregs-method ] each ]
tri
] with-compilation-unit
: insn-of ( vreg -- insn ) insns get at ;
: set-def-of ( obj insn assoc -- )
- swap defs-vreg dup [ swap set-at ] [ 3drop ] if ;
+ swap defs-vregs [ swap set-at ] with with each ;
: compute-defs ( cfg -- )
H{ } clone [
] each
] each-basic-block
] keep insns set ;
-
-:: compute-uses ( cfg -- )
- ! Here, a phi node uses its argument in the block that it comes from.
- H{ } clone :> use
- cfg [| block |
- block instructions>> [
- dup ##phi?
- [ inputs>> [ use adjoin-at ] assoc-each ]
- [ uses-vregs [ block swap use adjoin-at ] each ]
- if
- ] each
- ] each-basic-block
- use [ members ] assoc-map uses set ;
children parent
registers parent-index ;
-M: node equal? [ number>> ] bi@ = ;
+M: node equal? over node? [ [ number>> ] bi@ = ] [ 2drop f ] if ;
M: node hashcode* nip number>> ;
! we only care about local def-use
H{ } clone :> definers
nodes [| node |
- node insn>> defs-vreg [ node swap definers set-at ] when*
+ node insn>> defs-vregs [ node swap definers set-at ] each
node insn>> uses-vregs [ definers at [ node +data+ precedes ] when* ] each
] each ;
UNION: memory-insn
##load-memory ##load-memory-imm
- ##store-memory ##store-memory-imm ;
-
-UNION: alien-call-insn
- ##save-context
- ##alien-invoke ##alien-indirect ##alien-callback
- ##unary-float-function ##binary-float-function ;
+ ##store-memory ##store-memory-imm
+ alien-call-insn
+ slot-insn ;
: chain ( node var -- )
dup get [
GENERIC: add-control-edge ( node insn -- )
-M: stack-insn add-control-edge
- loc>> chain ;
-
-M: memory-insn add-control-edge
- drop memory-insn chain ;
+M: stack-insn add-control-edge loc>> chain ;
-M: slot-insn add-control-edge
- drop slot-insn chain ;
-
-M: alien-call-insn add-control-edge
- drop alien-call-insn chain ;
+M: memory-insn add-control-edge drop memory-insn chain ;
M: object add-control-edge 2drop ;
: add-control-edges ( nodes -- )
- [
- [ dup insn>> add-control-edge ] each
- ] with-scope ;
+ [ [ dup insn>> add-control-edge ] each ] with-scope ;
: set-follows ( nodes -- )
[
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg.gc-checks compiler.cfg.representations
+USING: kernel compiler.cfg.representations
+compiler.cfg.scheduling compiler.cfg.gc-checks
compiler.cfg.save-contexts compiler.cfg.ssa.destruction
compiler.cfg.build-stack-frame compiler.cfg.linear-scan
-compiler.cfg.scheduling ;
+compiler.cfg.stacks.uninitialized ;
IN: compiler.cfg.finalization
: finalize-cfg ( cfg -- cfg' )
select-representations
schedule-instructions
insert-gc-checks
+ dup compute-uninitialized-sets
insert-save-contexts
destruct-ssa
linear-scan
compiler.cfg.registers compiler.cfg.instructions compiler.cfg
compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
tools.test kernel vectors namespaces accessors sequences alien
-memory classes make combinators.short-circuit byte-arrays ;
+memory classes make combinators.short-circuit byte-arrays
+compiler.cfg.comparisons ;
IN: compiler.cfg.gc-checks.tests
+[ { } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##alien-invoke }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 0 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##allot }
+ T{ ##alien-invoke }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 0 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##allot }
+ T{ ##allot }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 0 4 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##allot }
+ T{ ##alien-invoke }
+ T{ ##allot }
+ T{ ##add }
+ T{ ##sub }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { 3 } ] [
+ V{
+ T{ ##inc-d }
+ T{ ##peek }
+ T{ ##alien-invoke }
+ T{ ##allot }
+ T{ ##add }
+ T{ ##branch }
+ } gc-check-offsets
+] unit-test
+
+[ { { "a" } } ] [ { "a" } { } split-instructions ] unit-test
+
+[ { { } { "a" } } ] [ { "a" } { 0 } split-instructions ] unit-test
+
+[ { { "a" } { } } ] [ { "a" } { 1 } split-instructions ] unit-test
+
+[ { { "a" } { "b" } } ] [ { "a" "b" } { 1 } split-instructions ] unit-test
+
+[ { { } { "a" } { "b" "c" } } ] [ { "a" "b" "c" } { 0 1 } split-instructions ] unit-test
+
: test-gc-checks ( -- )
H{ } clone representations set
cfg new 0 get >>entry cfg set ;
[ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
-[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
+[ ] [ 1 get
instructions>> allocation-size 123 <alien> size assert= ] unit-test
2 \ vreg-counter set-global
[ first ##check-nursery-branch? ]
} 1&& ;
-[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
-
-4 \ vreg-counter set-global
-
-[
+: gc-call? ( bb -- ? )
+ instructions>>
V{
- T{ ##gc-map f V{ 0 } V{ 3 } { 0 1 2 } }
- T{ ##call-gc }
+ T{ ##call-gc f T{ gc-map } }
T{ ##branch }
- }
-]
-[
- V{ D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
-] unit-test
-
-30 \ vreg-counter set-global
-
-V{
- T{ ##branch }
-} 0 test-bb
+ } = ;
-V{
- T{ ##branch }
-} 1 test-bb
-
-V{
- T{ ##branch }
-} 2 test-bb
-
-V{
- T{ ##branch }
-} 3 test-bb
-
-V{
- T{ ##branch }
-} 4 test-bb
-
-0 { 1 2 } edges
-1 3 edge
-2 3 edge
-3 4 edge
-
-[ ] [ test-gc-checks ] unit-test
-
-[ ] [ cfg get needs-predecessors drop ] unit-test
-
-[ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test
-
-[ t ] [ 1 get successors>> first gc-check? ] unit-test
-
-[ t ] [ 2 get successors>> first gc-check? ] unit-test
+4 \ vreg-counter set-global
-[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
+[ t ] [ <gc-call> gc-call? ] unit-test
30 \ vreg-counter set-global
[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ 1 get successors>> first successors>> first 2 set ] unit-test
+
[ 2 ] [ 2 get predecessors>> length ] unit-test
[ t ] [ 1 get successors>> first gc-check? ] unit-test
[
V{
- T{ ##gc-map f V{ 0 1 2 } V{ } { 2 } }
- T{ ##call-gc }
+ T{ ##call-gc f T{ gc-map } }
T{ ##branch }
}
] [ 2 get predecessors>> second instructions>> ] unit-test
} representations set
[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ 1 get successors>> first successors>> first 3 set ] unit-test
[ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
[ 2 ] [ 3 get instructions>> length ] unit-test
+
+! GC check in a block that is its own successor
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##allot f 1 64 byte-array }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 { 1 2 } edges
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[ ] [
+ 0 get successors>> first predecessors>>
+ [ first 0 get assert= ]
+ [ second 1 get [ instructions>> ] bi@ assert= ] bi
+] unit-test
+
+[ ] [
+ 0 get successors>> first successors>>
+ [ first 1 get [ instructions>> ] bi@ assert= ]
+ [ second gc-call? t assert= ] bi
+] unit-test
+
+[ ] [
+ 2 get predecessors>> first predecessors>>
+ [ first gc-check? t assert= ]
+ [ second gc-call? t assert= ] bi
+] unit-test
+
+! Brave new world of calls in the middle of BBs
+
+! call then allot
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##allot f 1 64 byte-array }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+2 \ vreg-counter set-global
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+! The GC check should come after the alien-invoke
+[
+ V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##check-nursery-branch f 64 cc<= 3 4 }
+ }
+] [ 0 get successors>> first instructions>> ] unit-test
+
+! call then allot then call then allot
+V{
+ T{ ##prologue }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##allot f 1 64 byte-array }
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##allot f 2 64 byte-array }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##epilogue }
+ T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+2 \ vreg-counter set-global
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[
+ V{
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##check-nursery-branch f 64 cc<= 3 4 }
+ }
+] [
+ 0 get
+ successors>> first
+ instructions>>
+] unit-test
+
+[
+ V{
+ T{ ##allot f 1 64 byte-array }
+ T{ ##alien-invoke f "malloc" f T{ gc-map } }
+ T{ ##check-nursery-branch f 64 cc<= 5 6 }
+ }
+] [
+ 0 get
+ successors>> first
+ successors>> first
+ instructions>>
+] unit-test
+
+[
+ V{
+ T{ ##allot f 2 64 byte-array }
+ T{ ##branch }
+ }
+] [
+ 0 get
+ successors>> first
+ successors>> first
+ successors>> first
+ instructions>>
+] unit-test
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators fry kernel layouts locals
-math make namespaces sequences cpu.architecture
+USING: accessors assocs combinators fry grouping kernel layouts
+locals math make namespaces sequences cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.utilities
compiler.cfg.comparisons
compiler.cfg.instructions
-compiler.cfg.predecessors
-compiler.cfg.liveness
-compiler.cfg.liveness.ssa
-compiler.cfg.stacks.uninitialized ;
+compiler.cfg.predecessors ;
IN: compiler.cfg.gc-checks
-<PRIVATE
-
! Garbage collection check insertion. This pass runs after
! representation selection, since it needs to know which vregs
! can contain tagged pointers.
+<PRIVATE
+
: insert-gc-check? ( bb -- ? )
dup kill-block?>>
[ drop f ] [ instructions>> [ ##allocation? ] any? ] if ;
: blocks-with-gc ( cfg -- bbs )
post-order [ insert-gc-check? ] filter ;
-! A GC check for bb consists of two new basic blocks, gc-check
-! and gc-call:
-!
-! gc-check
-! / \
-! | gc-call
-! \ /
-! bb
-
-! Any ##phi instructions at the start of bb are transplanted
-! into the gc-check block.
-
-: <gc-check> ( phis size -- bb )
- [ <basic-block> ] 2dip
- [
- [ % ]
- [
- cc<= int-rep next-vreg-rep int-rep next-vreg-rep
- ##check-nursery-branch
- ] bi*
- ] V{ } make >>instructions ;
-
-: scrubbed ( uninitialized-locs -- scrub-d scrub-r )
- [ ds-loc? ] partition [ [ n>> ] map ] bi@ ;
-
-: <gc-call> ( uninitialized-locs gc-roots -- bb )
- [ <basic-block> ] 2dip
- [ [ scrubbed ] dip ##gc-map ##call-gc ##branch ] V{ } make
- >>instructions t >>unlikely? ;
-
-:: insert-guard ( body check bb -- )
- bb predecessors>> check predecessors<<
- V{ bb body } check successors<<
-
- V{ check } body predecessors<<
- V{ bb } body successors<<
+GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
- V{ check body } bb predecessors<<
+:: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
+ seen-allocation? [ call-index , ] when
+ insn-index 1 + f ;
- check predecessors>> [ bb check update-successors ] each ;
+M: ##callback-inputs gc-check-offsets* gc-check-here ;
+M: ##phi gc-check-offsets* gc-check-here ;
+M: gc-map-insn gc-check-offsets* gc-check-here ;
+M: ##allocation gc-check-offsets* 3drop t ;
+M: insn gc-check-offsets* 2drop ;
-: (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
- [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
+: gc-check-offsets ( insns -- seq )
+ ! A basic block is divided into sections by call and phi
+ ! instructions. For every section with at least one
+ ! allocation, record the offset of its first instruction
+ ! in a sequence.
+ [
+ [ 0 f ] dip
+ [ gc-check-offsets* ] each-index
+ [ , ] [ drop ] if
+ ] { } make ;
+
+:: split-instructions ( insns seq -- insns-seq )
+ ! Divide a basic block into sections, where every section
+ ! other than the first requires a GC check.
+ [
+ insns 0 seq [| insns from to |
+ from to insns subseq ,
+ insns to
+ ] each
+ tail ,
+ ] { } make ;
GENERIC: allocation-size* ( insn -- n )
M: ##allot allocation-size* size>> ;
-
M: ##box-alien allocation-size* drop 5 cells ;
-
M: ##box-displaced-alien allocation-size* drop 5 cells ;
-: allocation-size ( bb -- n )
- instructions>>
+: allocation-size ( insns -- n )
[ ##allocation? ] filter
[ allocation-size* data-alignment get align ] map-sum ;
-: gc-live-in ( bb -- vregs )
- [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
- append ;
-
-: live-tagged ( bb -- vregs )
- gc-live-in [ rep-of tagged-rep? ] filter ;
-
-: remove-phis ( bb -- phis )
- [ [ ##phi? ] partition ] change-instructions drop ;
+: add-gc-checks ( insns-seq -- )
+ ! Insert a GC check at the end of every chunk but the last
+ ! one. This ensures that every section other than the first
+ ! has a GC check in the section immediately preceeding it.
+ 2 <clumps> [
+ first2 allocation-size
+ cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+ \ ##check-nursery-branch new-insn
+ swap push
+ ] each ;
+
+: make-blocks ( insns-seq -- bbs )
+ [ <basic-block> swap >>instructions ] map ;
+
+: <gc-call> ( -- bb )
+ <basic-block>
+ [ <gc-map> ##call-gc ##branch ] V{ } make
+ >>instructions t >>unlikely? ;
-: insert-gc-check ( bb -- )
- {
- [ uninitialized-locs ]
- [ live-tagged ]
- [ remove-phis ]
- [ allocation-size ]
- [ ]
- } cleave
- (insert-gc-check) ;
+:: connect-gc-checks ( bbs -- )
+ ! Every basic block but the last has two successors:
+ ! the next block, and a GC call.
+ ! Every basic block but the first has two predecessors:
+ ! the previous block, and the previous block's GC call.
+ bbs length 1 - :> len
+ len [ <gc-call> ] replicate :> gc-calls
+ len [| n |
+ n bbs nth :> bb
+ n 1 + bbs nth :> next-bb
+ n gc-calls nth :> gc-call
+ V{ next-bb gc-call } bb successors<<
+ V{ next-bb } gc-call successors<<
+ V{ bb } gc-call predecessors<<
+ V{ bb gc-call } next-bb predecessors<<
+ ] each-integer ;
+
+:: update-predecessor-phis ( from to bb -- )
+ to [
+ [
+ [
+ [ dup from eq? [ drop bb ] when ] dip
+ ] assoc-map
+ ] change-inputs drop
+ ] each-phi ;
+
+:: (insert-gc-checks) ( bb bbs -- )
+ bb predecessors>> bbs first predecessors<<
+ bb successors>> bbs last successors<<
+ bb predecessors>> [ bb bbs first update-successors ] each
+ bb successors>> [
+ [ bb ] dip bbs last
+ [ update-predecessors ]
+ [ update-predecessor-phis ] 3bi
+ ] each ;
+
+: process-block ( bb -- )
+ dup instructions>> dup gc-check-offsets split-instructions
+ [ add-gc-checks ] [ make-blocks dup connect-gc-checks ] bi
+ (insert-gc-checks) ;
PRIVATE>
: insert-gc-checks ( cfg -- cfg' )
dup blocks-with-gc [
- [
- needs-predecessors
- dup compute-ssa-live-sets
- dup compute-uninitialized-sets
- ] dip
- [ insert-gc-check ] each
+ [ needs-predecessors ] dip
+ [ process-block ] each
cfg-changed
] unless-empty ;
PRIVATE>
insn-classes get [
- dup [ insn-def-slot ] [ name>> "##" head? ] bi and
+ dup [ insn-def-slots length 1 = ] [ name>> "##" head? ] bi and
[ define-hat ] [ drop ] if
] each
--- /dev/null
+USING: compiler.cfg.height compiler.cfg.instructions\r
+compiler.cfg.registers tools.test ;\r
+IN: compiler.cfg.height.tests\r
+\r
+[\r
+ V{\r
+ T{ ##inc-r f -1 f }\r
+ T{ ##inc-d f 4 f }\r
+ T{ ##peek f 0 D 4 f }\r
+ T{ ##peek f 1 D 0 f }\r
+ T{ ##replace f 0 R -1 f }\r
+ T{ ##replace f 1 R 0 f }\r
+ T{ ##peek f 2 D 0 f }\r
+ }\r
+] [\r
+ V{\r
+ T{ ##peek f 0 D 0 }\r
+ T{ ##inc-d f 3 }\r
+ T{ ##peek f 1 D -1 }\r
+ T{ ##replace f 0 R 0 }\r
+ T{ ##inc-r f -1 }\r
+ T{ ##replace f 1 R 0 }\r
+ T{ ##inc-d f 1 }\r
+ T{ ##peek f 2 D 0 }\r
+ } height-step\r
+] unit-test\r
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math namespaces sequences kernel fry
compiler.cfg compiler.cfg.registers compiler.cfg.instructions
SYMBOL: ds-height
SYMBOL: rs-height
-GENERIC: compute-heights ( insn -- )
-
-M: ##inc-d compute-heights n>> ds-height [ + ] change ;
-M: ##inc-r compute-heights n>> rs-height [ + ] change ;
-M: insn compute-heights drop ;
+: init-height ( -- )
+ 0 ds-height set
+ 0 rs-height set ;
-GENERIC: normalize-height* ( insn -- insn' )
+GENERIC: visit-insn ( insn -- )
-: normalize-inc-d/r ( insn stack -- insn' )
- swap n>> '[ _ - ] change f ; inline
+: normalize-inc-d/r ( insn stack -- )
+ swap n>> '[ _ + ] change ; inline
-M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
-M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
+M: ##inc-d visit-insn ds-height normalize-inc-d/r ;
+M: ##inc-r visit-insn rs-height normalize-inc-d/r ;
GENERIC: loc-stack ( loc -- stack )
M: ds-loc <loc> drop <ds-loc> ;
M: rs-loc <loc> drop <rs-loc> ;
-: normalize-peek/replace ( insn -- insn' )
- [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
+: normalize-peek/replace ( insn -- )
+ [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc
+ drop ; inline
-M: ##peek normalize-height* normalize-peek/replace ;
-M: ##replace normalize-height* normalize-peek/replace ;
+M: ##peek visit-insn normalize-peek/replace ;
+M: ##replace visit-insn normalize-peek/replace ;
-M: insn normalize-height* ;
+M: insn visit-insn drop ;
: height-step ( insns -- insns' )
- 0 ds-height set
- 0 rs-height set
- [ [ compute-heights ] each ]
- [ [ [ normalize-height* ] map sift ] with-scope ] bi
- ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
- rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
+ init-height
+ [ <reversed> [ visit-insn ] each ]
+ [
+ [ [ ##inc-d? ] [ ##inc-r? ] bi or not ] filter!
+ ds-height get [ \ ##inc-d new-insn prefix ] unless-zero
+ rs-height get [ \ ##inc-r new-insn prefix ] unless-zero
+ ] bi ;
: normalize-height ( cfg -- cfg' )
dup [ height-step ] simple-optimization ;
! Instructions which use vregs
TUPLE: vreg-insn < insn ;
+! Instructions which do not have side effects; used for
+! dead code elimination
+TUPLE: flushable-insn < vreg-insn ;
+
! Instructions which are referentially transparent; used for
! value numbering
-TUPLE: pure-insn < vreg-insn ;
+TUPLE: foldable-insn < flushable-insn ;
! Constants
-INSN: ##load-integer
+FOLDABLE-INSN: ##load-integer
def: dst/int-rep
literal: val ;
-INSN: ##load-reference
+FOLDABLE-INSN: ##load-reference
def: dst/tagged-rep
literal: obj ;
-! These three are inserted by representation selection
-INSN: ##load-tagged
+! These four are inserted by representation selection
+FLUSHABLE-INSN: ##load-tagged
def: dst/tagged-rep
literal: val ;
-INSN: ##load-float
+FLUSHABLE-INSN: ##load-float
def: dst/float-rep
literal: val ;
-INSN: ##load-double
+FLUSHABLE-INSN: ##load-double
def: dst/double-rep
literal: val ;
-INSN: ##load-vector
+FLUSHABLE-INSN: ##load-vector
def: dst
literal: val rep ;
! Stack operations
-INSN: ##peek
+FLUSHABLE-INSN: ##peek
def: dst/tagged-rep
literal: loc ;
-INSN: ##replace
+VREG-INSN: ##replace
use: src/tagged-rep
literal: loc ;
INSN: ##no-tco ;
! Jump tables
-INSN: ##dispatch
+VREG-INSN: ##dispatch
use: src/int-rep
temp: temp/int-rep ;
! Slot access
-INSN: ##slot
+FLUSHABLE-INSN: ##slot
def: dst/tagged-rep
use: obj/tagged-rep slot/int-rep
literal: scale tag ;
-INSN: ##slot-imm
+FLUSHABLE-INSN: ##slot-imm
def: dst/tagged-rep
use: obj/tagged-rep
literal: slot tag ;
-INSN: ##set-slot
+VREG-INSN: ##set-slot
use: src/tagged-rep obj/tagged-rep slot/int-rep
literal: scale tag ;
-INSN: ##set-slot-imm
+VREG-INSN: ##set-slot-imm
use: src/tagged-rep obj/tagged-rep
literal: slot tag ;
! Register transfers
-INSN: ##copy
+FOLDABLE-INSN: ##copy
def: dst
use: src
literal: rep ;
-PURE-INSN: ##tagged>integer
+FOLDABLE-INSN: ##tagged>integer
def: dst/int-rep
use: src/tagged-rep ;
! Integer arithmetic
-PURE-INSN: ##add
+FOLDABLE-INSN: ##add
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##add-imm
+FOLDABLE-INSN: ##add-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##sub
+FOLDABLE-INSN: ##sub
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##sub-imm
+FOLDABLE-INSN: ##sub-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##mul
+FOLDABLE-INSN: ##mul
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##mul-imm
+FOLDABLE-INSN: ##mul-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##and
+FOLDABLE-INSN: ##and
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##and-imm
+FOLDABLE-INSN: ##and-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##or
+FOLDABLE-INSN: ##or
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##or-imm
+FOLDABLE-INSN: ##or-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##xor
+FOLDABLE-INSN: ##xor
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##xor-imm
+FOLDABLE-INSN: ##xor-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##shl
+FOLDABLE-INSN: ##shl
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##shl-imm
+FOLDABLE-INSN: ##shl-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##shr
+FOLDABLE-INSN: ##shr
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##shr-imm
+FOLDABLE-INSN: ##shr-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##sar
+FOLDABLE-INSN: ##sar
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##sar-imm
+FOLDABLE-INSN: ##sar-imm
def: dst/int-rep
use: src1/int-rep
literal: src2 ;
-PURE-INSN: ##min
+FOLDABLE-INSN: ##min
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##max
+FOLDABLE-INSN: ##max
def: dst/int-rep
use: src1/int-rep src2/int-rep ;
-PURE-INSN: ##not
+FOLDABLE-INSN: ##not
def: dst/int-rep
use: src/int-rep ;
-PURE-INSN: ##neg
+FOLDABLE-INSN: ##neg
def: dst/int-rep
use: src/int-rep ;
-PURE-INSN: ##log2
+FOLDABLE-INSN: ##log2
def: dst/int-rep
use: src/int-rep ;
-PURE-INSN: ##bit-count
+FOLDABLE-INSN: ##bit-count
def: dst/int-rep
use: src/int-rep ;
! Float arithmetic
-PURE-INSN: ##add-float
+FOLDABLE-INSN: ##add-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##sub-float
+FOLDABLE-INSN: ##sub-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##mul-float
+FOLDABLE-INSN: ##mul-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##div-float
+FOLDABLE-INSN: ##div-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##min-float
+FOLDABLE-INSN: ##min-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##max-float
+FOLDABLE-INSN: ##max-float
def: dst/double-rep
use: src1/double-rep src2/double-rep ;
-PURE-INSN: ##sqrt
+FOLDABLE-INSN: ##sqrt
def: dst/double-rep
use: src/double-rep ;
! libc intrinsics
-PURE-INSN: ##unary-float-function
+FOLDABLE-INSN: ##unary-float-function
def: dst/double-rep
use: src/double-rep
literal: func ;
-PURE-INSN: ##binary-float-function
+FOLDABLE-INSN: ##binary-float-function
def: dst/double-rep
use: src1/double-rep src2/double-rep
literal: func ;
! Single/double float conversion
-PURE-INSN: ##single>double-float
+FOLDABLE-INSN: ##single>double-float
def: dst/double-rep
use: src/float-rep ;
-PURE-INSN: ##double>single-float
+FOLDABLE-INSN: ##double>single-float
def: dst/float-rep
use: src/double-rep ;
! Float/integer conversion
-PURE-INSN: ##float>integer
+FOLDABLE-INSN: ##float>integer
def: dst/int-rep
use: src/double-rep ;
-PURE-INSN: ##integer>float
+FOLDABLE-INSN: ##integer>float
def: dst/double-rep
use: src/int-rep ;
! SIMD operations
-PURE-INSN: ##zero-vector
+FOLDABLE-INSN: ##zero-vector
def: dst
literal: rep ;
-PURE-INSN: ##fill-vector
+FOLDABLE-INSN: ##fill-vector
def: dst
literal: rep ;
-PURE-INSN: ##gather-vector-2
+FOLDABLE-INSN: ##gather-vector-2
def: dst
use: src1/scalar-rep src2/scalar-rep
literal: rep ;
-PURE-INSN: ##gather-int-vector-2
+FOLDABLE-INSN: ##gather-int-vector-2
def: dst
use: src1/int-rep src2/int-rep
literal: rep ;
-PURE-INSN: ##gather-vector-4
+FOLDABLE-INSN: ##gather-vector-4
def: dst
use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep
literal: rep ;
-PURE-INSN: ##gather-int-vector-4
+FOLDABLE-INSN: ##gather-int-vector-4
def: dst
use: src1/int-rep src2/int-rep src3/int-rep src4/int-rep
literal: rep ;
-PURE-INSN: ##select-vector
+FOLDABLE-INSN: ##select-vector
def: dst/int-rep
use: src
literal: n rep ;
-PURE-INSN: ##shuffle-vector
+FOLDABLE-INSN: ##shuffle-vector
def: dst
use: src shuffle
literal: rep ;
-PURE-INSN: ##shuffle-vector-halves-imm
+FOLDABLE-INSN: ##shuffle-vector-halves-imm
def: dst
use: src1 src2
literal: shuffle rep ;
-PURE-INSN: ##shuffle-vector-imm
+FOLDABLE-INSN: ##shuffle-vector-imm
def: dst
use: src
literal: shuffle rep ;
-PURE-INSN: ##tail>head-vector
+FOLDABLE-INSN: ##tail>head-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##merge-vector-head
+FOLDABLE-INSN: ##merge-vector-head
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##merge-vector-tail
+FOLDABLE-INSN: ##merge-vector-tail
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##float-pack-vector
+FOLDABLE-INSN: ##float-pack-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##signed-pack-vector
+FOLDABLE-INSN: ##signed-pack-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##unsigned-pack-vector
+FOLDABLE-INSN: ##unsigned-pack-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##unpack-vector-head
+FOLDABLE-INSN: ##unpack-vector-head
def: dst
use: src
literal: rep ;
-PURE-INSN: ##unpack-vector-tail
+FOLDABLE-INSN: ##unpack-vector-tail
def: dst
use: src
literal: rep ;
-PURE-INSN: ##integer>float-vector
+FOLDABLE-INSN: ##integer>float-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##float>integer-vector
+FOLDABLE-INSN: ##float>integer-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##compare-vector
+FOLDABLE-INSN: ##compare-vector
def: dst
use: src1 src2
literal: rep cc ;
-PURE-INSN: ##test-vector
+FOLDABLE-INSN: ##test-vector
def: dst/tagged-rep
use: src1
temp: temp/int-rep
literal: rep vcc ;
-INSN: ##test-vector-branch
+VREG-INSN: ##test-vector-branch
use: src1
temp: temp/int-rep
literal: rep vcc ;
-PURE-INSN: ##add-vector
+FOLDABLE-INSN: ##add-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##saturated-add-vector
+FOLDABLE-INSN: ##saturated-add-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##add-sub-vector
+FOLDABLE-INSN: ##add-sub-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##sub-vector
+FOLDABLE-INSN: ##sub-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##saturated-sub-vector
+FOLDABLE-INSN: ##saturated-sub-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##mul-vector
+FOLDABLE-INSN: ##mul-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##mul-high-vector
+FOLDABLE-INSN: ##mul-high-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##mul-horizontal-add-vector
+FOLDABLE-INSN: ##mul-horizontal-add-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##saturated-mul-vector
+FOLDABLE-INSN: ##saturated-mul-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##div-vector
+FOLDABLE-INSN: ##div-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##min-vector
+FOLDABLE-INSN: ##min-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##max-vector
+FOLDABLE-INSN: ##max-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##avg-vector
+FOLDABLE-INSN: ##avg-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##dot-vector
+FOLDABLE-INSN: ##dot-vector
def: dst/scalar-rep
use: src1 src2
literal: rep ;
-PURE-INSN: ##sad-vector
+FOLDABLE-INSN: ##sad-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##horizontal-add-vector
+FOLDABLE-INSN: ##horizontal-add-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##horizontal-sub-vector
+FOLDABLE-INSN: ##horizontal-sub-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##horizontal-shl-vector-imm
+FOLDABLE-INSN: ##horizontal-shl-vector-imm
def: dst
use: src1
literal: src2 rep ;
-PURE-INSN: ##horizontal-shr-vector-imm
+FOLDABLE-INSN: ##horizontal-shr-vector-imm
def: dst
use: src1
literal: src2 rep ;
-PURE-INSN: ##abs-vector
+FOLDABLE-INSN: ##abs-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##sqrt-vector
+FOLDABLE-INSN: ##sqrt-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##and-vector
+FOLDABLE-INSN: ##and-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##andn-vector
+FOLDABLE-INSN: ##andn-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##or-vector
+FOLDABLE-INSN: ##or-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##xor-vector
+FOLDABLE-INSN: ##xor-vector
def: dst
use: src1 src2
literal: rep ;
-PURE-INSN: ##not-vector
+FOLDABLE-INSN: ##not-vector
def: dst
use: src
literal: rep ;
-PURE-INSN: ##shl-vector-imm
+FOLDABLE-INSN: ##shl-vector-imm
def: dst
use: src1
literal: src2 rep ;
-PURE-INSN: ##shr-vector-imm
+FOLDABLE-INSN: ##shr-vector-imm
def: dst
use: src1
literal: src2 rep ;
-PURE-INSN: ##shl-vector
+FOLDABLE-INSN: ##shl-vector
def: dst
use: src1 src2/int-scalar-rep
literal: rep ;
-PURE-INSN: ##shr-vector
+FOLDABLE-INSN: ##shr-vector
def: dst
use: src1 src2/int-scalar-rep
literal: rep ;
! Scalar/vector conversion
-PURE-INSN: ##scalar>integer
+FOLDABLE-INSN: ##scalar>integer
def: dst/int-rep
use: src
literal: rep ;
-PURE-INSN: ##integer>scalar
+FOLDABLE-INSN: ##integer>scalar
def: dst
use: src/int-rep
literal: rep ;
-PURE-INSN: ##vector>scalar
+FOLDABLE-INSN: ##vector>scalar
def: dst/scalar-rep
use: src
literal: rep ;
-PURE-INSN: ##scalar>vector
+FOLDABLE-INSN: ##scalar>vector
def: dst
use: src/scalar-rep
literal: rep ;
! Boxing and unboxing aliens
-PURE-INSN: ##box-alien
+FOLDABLE-INSN: ##box-alien
def: dst/tagged-rep
use: src/int-rep
temp: temp/int-rep ;
-PURE-INSN: ##box-displaced-alien
+FOLDABLE-INSN: ##box-displaced-alien
def: dst/tagged-rep
use: displacement/int-rep base/tagged-rep
temp: temp/int-rep
literal: base-class ;
-PURE-INSN: ##unbox-any-c-ptr
+FOLDABLE-INSN: ##unbox-any-c-ptr
def: dst/int-rep
use: src/tagged-rep ;
-PURE-INSN: ##unbox-alien
+FOLDABLE-INSN: ##unbox-alien
def: dst/int-rep
use: src/tagged-rep ;
! Raw memory accessors
-INSN: ##load-memory
+FLUSHABLE-INSN: ##load-memory
def: dst
use: base/int-rep displacement/int-rep
literal: scale offset rep c-type ;
-INSN: ##load-memory-imm
+FLUSHABLE-INSN: ##load-memory-imm
def: dst
use: base/int-rep
literal: offset rep c-type ;
-INSN: ##store-memory
+VREG-INSN: ##store-memory
use: src base/int-rep displacement/int-rep
literal: scale offset rep c-type ;
-INSN: ##store-memory-imm
+VREG-INSN: ##store-memory-imm
use: src base/int-rep
literal: offset rep c-type ;
! Memory allocation
-INSN: ##allot
+FLUSHABLE-INSN: ##allot
def: dst/tagged-rep
literal: size class
temp: temp/int-rep ;
-INSN: ##write-barrier
+VREG-INSN: ##write-barrier
use: src/tagged-rep slot/int-rep
literal: scale tag
temp: temp1/int-rep temp2/int-rep ;
-INSN: ##write-barrier-imm
+VREG-INSN: ##write-barrier-imm
use: src/tagged-rep
literal: slot tag
temp: temp1/int-rep temp2/int-rep ;
-INSN: ##alien-global
+FLUSHABLE-INSN: ##alien-global
def: dst/int-rep
literal: symbol library ;
-INSN: ##vm-field
+FLUSHABLE-INSN: ##vm-field
def: dst/tagged-rep
literal: offset ;
-INSN: ##set-vm-field
+VREG-INSN: ##set-vm-field
use: src/tagged-rep
literal: offset ;
! FFI
-INSN: ##stack-frame
-literal: stack-frame ;
-
-INSN: ##unbox
+FOLDABLE-INSN: ##unbox
def: dst
use: src/tagged-rep
literal: unboxer rep ;
-INSN: ##unbox-long-long
-use: src/tagged-rep out/int-rep
+FOLDABLE-INSN: ##unbox-long-long
+def: dst1/int-rep dst2/int-rep
+use: src/tagged-rep
literal: unboxer ;
-INSN: ##store-reg-param
-use: src
-literal: reg rep ;
-
-INSN: ##store-stack-param
-use: src
-literal: n rep ;
-
-INSN: ##load-reg-param
-def: dst
-literal: reg rep ;
-
-INSN: ##load-stack-param
-def: dst
-literal: n rep ;
-
-INSN: ##local-allot
+FLUSHABLE-INSN: ##local-allot
def: dst/int-rep
literal: size align offset ;
-INSN: ##box
+FOLDABLE-INSN: ##box
def: dst/tagged-rep
use: src
-literal: boxer rep ;
+literal: boxer rep gc-map ;
-INSN: ##box-long-long
+FOLDABLE-INSN: ##box-long-long
def: dst/tagged-rep
use: src1/int-rep src2/int-rep
-literal: boxer ;
-
-INSN: ##allot-byte-array
-def: dst/tagged-rep
-literal: size ;
+literal: boxer gc-map ;
-INSN: ##prepare-var-args ;
+! Alien call inputs and outputs are arrays of triples with shape
+! { vreg rep stack#/reg }
-INSN: ##alien-invoke
-literal: symbols dll ;
+VREG-INSN: ##alien-invoke
+literal: reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map ;
-INSN: ##cleanup
-literal: n ;
-
-INSN: ##alien-indirect
-use: src/int-rep ;
+VREG-INSN: ##alien-indirect
+use: src/int-rep
+literal: reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map ;
-INSN: ##alien-assembly
-literal: quot ;
+VREG-INSN: ##alien-assembly
+literal: reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map ;
-INSN: ##begin-callback ;
+VREG-INSN: ##callback-inputs
+literal: reg-outputs stack-outputs ;
INSN: ##alien-callback
literal: quot ;
-INSN: ##end-callback ;
+VREG-INSN: ##callback-outputs
+literal: reg-inputs ;
! Control flow
-INSN: ##phi
+FLUSHABLE-INSN: ##phi
def: dst
literal: inputs ;
INSN: ##branch ;
! Tagged conditionals
-INSN: ##compare-branch
+VREG-INSN: ##compare-branch
use: src1/tagged-rep src2/tagged-rep
literal: cc ;
-INSN: ##compare-imm-branch
+VREG-INSN: ##compare-imm-branch
use: src1/tagged-rep
literal: src2 cc ;
-PURE-INSN: ##compare
+FOLDABLE-INSN: ##compare
def: dst/tagged-rep
use: src1/tagged-rep src2/tagged-rep
literal: cc
temp: temp/int-rep ;
-PURE-INSN: ##compare-imm
+FOLDABLE-INSN: ##compare-imm
def: dst/tagged-rep
use: src1/tagged-rep
literal: src2 cc
temp: temp/int-rep ;
! Integer conditionals
-INSN: ##compare-integer-branch
+VREG-INSN: ##compare-integer-branch
use: src1/int-rep src2/int-rep
literal: cc ;
-INSN: ##compare-integer-imm-branch
+VREG-INSN: ##compare-integer-imm-branch
use: src1/int-rep
literal: src2 cc ;
-INSN: ##test-branch
+VREG-INSN: ##test-branch
use: src1/int-rep src2/int-rep
literal: cc ;
-INSN: ##test-imm-branch
+VREG-INSN: ##test-imm-branch
use: src1/int-rep
literal: src2 cc ;
-PURE-INSN: ##compare-integer
+FOLDABLE-INSN: ##compare-integer
def: dst/tagged-rep
use: src1/int-rep src2/int-rep
literal: cc
temp: temp/int-rep ;
-PURE-INSN: ##compare-integer-imm
+FOLDABLE-INSN: ##compare-integer-imm
def: dst/tagged-rep
use: src1/int-rep
literal: src2 cc
temp: temp/int-rep ;
-PURE-INSN: ##test
+FOLDABLE-INSN: ##test
def: dst/tagged-rep
use: src1/int-rep src2/int-rep
literal: cc
temp: temp/int-rep ;
-PURE-INSN: ##test-imm
+FOLDABLE-INSN: ##test-imm
def: dst/tagged-rep
use: src1/int-rep
literal: src2 cc
temp: temp/int-rep ;
! Float conditionals
-INSN: ##compare-float-ordered-branch
+VREG-INSN: ##compare-float-ordered-branch
use: src1/double-rep src2/double-rep
literal: cc ;
-INSN: ##compare-float-unordered-branch
+VREG-INSN: ##compare-float-unordered-branch
use: src1/double-rep src2/double-rep
literal: cc ;
-PURE-INSN: ##compare-float-ordered
+FOLDABLE-INSN: ##compare-float-ordered
def: dst/tagged-rep
use: src1/double-rep src2/double-rep
literal: cc
temp: temp/int-rep ;
-PURE-INSN: ##compare-float-unordered
+FOLDABLE-INSN: ##compare-float-unordered
def: dst/tagged-rep
use: src1/double-rep src2/double-rep
literal: cc
temp: temp/int-rep ;
! Overflowing arithmetic
-INSN: ##fixnum-add
+VREG-INSN: ##fixnum-add
def: dst/tagged-rep
use: src1/tagged-rep src2/tagged-rep
literal: cc ;
-INSN: ##fixnum-sub
+VREG-INSN: ##fixnum-sub
def: dst/tagged-rep
use: src1/tagged-rep src2/tagged-rep
literal: cc ;
-INSN: ##fixnum-mul
+VREG-INSN: ##fixnum-mul
def: dst/tagged-rep
use: src1/tagged-rep src2/int-rep
literal: cc ;
-INSN: ##save-context
-temp: temp1/int-rep temp2/int-rep ;
-
-INSN: ##restore-context
+VREG-INSN: ##save-context
temp: temp1/int-rep temp2/int-rep ;
! GC checks
-INSN: ##check-nursery-branch
+VREG-INSN: ##check-nursery-branch
literal: size cc
temp: temp1/int-rep temp2/int-rep ;
-INSN: ##call-gc ;
-
-INSN: ##gc-map
-literal: scrub-d scrub-r gc-roots ;
+INSN: ##call-gc
+literal: gc-map ;
! Spills and reloads, inserted by register allocator
TUPLE: spill-slot { n integer } ;
C: <spill-slot> spill-slot
-INSN: ##spill
+VREG-INSN: ##spill
use: src
literal: rep dst ;
-INSN: ##reload
+VREG-INSN: ##reload
def: dst
literal: rep src ;
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
+! Instructions that contain subroutine calls to functions which
+! can callback arbitrary Factor code
+UNION: factor-call-insn
+##alien-invoke
+##alien-indirect
+##alien-assembly ;
+
+! Instructions that contain subroutine calls to functions which
+! allocate memory
+UNION: gc-map-insn
+##call-gc
+##box
+##box-long-long
+factor-call-insn ;
+
+M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;
+
+! Each one has a gc-map slot
+TUPLE: gc-map scrub-d scrub-r gc-roots ;
+
+: <gc-map> ( -- gc-map ) gc-map new ;
+
+UNION: alien-call-insn
+##alien-invoke
+##alien-indirect
+##alien-assembly ;
+
! Instructions that clobber registers. They receive inputs and
! produce outputs in spill slots.
UNION: hairy-clobber-insn
-##load-reg-param
-##store-reg-param
##call-gc
-##alien-invoke
-##alien-indirect
-##alien-assembly
-##begin-callback
-##end-callback ;
+alien-call-insn
+##callback-inputs
+##callback-outputs
+##unbox-long-long ;
! Instructions that clobber registers but are allowed to produce
! outputs in registers. Inputs are in spill slots, except for
##unary-float-function
##binary-float-function
##unbox
-##unbox-long-long
##box
-##box-long-long
-##allot-byte-array ;
+##box-long-long ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
] reduce drop
] { } make ;
-: find-def-slot ( slots -- slot/f )
- [ type>> def eq? ] find nip ;
-
-: insn-def-slot ( class -- slot/f )
- "insn-slots" word-prop find-def-slot ;
+: insn-def-slots ( class -- slot/f )
+ "insn-slots" word-prop [ type>> def eq? ] filter ;
: insn-use-slots ( class -- slots )
"insn-slots" word-prop [ type>> use eq? ] filter ;
: vreg-insn-word ( -- word )
"vreg-insn" "compiler.cfg.instructions" lookup ;
-: pure-insn-word ( -- word )
- "pure-insn" "compiler.cfg.instructions" lookup ;
+: flushable-insn-word ( -- word )
+ "flushable-insn" "compiler.cfg.instructions" lookup ;
+
+: foldable-insn-word ( -- word )
+ "foldable-insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
boa-effect in>> but-last { } <effect> ;
: uses-vregs? ( specs -- ? )
[ type>> { def use temp } member-eq? ] any? ;
-: insn-superclass ( pure? specs -- superclass )
- pure-insn-word swap uses-vregs? vreg-insn-word insn-word ? ? ;
-
-: define-insn-tuple ( class pure? specs -- )
- [ insn-superclass ] keep
+: define-insn-tuple ( class superclass specs -- )
[ name>> ] map "insn#" suffix define-tuple-class ;
: define-insn-ctor ( class specs -- )
[ dup '[ _ ] [ f ] [ boa , ] surround ] dip
[ name>> ] map { } <effect> define-declared ;
-: define-insn ( class pure? specs -- )
+: define-insn ( class superclass specs -- )
parse-insn-slot-specs
{
[ nip "insn-slots" set-word-prop ]
[ nip define-insn-ctor ]
} 3cleave ;
-SYNTAX: INSN: CREATE-CLASS f ";" parse-tokens define-insn ;
+SYNTAX: INSN:
+ CREATE-CLASS insn-word ";" parse-tokens define-insn ;
+
+SYNTAX: VREG-INSN:
+ CREATE-CLASS vreg-insn-word ";" parse-tokens define-insn ;
+
+SYNTAX: FLUSHABLE-INSN:
+ CREATE-CLASS flushable-insn-word ";" parse-tokens define-insn ;
-SYNTAX: PURE-INSN: CREATE-CLASS t ";" parse-tokens define-insn ;
+SYNTAX: FOLDABLE-INSN:
+ CREATE-CLASS foldable-insn-word ";" parse-tokens define-insn ;
: bytes>cells ( m -- n ) cell align cell /i ;
-: ^^allot-byte-array ( n -- dst )
- 16 + byte-array ^^allot ;
+: ^^allot-byte-array ( len -- dst )
+ dup 16 + byte-array ^^allot [ byte-array store-length ] keep ;
: emit-allot-byte-array ( len -- dst )
- ds-drop
- dup ^^allot-byte-array
- [ byte-array store-length ] [ ds-push ] [ ] tri ;
+ ds-drop ^^allot-byte-array dup ds-push ;
: emit-(byte-array) ( node -- )
dup node-input-infos first literal>> dup expand-(byte-array)?
2dup spill-at-sync-point?
[ swap n>> spill f ] [ 2drop t ] if ;
-GENERIC: handle-progress* ( obj -- )
+: handle-interval ( live-interval -- )
+ [ start>> deactivate-intervals ]
+ [ start>> activate-intervals ]
+ [ assign-register ]
+ tri ;
-M: live-interval handle-progress* drop ;
-
-M: sync-point handle-progress*
+: (handle-sync-point) ( sync-point -- )
active-intervals get values
[ [ spill-at-sync-point ] with filter! drop ] with each ;
-:: handle-progress ( n obj -- )
- n progress set
- n deactivate-intervals
- obj handle-progress*
- n activate-intervals ;
-
-GENERIC: handle ( obj -- )
-
-M: live-interval handle ( live-interval -- )
- [ [ start>> ] keep handle-progress ] [ assign-register ] bi ;
-
-M: sync-point handle ( sync-point -- )
- [ n>> ] keep handle-progress ;
+: handle-sync-point ( sync-point -- )
+ [ n>> deactivate-intervals ]
+ [ (handle-sync-point) ]
+ [ n>> activate-intervals ]
+ tri ;
-: smallest-heap ( heap1 heap2 -- heap )
- ! If heap1 and heap2 have the same key, favors heap1.
+:: (allocate-registers-step) ( unhandled-intervals unhandled-sync-points -- )
{
- { [ dup heap-empty? ] [ drop ] }
- { [ over heap-empty? ] [ nip ] }
- [ [ [ heap-peek nip ] bi@ <= ] most ]
+ {
+ [ unhandled-intervals heap-empty? ]
+ [ unhandled-sync-points heap-pop drop handle-sync-point ]
+ }
+ {
+ [ unhandled-sync-points heap-empty? ]
+ [ unhandled-intervals heap-pop drop handle-interval ]
+ }
+ [
+ unhandled-intervals heap-peek :> ( i ik )
+ unhandled-sync-points heap-peek :> ( s sk )
+ {
+ {
+ [ ik sk < ]
+ [ unhandled-intervals heap-pop* i handle-interval ]
+ }
+ {
+ [ ik sk > ]
+ [ unhandled-sync-points heap-pop* s handle-sync-point ]
+ }
+ [
+ unhandled-intervals heap-pop*
+ i handle-interval
+ s (handle-sync-point)
+ ]
+ } cond
+ ]
} cond ;
-: (allocate-registers) ( -- )
- unhandled-intervals get unhandled-sync-points get smallest-heap
- dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
+: (allocate-registers) ( unhandled-intervals unhandled-sync-points -- )
+ 2dup [ heap-empty? ] both? [ 2drop ] [
+ [ (allocate-registers-step) ]
+ [ (allocate-registers) ]
+ 2bi
+ ] if ;
: finish-allocation ( -- )
active-intervals inactive-intervals
: allocate-registers ( live-intervals sync-point machine-registers -- live-intervals )
init-allocator
init-unhandled
- (allocate-registers)
+ unhandled-intervals get unhandled-sync-points get (allocate-registers)
finish-allocation
handled-intervals get ;
! Any active intervals which have ended are moved to handled
! Any active intervals which cover the current position
! are moved to inactive
+ dup progress set
active-intervals {
{ [ 2dup finished? ] [ finish ] }
{ [ 2dup covers? not ] [ deactivate ] }
M: vreg-insn assign-registers-in-insn
[ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
-M: ##gc-map assign-registers-in-insn
- [ [ vreg>reg ] map ] change-gc-roots drop ;
+M: gc-map-insn assign-registers-in-insn
+ [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
+ [ gc-map>> [ [ vreg>reg ] map ] change-gc-roots drop ]
+ bi ;
M: insn assign-registers-in-insn drop ;
compiler.cfg.debugger
compiler.cfg.def-use
compiler.cfg.comparisons
+compiler.cfg.ssa.destruction
compiler.cfg.linear-scan
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
check-allocation? on
check-numbering? on
+! Live interval calculation
+
+! A value is defined and never used; make sure it has the right
+! live range
+V{
+ T{ ##load-integer f 1 0 }
+ T{ ##replace-imm f D 0 "hi" }
+ T{ ##branch }
+} 0 test-bb
+
+: test-live-intervals ( -- )
+ cfg new 0 get >>entry
+ [ cfg set ] [ number-instructions ] [ compute-live-intervals ] tri
+ 2drop ;
+
+[ ] [
+ H{
+ { 1 int-rep }
+ } representations set
+ H{
+ { 1 1 }
+ } leader-map set
+ test-live-intervals
+] unit-test
+
+[ 0 0 ] [
+ 1 live-intervals get at [ start>> ] [ end>> ] bi
+] unit-test
+
+! Live range and interval splitting
[
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
{ T{ live-range f 16 20 } }
covers?
] if ;
+: (find-use) ( insn# live-interval -- vreg-use )
+ uses>> [ n>> <=> ] with search nip ;
+
:: find-use ( insn# live-interval -- vreg-use )
- insn# live-interval uses>> [ n>> <=> ] with search nip
+ insn# live-interval (find-use)
dup [ dup n>> insn# = [ drop f ] unless ] when ;
: add-new-range ( from to live-interval -- )
M: vreg-insn compute-live-intervals* ( insn -- )
dup insn#>>
- [ [ defs-vreg ] dip '[ _ record-def ] when* ]
+ [ [ defs-vregs ] dip '[ _ record-def ] each ]
[ [ uses-vregs ] dip '[ _ record-use ] each ]
[ [ temp-vregs ] dip '[ _ record-temp ] each ]
2tri ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs sequences sets
+USING: kernel accessors assocs namespaces sequences sets
compiler.cfg.def-use compiler.cfg.dataflow-analysis
-compiler.cfg.instructions ;
+compiler.cfg.instructions compiler.cfg.registers
+cpu.architecture ;
IN: compiler.cfg.liveness
! See http://en.wikipedia.org/wiki/Liveness_analysis
-! Do not run after SSA construction
+! Do not run after SSA construction; compiler.cfg.liveness.ssa
+! should be used instead. The transfer-liveness word is used
+! by SSA liveness too, so it handles ##phi instructions.
BACKWARD-ANALYSIS: live
-GENERIC: insn-liveness ( live-set insn -- )
+GENERIC: visit-insn ( live-set insn -- live-set )
: kill-defs ( live-set insn -- live-set )
- defs-vreg [ over delete-at ] when* ;
+ defs-vregs [ over delete-at ] each ; inline
: gen-uses ( live-set insn -- live-set )
- dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ;
+ uses-vregs [ over conjoin ] each ; inline
+
+M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
+
+: fill-gc-map ( live-set insn -- live-set )
+ representations get [
+ gc-map>> over keys
+ [ rep-of tagged-rep? ] filter
+ >>gc-roots
+ ] when
+ drop ;
+
+M: gc-map-insn visit-insn
+ [ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;
+
+M: ##phi visit-insn kill-defs ;
+
+M: insn visit-insn drop ;
: transfer-liveness ( live-set instructions -- live-set' )
- [ clone ] [ <reversed> ] bi* [ [ kill-defs ] [ gen-uses ] bi ] each ;
+ [ clone ] [ <reversed> ] bi* [ visit-insn ] each ;
: local-live-in ( instructions -- live-set )
[ H{ } ] dip transfer-liveness keys ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry functors generic.parser
kernel lexer namespaces parser sequences slots words sets
M: insn rename-insn-defs drop ;
-insn-classes get [ insn-def-slot ] filter [
+insn-classes get special-vreg-insns diff [ insn-def-slots empty? not ] filter [
[ \ rename-insn-defs create-method-in ]
- [ insn-def-slot name>> 1array DEF-QUOT slot-change-quot ] bi
+ [ insn-def-slots [ name>> ] map DEF-QUOT slot-change-quot ] bi
define
] each
+M: ##phi rename-insn-defs DEF-QUOT change-dst drop ;
+
+M: alien-call-insn rename-insn-defs
+ [ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs drop ;
+
+M: ##callback-inputs rename-insn-defs
+ [ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs
+ [ [ first3 DEF-QUOT 2dip 3array ] map ] change-stack-outputs
+ drop ;
+
GENERIC: rename-insn-uses ( insn -- )
M: insn rename-insn-uses drop ;
-insn-classes get { ##phi } diff [ insn-use-slots empty? not ] filter [
+insn-classes get special-vreg-insns diff [ insn-use-slots empty? not ] filter [
[ \ rename-insn-uses create-method-in ]
[ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
define
] each
+M: alien-call-insn rename-insn-uses
+ [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs
+ [ [ first3 USE-QUOT 2dip 3array ] map ] change-stack-inputs
+ drop ;
+
+M: ##alien-indirect rename-insn-uses
+ USE-QUOT change-src call-next-method ;
+
+M: ##callback-outputs rename-insn-uses
+ [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs drop ;
+
M: ##phi rename-insn-uses
[ USE-QUOT assoc-map ] change-inputs drop ;
: init-components ( cfg components -- )
'[
instructions>> [
- defs-vreg [ _ add-atom ] when*
+ defs-vregs [ _ add-atom ] each
] each
] each-basic-block ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays fry namespaces generic
words sets combinators generalizations sequences.generalizations
cpu.architecture compiler.units compiler.cfg.utilities
compiler.cfg compiler.cfg.rpo compiler.cfg.instructions
compiler.cfg.def-use ;
-FROM: compiler.cfg.instructions.syntax => insn-def-slot insn-use-slots insn-temp-slots scalar-rep ;
+FROM: compiler.cfg.instructions.syntax => insn-def-slots
+insn-use-slots insn-temp-slots scalar-rep ;
FROM: namespaces => set ;
IN: compiler.cfg.representations.preferred
-GENERIC: defs-vreg-rep ( insn -- rep/f )
+GENERIC: defs-vreg-reps ( insn -- reps )
GENERIC: temp-vreg-reps ( insn -- reps )
GENERIC: uses-vreg-reps ( insn -- reps )
-M: insn defs-vreg-rep drop f ;
+M: insn defs-vreg-reps drop { } ;
M: insn temp-vreg-reps drop { } ;
M: insn uses-vreg-reps drop { } ;
[ [ drop ] swap suffix ]
} case ;
-: define-defs-vreg-rep-method ( insn -- )
- dup insn-def-slot dup [
- [ \ defs-vreg-rep create-method ]
- [ rep>> rep-getter-quot ]
- bi* define
- ] [ 2drop ] if ;
-
: reps-getter-quot ( reps -- quot )
dup [ rep>> { f scalar-rep } member-eq? not ] all? [
[ rep>> ] map [ drop ] swap suffix
} case
] if ;
-: define-uses-vreg-reps-method ( insn -- )
- dup insn-use-slots [ drop ] [
- [ \ uses-vreg-reps create-method ]
+: define-vreg-reps-method ( insn slots word -- )
+ [ [ drop ] ] dip '[
+ [ _ create-method ]
[ reps-getter-quot ]
bi* define
] if-empty ;
+: define-defs-vreg-reps-method ( insn -- )
+ dup insn-def-slots \ defs-vreg-reps define-vreg-reps-method ;
+
+: define-uses-vreg-reps-method ( insn -- )
+ dup insn-use-slots \ uses-vreg-reps define-vreg-reps-method ;
+
: define-temp-vreg-reps-method ( insn -- )
- dup insn-temp-slots [ drop ] [
- [ \ temp-vreg-reps create-method ]
- [ reps-getter-quot ]
- bi* define
- ] if-empty ;
+ dup insn-temp-slots \ temp-vreg-reps define-vreg-reps-method ;
PRIVATE>
+M: alien-call-insn defs-vreg-reps
+ reg-outputs>> [ second ] map ;
+
+M: ##callback-inputs defs-vreg-reps
+ [ reg-outputs>> ] [ stack-outputs>> ] bi append [ second ] map ;
+
+M: ##callback-outputs defs-vreg-reps drop { } ;
+
+M: alien-call-insn uses-vreg-reps
+ [ reg-inputs>> ] [ stack-inputs>> ] bi append [ second ] map ;
+
+M: ##alien-indirect uses-vreg-reps
+ call-next-method int-rep prefix ;
+
+M: ##callback-inputs uses-vreg-reps
+ drop { } ;
+
+M: ##callback-outputs uses-vreg-reps
+ reg-inputs>> [ second ] map ;
+
[
insn-classes get
- [ [ define-defs-vreg-rep-method ] each ]
- [ { ##phi } diff [ define-uses-vreg-reps-method ] each ]
+ [ special-vreg-insns diff [ define-defs-vreg-reps-method ] each ]
+ [ special-vreg-insns diff [ define-uses-vreg-reps-method ] each ]
[ [ define-temp-vreg-reps-method ] each ]
tri
] with-compilation-unit
: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
- [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
+ [ [ defs-vregs ] [ defs-vreg-reps ] bi ] dip 2each ; inline
: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
: each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline
-
-: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
- '[
- [ basic-block set ] [
- [
- _ each-rep
- ] each-non-phi
- ] bi
- ] each-basic-block ; inline
} uses-vreg-reps
] unit-test
-[ double-rep ] [
+[ { double-rep } ] [
T{ ##load-memory-imm
{ dst 5 }
{ base 3 }
{ offset 0 }
{ rep double-rep }
- } defs-vreg-rep
+ } defs-vreg-reps
] unit-test
H{ } clone representations set
USING: accessors compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.save-contexts kernel namespaces tools.test ;
+compiler.cfg.save-contexts kernel namespaces tools.test
+cpu.x86.assembler.operands cpu.architecture ;
IN: compiler.cfg.save-contexts.tests
0 vreg-counter set-global
] [
0 get instructions>>
] unit-test
+
+4 vreg-counter set-global
+
+V{
+ T{ ##inc-d f 3 }
+ T{ ##box f 4 3 "from_signed_4" int-rep
+ T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
+ }
+} 0 test-bb
+
+0 get insert-save-context
+
+[
+ V{
+ T{ ##inc-d f 3 }
+ T{ ##save-context f 5 6 }
+ T{ ##box f 4 3 "from_signed_4" int-rep
+ T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
+ }
+ }
+] [
+ 0 get instructions>>
+] unit-test
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit
-compiler.cfg.instructions compiler.cfg.registers
+USING: accessors compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.rpo cpu.architecture kernel sequences vectors ;
IN: compiler.cfg.save-contexts
! Insert context saves.
-: needs-save-context? ( insns -- ? )
- [
- {
- [ ##unary-float-function? ]
- [ ##binary-float-function? ]
- [ ##alien-invoke? ]
- [ ##alien-indirect? ]
- [ ##alien-assembly? ]
- } 1||
- ] any? ;
+GENERIC: needs-save-context? ( insn -- ? )
+
+M: ##unary-float-function needs-save-context? drop t ;
+M: ##binary-float-function needs-save-context? drop t ;
+M: gc-map-insn needs-save-context? drop t ;
+M: insn needs-save-context? drop f ;
+
+: bb-needs-save-context? ( insn -- ? )
+ instructions>> [ needs-save-context? ] any? ;
+
+GENERIC: modifies-context? ( insn -- ? )
+
+M: ##inc-d modifies-context? drop t ;
+M: ##inc-r modifies-context? drop t ;
+M: ##callback-inputs modifies-context? drop t ;
+M: insn modifies-context? drop f ;
+
+: save-context-offset ( bb -- n )
+ ! ##save-context must be placed after instructions that
+ ! modify the context, or instructions that read parameter
+ ! registers.
+ instructions>> [ modifies-context? not ] find drop ;
: insert-save-context ( bb -- )
- dup instructions>> dup needs-save-context? [
- tagged-rep next-vreg-rep
- tagged-rep next-vreg-rep
- \ ##save-context new-insn prefix
- >>instructions drop
- ] [ 2drop ] if ;
+ dup bb-needs-save-context? [
+ [
+ int-rep next-vreg-rep
+ int-rep next-vreg-rep
+ \ ##save-context new-insn
+ ] dip
+ [ save-context-offset ] keep
+ [ insert-nth ] change-instructions drop
+ ] [ drop ] if ;
: insert-save-contexts ( cfg -- cfg' )
dup [ insert-save-context ] each-basic-block ;
-USING: compiler.cfg.scheduling vocabs.loader namespaces tools.test ;
+USING: compiler.cfg.scheduling compiler.cfg.instructions
+vocabs.loader namespaces tools.test arrays kernel ;
IN: compiler.cfg.scheduling.tests
! Recompile compiler.cfg.scheduling with extra tests,
[ ] [ "compiler.cfg.scheduling" reload ] unit-test
[ ] [ "compiler.cfg.dependence" reload ] unit-test
] with-variable
+
+[
+ { }
+ { }
+ { T{ ##test-branch } }
+] [
+ V{ T{ ##test-branch } }
+ split-3-ways
+ [ >array ] tri@
+] unit-test
+
+[
+ { T{ ##inc-d } T{ ##inc-r } T{ ##callback-inputs } }
+ { T{ ##add } T{ ##sub } T{ ##mul } }
+ { T{ ##test-branch } }
+] [
+ V{
+ T{ ##inc-d }
+ T{ ##inc-r }
+ T{ ##callback-inputs }
+ T{ ##add }
+ T{ ##sub }
+ T{ ##mul }
+ T{ ##test-branch }
+ }
+ split-3-ways
+ [ >array ] tri@
+] unit-test
+
+[
+ { }
+ { T{ ##add } T{ ##sub } T{ ##mul } }
+ { T{ ##dispatch } }
+] [
+ V{
+ T{ ##add }
+ T{ ##sub }
+ T{ ##mul }
+ T{ ##dispatch }
+ }
+ split-3-ways
+ [ >array ] tri@
+] unit-test
, (reorder)
] when* ;
-: cut-by ( seq quot -- before after )
- dupd find drop [ cut ] [ f ] if* ; inline
+UNION: initial-insn ##phi ##inc-d ##inc-r ##callback-inputs ;
-UNION: initial-insn
- ##phi ##inc-d ##inc-r ;
+UNION: final-insn
+##branch
+##dispatch
+conditional-branch-insn
+##epilogue ##return
+##callback-outputs ;
-: split-3-ways ( insns -- first middle last )
- [ initial-insn? not ] cut-by unclip-last ;
+: initial-insn-end ( insns -- n )
+ [ initial-insn? not ] find drop 0 or ;
+
+: final-insn-start ( insns -- n )
+ [ final-insn? not ] find-last drop [ 1 + ] [ 0 ] if* ;
+
+:: split-3-ways ( insns -- first middle last )
+ insns initial-insn-end :> a
+ insns final-insn-start :> b
+ insns a head-slice
+ a b insns <slice>
+ insns b tail-slice ;
: reorder ( insns -- insns' )
split-3-ways [
build-dependence-graph
build-fan-in-trees
[ (reorder) ] V{ } make reverse
- ] dip suffix append ;
+ ] dip 3append ;
ERROR: not-all-instructions-were-scheduled old-bb new-bb ;
[ [ length ] bi@ = ] [ [ unique ] bi@ = ] 2bi and
[ old-bb new-bb not-all-instructions-were-scheduled ] unless ;
-ERROR: definition-after-usage vreg old-bb new-bb ;
+ERROR: definition-after-usage vregs old-bb new-bb ;
:: check-usages ( new-bb old-bb -- )
HS{ } clone :> useds
new-bb instructions>> split-3-ways drop nip
[| insn |
insn uses-vregs [ useds adjoin ] each
- insn defs-vreg :> def-reg
- def-reg useds in?
- [ def-reg old-bb new-bb definition-after-usage ] when
+ insn defs-vregs :> defs-vregs
+ defs-vregs useds intersects?
+ [ defs-vregs old-bb new-bb definition-after-usage ] when
] each ;
: check-scheduling ( new-bb old-bb -- )
: might-spill? ( bb -- ? )
[ live-in assoc-size ]
- [ instructions>> [ defs-vreg ] count ] bi
+ [ instructions>> [ defs-vregs length ] map-sum ] bi
+ num-registers >= ;
: schedule-instructions ( cfg -- cfg' )
! Set of vregs defined in more than one basic block
SYMBOL: defs-multi
-: compute-insn-defs ( bb insn -- )
- defs-vreg dup [
+GENERIC: compute-insn-defs ( bb insn -- )
+
+M: insn compute-insn-defs 2drop ;
+
+M: vreg-insn compute-insn-defs
+ defs-vregs [
defs get [ conjoin-at ] [ drop ] [ at assoc-size 1 > ] 2tri
[ defs-multi get conjoin ] [ drop ] if
- ] [ 2drop ] if ;
+ ] with each ;
: compute-defs ( cfg -- )
H{ } clone defs set
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel locals fry sequences
+USING: accessors assocs kernel locals fry sequences sets
cpu.architecture
compiler.cfg.rpo
compiler.cfg.def-use
! ##fixnum-add, ##fixnum-sub or ##fixnum-mul) then we don't
! need to insert a copy since in fact doing so will result
! in incorrect code.
- [ instructions>> last defs-vreg ] dip eq? not ;
+ [ instructions>> last defs-vregs ] dip swap in? not ;
:: insert-copy ( bb src rep -- bb dst )
bb src insert-copy? [
SYMBOL: copies
: value-of ( vreg -- value )
- insn-of dup ##tagged>integer? [ src>> ] [ dst>> ] if ;
+ dup insn-of dup ##tagged>integer? [ nip src>> ] [ drop ] if ;
: init-coalescing ( -- )
defs get
M: vreg-insn prepare-insn
[ temp-vregs [ leader-map get conjoin ] each ]
[
- [ defs-vreg ] [ uses-vregs ] bi
- 2dup empty? not and [
- first
+ [ defs-vregs ] [ uses-vregs ] bi
+ 2dup [ empty? not ] both? [
+ [ first ] bi@
2dup [ rep-of reg-class-of ] bi@ eq?
[ maybe-eliminate-copy-later ] [ 2drop ] if
] [ 2drop ] if
V{
T{ ##save-context f 77 78 }
- T{ ##call-gc f { } }
+ T{ ##call-gc f T{ gc-map } }
T{ ##branch }
} 2 test-bb
SYMBOLS: local-def-indices local-kill-indices ;
-: record-def ( n insn -- )
- defs-vreg dup [ local-def-indices get set-at ] [ 2drop ] if ;
+: record-defs ( n insn -- )
+ defs-vregs [ local-def-indices get set-at ] with each ;
: record-uses ( n insn -- )
! Record live intervals so that all but the first input interfere
! with the output. This lets us coalesce the output with the
! first input.
- dup uses-vregs dup empty? [ 3drop ] [
+ dup uses-vregs [ 2drop ] [
swap def-is-use-insn?
[ [ first local-kill-indices get set-at ] [ rest-slice ] 2bi ] unless
[ 1 + ] dip [ local-kill-indices get set-at ] with each
- ] if ;
+ ] if-empty ;
GENERIC: record-insn ( n insn -- )
M: ##phi record-insn
- record-def ;
+ record-defs ;
M: vreg-insn record-insn
- [ 2 * ] dip [ record-def ] [ record-uses ] 2bi ;
+ [ 2 * ] dip [ record-defs ] [ record-uses ] 2bi ;
M: insn record-insn
2drop ;
[ ] [ test-uninitialized ] unit-test
-[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test
-[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test
+[ { B{ 0 0 0 } B{ } } ] [ 1 get uninitialized-in ] unit-test
+[ { B{ 1 1 1 } B{ 0 } } ] [ 2 get uninitialized-in ] unit-test
! When merging, if a location is uninitialized in one branch and
! initialized in another, we have to consider it uninitialized,
[ ] [ test-uninitialized ] unit-test
-[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test
+[ { B{ 0 } B{ } } ] [ 3 get uninitialized-in ] unit-test
! Consider the following sequence of instructions:
! ##inc-d 2
-! ##gc
+! ...
+! ##allot
! ##replace ... D 0
! ##replace ... D 1
-! The GC check runs before stack locations 0 and 1 have been initialized,
-! and it needs to zero them out so that GC doesn't try to trace them.
+! The GC check runs before stack locations 0 and 1 have been
+! initialized, and so the GC needs to scrub them so that they
+! don't get traced. This is achieved by computing uninitialized
+! locations with a dataflow analysis, and recording the
+! information in GC maps. The scrub_contexts() method on
+! vm/gc.cpp reads this information from GC maps and performs
+! the scrubbing.
<PRIVATE
] change ;
M: ##inc-d visit-insn n>> ds-loc handle-inc ;
-
M: ##inc-r visit-insn n>> rs-loc handle-inc ;
ERROR: uninitialized-peek insn ;
M: ##replace visit-insn visit-replace ;
M: ##replace-imm visit-insn visit-replace ;
+M: gc-map-insn visit-insn
+ gc-map>>
+ ds-loc get clone >>scrub-d
+ rs-loc get clone >>scrub-r
+ drop ;
+
M: insn visit-insn drop ;
: prepare ( pair -- )
: (join-sets) ( seq1 seq2 -- seq )
2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
-: (uninitialized-locs) ( seq quot -- seq' )
- [ [ drop 0 = ] selector [ each-index ] dip ] dip map ; inline
-
PRIVATE>
FORWARD-ANALYSIS: uninitialized
M: uninitialized-analysis join-sets ( sets analysis -- pair )
2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
-
-: uninitialized-locs ( bb -- locs )
- uninitialized-in dup [
- first2
- [ [ <ds-loc> ] (uninitialized-locs) ]
- [ [ <rs-loc> ] (uninitialized-locs) ]
- bi* append f like
- ] when ;
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
:: update-predecessors ( from to bb -- )
- ! Update 'to' predecessors for insertion of 'bb' between
- ! 'from' and 'to'.
+ ! Whenever 'from' appears in the list of predecessors of 'to'
+ ! replace it with 'bb'.
to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
:: update-successors ( from to bb -- )
- ! Update 'from' successors for insertion of 'bb' between
- ! 'from' and 'to'.
+ ! Whenever 'to' appears in the list of successors of 'from'
+ ! replace it with 'bb'.
from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
:: insert-basic-block ( from to insns -- )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes classes.algebra combinators fry
generic.parser kernel math namespaces quotations sequences slots
-words make
+words make sets
compiler.cfg.instructions
compiler.cfg.instructions.syntax
compiler.cfg.value-numbering.graph ;
[ drop \ >expr create-method-in ] [ >expr-quot ] 2bi define ;
insn-classes get
-[ pure-insn class<= ] filter
+[ foldable-insn class<= ] filter
+{ ##copy ##load-integer ##load-reference } diff
[
dup "insn-slots" word-prop input-values
define->expr-method
[ redundant-instruction ] [ useful-instruction ] ?if ;
M: insn process-instruction
+ dup rewrite [ process-instruction ] [ ] ?if ;
+
+M: foldable-insn process-instruction
dup rewrite
[ process-instruction ]
- [ dup defs-vreg [ check-redundancy ] when ] ?if ;
+ [ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if ;
M: ##copy process-instruction
dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
! Special cases
M: ##no-tco generate-insn drop ;
-M: ##stack-frame generate-insn drop ;
-
M: ##prologue generate-insn
drop
cfg get stack-frame>>
CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
-CODEGEN: ##restore-context %restore-context
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: ##alien-global %alien-global
-CODEGEN: ##gc-map %gc-map
CODEGEN: ##call-gc %call-gc
CODEGEN: ##spill %spill
CODEGEN: ##reload %reload
! FFI
CODEGEN: ##unbox %unbox
CODEGEN: ##unbox-long-long %unbox-long-long
-CODEGEN: ##store-reg-param %store-reg-param
-CODEGEN: ##store-stack-param %store-stack-param
-CODEGEN: ##load-reg-param %load-reg-param
-CODEGEN: ##load-stack-param %load-stack-param
CODEGEN: ##local-allot %local-allot
CODEGEN: ##box %box
CODEGEN: ##box-long-long %box-long-long
-CODEGEN: ##allot-byte-array %allot-byte-array
-CODEGEN: ##prepare-var-args %prepare-var-args
CODEGEN: ##alien-invoke %alien-invoke
-CODEGEN: ##cleanup %cleanup
CODEGEN: ##alien-indirect %alien-indirect
-CODEGEN: ##begin-callback %begin-callback
+CODEGEN: ##alien-assembly %alien-assembly
+CODEGEN: ##callback-inputs %callback-inputs
CODEGEN: ##alien-callback %alien-callback
-CODEGEN: ##end-callback %end-callback
-
-M: ##alien-assembly generate-insn quot>> call( -- ) ;
+CODEGEN: ##callback-outputs %callback-outputs
USING: namespaces byte-arrays make compiler.codegen.fixup
bit-arrays accessors classes.struct tools.test kernel math
-sequences alien.c-types specialized-arrays boxes ;
+sequences alien.c-types specialized-arrays boxes
+compiler.cfg.instructions system cpu.architecture ;
SPECIALIZED-ARRAY: uint
IN: compiler.codegen.fixup.tests
{ gc-root-count uint }
{ return-address-count uint } ;
+SINGLETON: fake-cpu
+
+fake-cpu \ cpu set
+
+M: fake-cpu gc-root-offsets ;
+
[ ] [
[
init-fixup
50 <byte-array> %
- { { } { } { } } set-next-gc-map
- gc-map-here
+ T{ gc-map f B{ } B{ } V{ } } gc-map-here
50 <byte-array> %
- { { 0 4 } { 1 } { 1 3 } } set-next-gc-map
- gc-map-here
+ T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } } gc-map-here
emit-gc-info
] B{ } make
hashtables io.binary kernel kernel.private math namespaces make
sequences words quotations strings alien.accessors alien.strings
layouts system combinators math.bitwise math.order
-combinators.smart accessors growable fry compiler.constants
-memoize boxes ;
+combinators.short-circuit combinators.smart accessors growable
+fry memoize compiler.constants compiler.cfg.instructions
+cpu.architecture ;
IN: compiler.codegen.fixup
! Utilities
! uint <largest GC root spill slot>
! uint <number of return addresses>
-SYMBOLS: next-gc-map return-addresses gc-maps ;
+SYMBOLS: return-addresses gc-maps ;
-: gc-map? ( triple -- ? )
+: gc-map-needed? ( gc-map -- ? )
! If there are no stack locations to scrub and no GC roots,
! there's no point storing the GC map.
- [ empty? not ] any? ;
-
-: gc-map-here ( -- )
- next-gc-map get box> dup gc-map? [
+ dup [
+ {
+ [ scrub-d>> empty? ]
+ [ scrub-r>> empty? ]
+ [ gc-roots>> empty? ]
+ } 1&& not
+ ] when ;
+
+: gc-map-here ( gc-map -- )
+ dup gc-map-needed? [
gc-maps get push
compiled-offset return-addresses get push
] [ drop ] if ;
-: set-next-gc-map ( gc-map -- ) next-gc-map get >box ;
+: emit-scrub ( seqs -- n )
+ ! seqs is a sequence of sequences of 0/1
+ dup [ length ] [ max ] map-reduce
+ [ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ;
: integers>bits ( seq n -- bit-array )
<bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
-: emit-bitmap ( seqs -- n )
+: emit-gc-roots ( seqs -- n )
! seqs is a sequence of sequences of integers 0..n-1
- [ 0 ] [
- dup [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce
- [ '[ _ integers>bits % ] each ] keep
- ] if-empty ;
+ dup [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce
+ [ '[ _ integers>bits % ] each ] keep ;
: emit-uint ( n -- )
building get push-uint ;
return-addresses get empty? [ 0 emit-uint ] [
gc-maps get
[
- [ [ first ] map emit-bitmap ]
- [ [ second ] map emit-bitmap ]
- [ [ third ] map emit-bitmap ] tri
+ [ [ scrub-d>> ] map emit-scrub ]
+ [ [ scrub-r>> ] map emit-scrub ]
+ [ [ gc-roots>> gc-root-offsets ] map emit-gc-roots ] tri
] ?{ } make underlying>> %
return-addresses get [ emit-uint ] each
[ emit-uint ] tri@
BV{ } clone relocation-table set
V{ } clone binary-literal-table set
V{ } clone return-addresses set
- V{ } clone gc-maps set
- <box> next-gc-map set ;
+ V{ } clone gc-maps set ;
: check-fixup ( seq -- )
- length data-alignment get mod 0 assert=
- next-gc-map get occupied>> f assert= ;
+ length data-alignment get mod 0 assert= ;
: with-fixup ( quot -- code )
'[
[ 3 ] [ blah ] unit-test
-: out-param-test ( -- b )
- { int } [ [ 12 ] dip 0 int set-alien-value ] [ ] with-out-parameters ;
+: out-param-test-1 ( -- b )
+ { int } [ [ 12 ] dip 0 int set-alien-value ] with-out-parameters ;
-[ 12 ] [ out-param-test ] unit-test
+[ 12 ] [ out-param-test-1 ] unit-test
+
+: out-param-test-2 ( -- b )
+ { { int initial: 12 } } [ drop ] with-out-parameters ;
+
+[ 12 ] [ out-param-test-2 ] unit-test
+
+: out-param-test-3 ( -- x y )
+ { { RECT initial: S{ RECT { x 3 } { y 4 } } } } [ drop ]
+ with-out-parameters
+ [ x>> ] [ y>> ] bi ;
+
+[ 3.0 4.0 ] [ out-param-test-3 ] unit-test
: out-param-callback ( -- a )
void { int pointer: int } cdecl
{ int } [
swap void { int pointer: int } cdecl
alien-indirect
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
[ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler.test definitions generic.single shuffle math.order ;
+compiler.test definitions generic.single shuffle math.order
+compiler.cfg.debugger classes.struct alien.syntax alien.data ;
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
] keep ;
[ { 0.5 } ] [ grid-mesh-test-case ] unit-test
+
+[ { 1 } "bar" ] [ { 1 } [ [ [ [ "foo" throw ] [ "bar" throw ] recover ] attempt-all f ] [ ] recover ] compile-call ] unit-test
+
+GENERIC: bad-push-test-case ( a -- b )
+M: object bad-push-test-case "foo" throw ; inline
+[ { 1 } "bar" ] [ { 1 } [ [ [ [ bad-push-test-case ] [ "bar" throw ] recover ] attempt-all f ] [ ] recover ] compile-call ] unit-test
+
+STRUCT: BitmapData { Scan0 void* } ;
+
+[ ALIEN: 123 ] [
+ [
+ { BitmapData }
+ [ BitmapData memory>struct ALIEN: 123 >>Scan0 drop ]
+ with-out-parameters Scan0>>
+ ] compile-call
+] unit-test
[ t ] [
[
- { integer } declare [ 256 rem ] map
+ { iota } declare [ 256 rem ] map
] { mod fixnum-mod rem } inlined?
] unit-test
] keep bitxor >fixnum
] with each
] { + bignum+ fixnum-shift bitxor bignum-bitxor } inlined?
-] unit-test
\ No newline at end of file
+] unit-test
literal>> dup tuple-class? [ drop tuple ] unless <class-info>
] "outputs" set-word-prop
-! the output of clone has the same type as the input
+! the output of (clone) has the same type as the input
: cloned-value-info ( value-info -- value-info' )
clone f >>literal f >>literal?
[ [ dup [ cloned-value-info ] when ] map ] change-slots ;
-{ clone (clone) } [
- [ cloned-value-info ] "outputs" set-word-prop
-] each
+\ (clone) [ cloned-value-info ] "outputs" set-word-prop
\ slot [
dup literal?>>
! Copyright (C) 2008, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: deques threads kernel arrays sequences alarms fry ;\r
+USING: deques threads kernel arrays sequences timers fry ;\r
IN: concurrency.conditions\r
\r
: notify-1 ( deque -- )\r
: notify-all ( deque -- )\r
[ resume-now ] slurp-deque ; inline\r
\r
-: queue-timeout ( queue timeout -- alarm )\r
- #! Add an alarm which removes the current thread from the\r
+: queue-timeout ( queue timeout -- timer )\r
+ #! Add an timer which removes the current thread from the\r
#! queue, and resumes it, passing it a value of t.\r
[\r
[ self swap push-front* ] keep '[\r
: wait ( queue timeout status -- )\r
over [\r
[ queue-timeout ] dip suspend\r
- [ wait-timeout ] [ stop-alarm ] if\r
+ [ wait-timeout ] [ stop-timer ] if\r
] [\r
[ drop queue ] dip suspend drop\r
] if ; inline\r
! Copyright (C) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.syntax kernel math
-namespaces sequences destructors combinators threads heaps
-deques calendar system core-foundation core-foundation.strings
-core-foundation.file-descriptors core-foundation.timers
-core-foundation.time ;
+USING: accessors alien alien.c-types alien.syntax calendar
+classes.struct combinators core-foundation
+core-foundation.file-descriptors core-foundation.strings
+core-foundation.time core-foundation.timers deques destructors
+heaps kernel math namespaces sequences system threads unix
+unix.time ;
+FROM: calendar.unix => system-micros ;
IN: core-foundation.run-loop
CONSTANT: kCFRunLoopRunFinished 1
[ 0 swap <CFRange> kCFStringEncodingUTF8 0 f ] keep
4 * 1 + <byte-array> [
dup length
- { CFIndex } [ CFStringGetBytes drop ] [ ]
- with-out-parameters
+ { CFIndex } [ CFStringGetBytes drop ] with-out-parameters
] keep
swap head-slice utf8 decode ;
! 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 ;
+core-foundation core-foundation.time calendar.unix ;
IN: core-foundation.timers
TYPEDEF: void* CFRunLoopTimerRef
: typographic-bounds ( line -- width ascent descent leading )
{ CGFloat CGFloat CGFloat }
- [ CTLineGetTypographicBounds ] [ ] with-out-parameters ; inline
+ [ CTLineGetTypographicBounds ] with-out-parameters ; inline
: store-typographic-bounds ( metrics width ascent descent leading -- metrics )
{
! %store-memory work
HOOK: complex-addressing? cpu ( -- ? )
+HOOK: gc-root-offsets cpu ( seq -- seq' )
+
HOOK: %load-immediate cpu ( reg val -- )
HOOK: %load-reference cpu ( reg obj -- )
HOOK: %load-float cpu ( reg val -- )
! GC checks
HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
-HOOK: %gc-map cpu ( scrub-d scrub-r gc-roots -- )
-HOOK: %call-gc cpu ( -- )
+HOOK: %call-gc cpu ( gc-map -- )
HOOK: %prologue cpu ( n -- )
HOOK: %epilogue cpu ( n -- )
! can be passed to a C function, or returned from a callback
HOOK: %unbox cpu ( dst src func rep -- )
-HOOK: %unbox-long-long cpu ( src out func -- )
-
-HOOK: %store-reg-param cpu ( src reg rep -- )
-
-HOOK: %store-stack-param cpu ( src n rep -- )
+HOOK: %unbox-long-long cpu ( dst1 dst2 src func -- )
HOOK: %local-allot cpu ( dst size align offset -- )
! Call a function to convert a value into a tagged pointer,
! possibly allocating a bignum, float, or alien instance,
! which is then pushed on the data stack
-HOOK: %box cpu ( dst src func rep -- )
-
-HOOK: %box-long-long cpu ( dst src1 src2 func -- )
-
-HOOK: %allot-byte-array cpu ( dst size -- )
+HOOK: %box cpu ( dst src func rep gc-map -- )
-HOOK: %restore-context cpu ( temp1 temp2 -- )
+HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- )
HOOK: %save-context cpu ( temp1 temp2 -- )
-HOOK: %prepare-var-args cpu ( -- )
+HOOK: %c-invoke cpu ( symbols dll gc-map -- )
-M: object %prepare-var-args ;
+HOOK: %alien-invoke cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- )
-HOOK: %alien-invoke cpu ( function library -- )
+HOOK: %alien-indirect cpu ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- )
-HOOK: %cleanup cpu ( n -- )
+HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- )
-M: object %cleanup ( n -- ) drop ;
-
-HOOK: %alien-indirect cpu ( src -- )
-
-HOOK: %load-reg-param cpu ( dst reg rep -- )
-
-HOOK: %load-stack-param cpu ( dst n rep -- )
-
-HOOK: %begin-callback cpu ( -- )
+HOOK: %callback-inputs cpu ( reg-outputs stack-outputs -- )
HOOK: %alien-callback cpu ( quot -- )
-HOOK: %end-callback cpu ( -- )
+HOOK: %callback-outputs cpu ( reg-inputs -- )
HOOK: stack-cleanup cpu ( stack-size return abi -- n )
-
-M: object stack-cleanup 3drop 0 ;
M:: ppc %unary-float-function ( dst src func -- )
0 src float-function-param
- func f %alien-invoke
+ func f %c-invoke
dst float-function-return ;
M:: ppc %binary-float-function ( dst src1 src2 func -- )
0 src1 float-function-param
1 src2 float-function-param
- func f %alien-invoke
+ func f %c-invoke
dst float-function-return ;
! Internal format is always double-precision on PowerPC
M: ppc %call-gc ( gc-roots -- )
3 swap gc-root-offsets %load-reference
4 %load-vm-addr
- "inline_gc" f %alien-invoke ;
+ "inline_gc" f %c-invoke ;
M: ppc %prologue ( n -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
:: call-unbox-func ( src func -- )
3 src load-param
4 %load-vm-addr
- func f %alien-invoke ;
+ func f %c-invoke ;
M:: ppc %unbox ( src n rep func -- )
src func call-unbox-func
4 src load-param
3 1 n local@ ADDI
c-type heap-size 5 LI
- "memcpy" "libc" load-library %alien-invoke ;
+ "memcpy" "libc" load-library %c-invoke ;
M:: ppc %box ( dst n rep func -- )
n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
rep double-rep? 5 4 ? %load-vm-addr
- func f %alien-invoke
+ func f %c-invoke
3 dst store-param ;
M:: ppc %box-long-long ( dst n func -- )
4 1 n cell + local@ LWZ
] when
5 %load-vm-addr
- func f %alien-invoke
+ func f %c-invoke
3 dst store-param ;
: struct-return@ ( n -- n )
c-type heap-size 4 LI
5 %load-vm-addr
! Call the function
- "from_value_struct" f %alien-invoke
+ "from_value_struct" f %c-invoke
3 dst store-param ;
M:: ppc %restore-context ( temp1 temp2 -- )
ds-reg temp1 "datastack" context-field-offset STW
rs-reg temp1 "retainstack" context-field-offset STW ;
-M: ppc %alien-invoke ( symbol dll -- )
+M: ppc %c-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
M: ppc %alien-indirect ( src -- )
#! Box a <= 16-byte struct returned in r3:r4:r5:r6
c-type heap-size 7 LI
8 %load-vm-addr
- "from_medium_struct" f %alien-invoke
+ "from_medium_struct" f %c-invoke
3 dst store-param ;
: %unbox-struct-1 ( -- )
M: ppc %begin-callback ( -- )
3 %load-vm-addr
- "begin_callback" f %alien-invoke ;
+ "begin_callback" f %c-invoke ;
M: ppc %alien-callback ( quot -- )
3 swap %load-reference
M: ppc %end-callback ( -- )
3 %load-vm-addr
- "end_callback" f %alien-invoke ;
+ "end_callback" f %c-invoke ;
enable-float-functions
M: x86.32 %prepare-jump
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
+M: x86.32 %load-stack-param ( dst rep n -- )
+ next-stack@ swap pick register? [ %copy ] [
+ {
+ { int-rep [ [ EAX ] dip MOV ?spill-slot EAX MOV ] }
+ { float-rep [ FLDS ?spill-slot FSTPS ] }
+ { double-rep [ FLDL ?spill-slot FSTPL ] }
+ } case
+ ] if ;
+
+M: x86.32 %store-stack-param ( src rep n -- )
+ stack@ swap pick register? [ [ swap ] dip %copy ] [
+ {
+ { int-rep [ [ [ EAX ] dip ?spill-slot MOV ] [ EAX MOV ] bi* ] }
+ { float-rep [ [ ?spill-slot FLDS ] [ FSTPS ] bi* ] }
+ { double-rep [ [ ?spill-slot FLDL ] [ FSTPL ] bi* ] }
+ } case
+ ] if ;
+
:: load-float-return ( dst x87-insn rep -- )
dst register? [
ESP 4 SUB
dst ?spill-slot x87-insn execute
] if ; inline
-M: x86.32 %load-reg-param ( dst reg rep -- )
- {
+M: x86.32 %load-reg-param ( vreg rep reg -- )
+ swap {
{ int-rep [ int-rep %copy ] }
{ float-rep [ drop \ FSTPS float-rep load-float-return ] }
{ double-rep [ drop \ FSTPL double-rep load-float-return ] }
src ?spill-slot x87-insn execute
] if ; inline
-M: x86.32 %store-reg-param ( src reg rep -- )
- {
+M: x86.32 %store-reg-param ( vreg rep reg -- )
+ swap {
{ int-rep [ swap int-rep %copy ] }
{ float-rep [ drop \ FLDS float-rep store-float-return ] }
{ double-rep [ drop \ FLDL double-rep store-float-return ] }
EAX src tagged-rep %copy
4 save-vm-ptr
0 stack@ EAX MOV
- func f %alien-invoke ;
+ func f f %c-invoke ;
M:: x86.32 %unbox ( dst src func rep -- )
src func call-unbox-func
dst rep %load-return ;
-M:: x86.32 %unbox-long-long ( src out func -- )
- EAX src int-rep %copy
- 0 stack@ EAX MOV
- EAX out int-rep %copy
- 4 stack@ EAX MOV
- 8 save-vm-ptr
- func f %alien-invoke ;
+M:: x86.32 %unbox-long-long ( dst1 dst2 src func -- )
+ src int-rep 0 %store-stack-param
+ 4 save-vm-ptr
+ func f f %c-invoke
+ dst1 EAX int-rep %copy
+ dst2 EDX int-rep %copy ;
-M:: x86.32 %box ( dst src func rep -- )
+M:: x86.32 %box ( dst src func rep gc-map -- )
+ src rep 0 %store-stack-param
rep rep-size save-vm-ptr
- src rep %store-return
- 0 stack@ rep %load-return
- func f %alien-invoke
+ func f gc-map %c-invoke
dst EAX tagged-rep %copy ;
-M:: x86.32 %box-long-long ( dst src1 src2 func -- )
+M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- )
+ src1 int-rep 0 %store-stack-param
+ src2 int-rep 4 %store-stack-param
8 save-vm-ptr
- EAX src1 int-rep %copy
- 0 stack@ EAX int-rep %copy
- EAX src2 int-rep %copy
- 4 stack@ EAX int-rep %copy
- func f %alien-invoke
+ func f gc-map %c-invoke
dst EAX tagged-rep %copy ;
-M:: x86.32 %allot-byte-array ( dst size -- )
- 4 save-vm-ptr
- 0 stack@ size MOV
- "allot_byte_array" f %alien-invoke
- dst EAX tagged-rep %copy ;
-
-M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
+M: x86.32 %c-invoke
+ [ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
4 stack@ 0 MOV
- "begin_callback" f %alien-invoke ;
+ "begin_callback" f f %c-invoke ;
M: x86.32 %alien-callback ( quot -- )
[ EAX ] dip %load-reference
M: x86.32 %end-callback ( -- )
0 save-vm-ptr
- "end_callback" f %alien-invoke ;
-
-GENERIC: float-function-param ( n dst src -- )
-
-M:: spill-slot float-function-param ( n dst src -- )
- ! We can clobber dst here since its going to contain the
- ! final result
- dst src double-rep %copy
- dst n double-rep %store-stack-param ;
-
-M:: register float-function-param ( n dst src -- )
- src n double-rep %store-stack-param ;
+ "end_callback" f f %c-invoke ;
M:: x86.32 %unary-float-function ( dst src func -- )
- 0 dst src float-function-param
- func "libm" load-library %alien-invoke
+ src double-rep 0 %store-stack-param
+ func "libm" load-library f %c-invoke
dst double-rep %load-return ;
M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
- 0 dst src1 float-function-param
- 8 dst src2 float-function-param
- func "libm" load-library %alien-invoke
+ src1 double-rep 0 %store-stack-param
+ src2 double-rep 8 %store-stack-param
+ func "libm" load-library f %c-invoke
dst double-rep %load-return ;
: funny-large-struct-return? ( return abi -- ? )
: nv-reg ( -- reg ) ESI ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
+: link-reg ( -- reg ) EBX ;
: fixnum>slot@ ( -- ) temp0 2 SAR ;
: rex-length ( -- n ) 0 ;
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
+: jit-scrub-return ( n -- )
+ ESP swap [+] 0 MOV ;
+
[
! ctx-reg is preserved across the call because it is non-volatile
! in the C ABI
ESP 4 [+] EAX MOV
"begin_callback" jit-call
- jit-load-vm
- jit-load-context
- jit-restore-context
-
jit-call-quot
jit-load-vm
- jit-save-context
-
ESP [] vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
! Unwind stack frames
ESP EDX MOV
+ 0 jit-scrub-return
jit-jump-quot
] \ unwind-native-frames define-sub-primitive
! Contexts
: jit-switch-context ( reg -- )
- ! Dummy return address -- it never gets returned to but it
- ! must point to inside the current code block
- ESP -4 [+] HEX: ffffffff MOV rc-absolute-cell rt-this jit-rel
+ -4 jit-scrub-return
! Save ds, rs registers
jit-load-vm
dup load-decks-offset
[+] card-mark <byte> MOV ;
-M:: x86.64 %load-reg-param ( dst reg rep -- )
- dst reg rep %copy ;
+M:: x86.64 %load-stack-param ( vreg rep n -- )
+ rep return-reg n next-stack@ rep %copy
+ vreg rep return-reg rep %copy ;
-M:: x86.64 %store-reg-param ( src reg rep -- )
- reg src rep %copy ;
+M:: x86.64 %store-stack-param ( vreg rep n -- )
+ rep return-reg vreg rep %copy
+ n reserved-stack-space + stack@ rep return-reg rep %copy ;
+
+M:: x86.64 %load-reg-param ( vreg rep reg -- )
+ vreg reg rep %copy ;
+
+M:: x86.64 %store-reg-param ( vreg rep reg -- )
+ reg vreg rep %copy ;
M:: x86.64 %unbox ( dst src func rep -- )
param-reg-0 src tagged-rep %copy
param-reg-1 %mov-vm-ptr
- func f %alien-invoke
+ func f f %c-invoke
dst rep %load-return ;
-M:: x86.64 %box ( dst src func rep -- )
+M:: x86.64 %box ( dst src func rep gc-map -- )
0 rep reg-class-of cdecl param-regs at nth src rep %copy
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
- func f %alien-invoke
+ func f gc-map %c-invoke
dst int-rep %load-return ;
-M:: x86.64 %allot-byte-array ( dst size -- )
- param-reg-0 size MOV
- param-reg-1 %mov-vm-ptr
- "allot_byte_array" f %alien-invoke
- dst int-rep %load-return ;
-
-M: x86.64 %alien-invoke
- R11 0 MOV
- rc-absolute-cell rel-dlsym
- R11 CALL ;
+M: x86.64 %c-invoke
+ [ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip
+ gc-map-here ;
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
param-reg-1 0 MOV
- "begin_callback" f %alien-invoke ;
+ "begin_callback" f f %c-invoke ;
M: x86.64 %alien-callback ( quot -- )
[ param-reg-0 ] dip %load-reference
M: x86.64 %end-callback ( -- )
param-reg-0 %mov-vm-ptr
- "end_callback" f %alien-invoke ;
+ "end_callback" f f %c-invoke ;
: float-function-param ( i src -- )
[ float-regs cdecl param-regs at nth ] dip double-rep %copy ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
- func "libm" load-library %alien-invoke
+ func "libm" load-library f %c-invoke
dst double-rep %load-return ;
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
! src2 is always a spill slot
0 src1 float-function-param
1 src2 float-function-param
- func "libm" load-library %alien-invoke
+ func "libm" load-library f %c-invoke
dst double-rep %load-return ;
+M: x86.64 stack-cleanup 3drop 0 ;
+
+M: x86.64 %cleanup 0 assert= ;
+
M: x86.64 long-long-on-stack? f ;
M: x86.64 float-on-stack? f ;
: nv-reg ( -- reg ) RBX ;
: stack-reg ( -- reg ) RSP ;
: frame-reg ( -- reg ) RBP ;
+: link-reg ( -- reg ) R11 ;
: ctx-reg ( -- reg ) R12 ;
: vm-reg ( -- reg ) R13 ;
: ds-reg ( -- reg ) R14 ;
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
+: jit-scrub-return ( n -- )
+ RSP swap [+] 0 MOV ;
+
[
! ctx-reg is preserved across the call because it is non-volatile
! in the C ABI
arg1 vm-reg MOV
"begin_callback" jit-call
- jit-load-context
- jit-restore-context
-
! call the quotation
arg1 return-reg MOV
jit-call-quot
- jit-save-context
-
arg1 vm-reg MOV
"end_callback" jit-call
] \ c-to-factor define-sub-primitive
! Unwind stack frames
RSP arg2 MOV
+ 0 jit-scrub-return
! Load VM pointer into vm-reg, since we're entering from
! C code
! Contexts
: jit-switch-context ( reg -- )
- ! Dummy return address -- it never gets returned to but it
- ! must point to inside the current code block
- R11 0 [RIP+] LEA
- RSP -8 [+] R11 MOV
+ -8 jit-scrub-return
! Save ds, rs registers
jit-save-context
[ [ EAX [] XMM1 UCOMISD ] { } make ] must-fail
[ { HEX: 66 HEX: 0f HEX: 38 HEX: 2a HEX: 01 } ] [ [ XMM0 ECX [] MOVNTDQA ] { } make ] unit-test
+[ { HEX: 66 HEX: 48 HEX: 0f HEX: 6e HEX: c8 } ] [ [ XMM1 RAX MOVD ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 6e HEX: c8 } ] [ [ XMM1 EAX MOVD ] { } make ] unit-test
+[ { HEX: 66 HEX: 48 HEX: 0f HEX: 7e HEX: c8 } ] [ [ RAX XMM1 MOVD ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 7e HEX: c8 } ] [ [ EAX XMM1 MOVD ] { } make ] unit-test
+
+[ { HEX: f3 HEX: 0f HEX: 7e HEX: 08 } ] [ [ XMM1 EAX [] MOVQ ] { } make ] unit-test
+[ { HEX: f3 HEX: 0f HEX: 7e HEX: 08 } ] [ [ XMM1 EAX [] MOVQ ] { } make ] unit-test
+[ { HEX: f3 HEX: 0f HEX: 7e HEX: ca } ] [ [ XMM1 XMM2 MOVQ ] { } make ] unit-test
+
! rm-r only sse instructions
[ { HEX: 0f HEX: 2b HEX: 08 } ] [ [ EAX [] XMM1 MOVNTPS ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: e7 HEX: 08 } ] [ [ EAX [] XMM1 MOVNTDQ ] { } make ] unit-test
: 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- )
[ , ] when* direction-op-sse extended-opcode (2-operand) ;
+: 2-operand-rm-mr-sse* ( dst src op12{rm,mr} -- )
+ direction-op-sse first2 [ , ] when* extended-opcode (2-operand) ;
+
: 2-operand-rm-sse ( dst src op1 op2 -- )
[ , ] when* extended-opcode (2-operand) ;
: MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ;
: MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ;
+: MOVQ ( dest src -- )
+ { { HEX: 7e HEX: f3 } { HEX: d6 HEX: 66 } } 2-operand-rm-mr-sse* ;
+
<PRIVATE
: 2shuffler ( indexes/mask -- mask )
! Save C callstack pointer
nv-reg context-callstack-save-offset [+] stack-reg MOV
- ! Load Factor callstack pointer
+ ! Load Factor stack pointers
stack-reg nv-reg context-callstack-bottom-offset [+] MOV
-
nv-reg jit-update-tib
jit-install-seh
+ rs-reg nv-reg context-retainstack-offset [+] MOV
+ ds-reg nv-reg context-datastack-offset [+] MOV
+
! Call into Factor code
- nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
- nv-reg CALL
+ link-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
+ link-reg CALL
! Load VM into vm-reg; only needed on x86-32, but doesn't
! hurt on x86-64
{ cc/<= [ label JG ] }
} case ;
-: gc-root-offsets ( seq -- seq' )
+M: x86 gc-root-offsets
[ n>> spill-offset special-offset cell + cell /i ] map f like ;
-M: x86 %gc-map ( scrub-d scrub-r gc-roots -- )
- gc-root-offsets 3array set-next-gc-map ;
-
-M: x86 %call-gc
+M: x86 %call-gc ( gc-map -- )
\ minor-gc %call
gc-map-here ;
M:: x86 %reload ( dst rep src -- )
dst src rep %copy ;
-M:: x86 %store-stack-param ( src n rep -- )
- n reserved-stack-space + stack@ src rep %copy ;
-
-: %load-return ( dst rep -- )
- [ reg-class-of return-regs at first ] keep %load-reg-param ;
-
-: %store-return ( dst rep -- )
- [ reg-class-of return-regs at first ] keep %store-reg-param ;
+M:: x86 %local-allot ( dst size align offset -- )
+ dst offset local-allot-offset special-offset stack@ LEA ;
: next-stack@ ( n -- operand )
#! nth parameter from the next stack frame. Used to box
#! set up by the caller.
[ frame-reg ] dip 2 cells + reserved-stack-space + [+] ;
-M:: x86 %load-stack-param ( dst n rep -- )
- dst n next-stack@ rep %copy ;
+: return-reg ( rep -- reg )
+ reg-class-of return-regs at first ;
-M:: x86 %local-allot ( dst size align offset -- )
- dst offset local-allot-offset special-offset stack@ LEA ;
+HOOK: %load-stack-param cpu ( vreg rep n -- )
-M: x86 %alien-indirect ( src -- )
- ?spill-slot CALL ;
+HOOK: %store-stack-param cpu ( vreg rep n -- )
-M: x86 %loop-entry 16 alignment [ NOP ] times ;
+HOOK: %load-reg-param cpu ( vreg rep reg -- )
-M:: x86 %restore-context ( temp1 temp2 -- )
- #! Load Factor stack pointers on entry from C to Factor.
- temp1 %context
- temp2 stack-reg cell neg [+] LEA
- temp1 "callstack-top" context-field-offset [+] temp2 MOV
- ds-reg temp1 "datastack" context-field-offset [+] MOV
- rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
+HOOK: %store-reg-param cpu ( vreg rep reg -- )
+
+: %load-return ( dst rep -- )
+ dup return-reg %load-reg-param ;
+
+: %store-return ( dst rep -- )
+ dup return-reg %store-reg-param ;
+
+HOOK: %prepare-var-args cpu ( -- )
+
+HOOK: %cleanup cpu ( n -- )
+
+:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot -- )
+ stack-inputs [ first3 %store-stack-param ] each
+ reg-inputs [ first3 %store-reg-param ] each
+ quot call
+ cleanup %cleanup
+ reg-outputs [ first3 %load-reg-param ] each ; inline
+
+M: x86 %alien-invoke ( reg-inputs stack-inputs reg-outputs cleanup stack-size symbols dll gc-map -- )
+ '[ _ _ _ %c-invoke ] emit-alien-insn ;
+
+M:: x86 %alien-indirect ( src reg-inputs stack-inputs reg-outputs cleanup stack-size gc-map -- )
+ reg-inputs stack-inputs reg-outputs cleanup stack-size [
+ src ?spill-slot CALL
+ gc-map gc-map-here
+ ] emit-alien-insn ;
+
+M: x86 %alien-assembly ( reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map -- )
+ '[ _ _ gc-map set call( -- ) ] emit-alien-insn ;
+
+HOOK: %begin-callback cpu ( -- )
+
+M: x86 %callback-inputs ( reg-outputs stack-outputs -- )
+ [ [ first3 %load-reg-param ] each ]
+ [ [ first3 %load-stack-param ] each ] bi*
+ %begin-callback ;
+
+HOOK: %end-callback cpu ( -- )
+
+M: x86 %callback-outputs ( reg-inputs -- )
+ %end-callback
+ [ first3 %store-reg-param ] each ;
+
+M: x86 %loop-entry 16 alignment [ NOP ] times ;
M:: x86 %save-context ( temp1 temp2 -- )
#! Save Factor stack pointers in case the C code calls a
:: (%compare-float) ( dst src1 src2 cc temp compare -- )
cc {
- { cc< [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
- { cc<= [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
- { cc> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
- { cc>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
- { cc= [ src1 src2 \ compare call( a b -- ) dst temp \ %cmov-float= (%boolean) ] }
- { cc<> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVNE (%boolean) ] }
- { cc<>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVNP (%boolean) ] }
- { cc/< [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
- { cc/<= [ src2 src1 \ compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
- { cc/> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
- { cc/>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
- { cc/= [ src1 src2 \ compare call( a b -- ) dst temp \ %cmov-float/= (%boolean) ] }
- { cc/<> [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVE (%boolean) ] }
- { cc/<>= [ src1 src2 \ compare call( a b -- ) dst temp \ CMOVP (%boolean) ] }
+ { cc< [ src2 src1 compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
+ { cc<= [ src2 src1 compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+ { cc> [ src1 src2 compare call( a b -- ) dst temp \ CMOVA (%boolean) ] }
+ { cc>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+ { cc= [ src1 src2 compare call( a b -- ) dst temp \ %cmov-float= (%boolean) ] }
+ { cc<> [ src1 src2 compare call( a b -- ) dst temp \ CMOVNE (%boolean) ] }
+ { cc<>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVNP (%boolean) ] }
+ { cc/< [ src2 src1 compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+ { cc/<= [ src2 src1 compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
+ { cc/> [ src1 src2 compare call( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+ { cc/>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVB (%boolean) ] }
+ { cc/= [ src1 src2 compare call( a b -- ) dst temp \ %cmov-float/= (%boolean) ] }
+ { cc/<> [ src1 src2 compare call( a b -- ) dst temp \ CMOVE (%boolean) ] }
+ { cc/<>= [ src1 src2 compare call( a b -- ) dst temp \ CMOVP (%boolean) ] }
} case ; inline
: %jump-float= ( label -- )
:: (%compare-float-branch) ( label src1 src2 cc compare -- )
cc {
- { cc< [ src2 src1 \ compare call( a b -- ) label JA ] }
- { cc<= [ src2 src1 \ compare call( a b -- ) label JAE ] }
- { cc> [ src1 src2 \ compare call( a b -- ) label JA ] }
- { cc>= [ src1 src2 \ compare call( a b -- ) label JAE ] }
- { cc= [ src1 src2 \ compare call( a b -- ) label %jump-float= ] }
- { cc<> [ src1 src2 \ compare call( a b -- ) label JNE ] }
- { cc<>= [ src1 src2 \ compare call( a b -- ) label JNP ] }
- { cc/< [ src2 src1 \ compare call( a b -- ) label JBE ] }
- { cc/<= [ src2 src1 \ compare call( a b -- ) label JB ] }
- { cc/> [ src1 src2 \ compare call( a b -- ) label JBE ] }
- { cc/>= [ src1 src2 \ compare call( a b -- ) label JB ] }
- { cc/= [ src1 src2 \ compare call( a b -- ) label %jump-float/= ] }
- { cc/<> [ src1 src2 \ compare call( a b -- ) label JE ] }
- { cc/<>= [ src1 src2 \ compare call( a b -- ) label JP ] }
+ { cc< [ src2 src1 compare call( a b -- ) label JA ] }
+ { cc<= [ src2 src1 compare call( a b -- ) label JAE ] }
+ { cc> [ src1 src2 compare call( a b -- ) label JA ] }
+ { cc>= [ src1 src2 compare call( a b -- ) label JAE ] }
+ { cc= [ src1 src2 compare call( a b -- ) label %jump-float= ] }
+ { cc<> [ src1 src2 compare call( a b -- ) label JNE ] }
+ { cc<>= [ src1 src2 compare call( a b -- ) label JNP ] }
+ { cc/< [ src2 src1 compare call( a b -- ) label JBE ] }
+ { cc/<= [ src2 src1 compare call( a b -- ) label JB ] }
+ { cc/> [ src1 src2 compare call( a b -- ) label JBE ] }
+ { cc/>= [ src1 src2 compare call( a b -- ) label JB ] }
+ { cc/= [ src1 src2 compare call( a b -- ) label %jump-float/= ] }
+ { cc/<> [ src1 src2 compare call( a b -- ) label JE ] }
+ { cc/<>= [ src1 src2 compare call( a b -- ) label JP ] }
} case ;
enable-min/max
] [
&postgresql-free
] if
- ] [ ] with-out-parameters memory>byte-array
+ ] with-out-parameters memory>byte-array
] with-destructors
] [
drop pq-get-is-null nip [ f ] [ B{ } clone ] if
: sqlite-open ( path -- db )
normalize-path
- { void* } [ sqlite3_open sqlite-check-result ] [ ]
+ { void* } [ sqlite3_open sqlite-check-result ]
with-out-parameters ;
: sqlite-close ( db -- )
: sqlite-prepare ( db sql -- handle )
utf8 encode dup length
{ void* void* }
- [ sqlite3_prepare_v2 sqlite-check-result ] [ drop ]
- with-out-parameters ;
+ [ sqlite3_prepare_v2 sqlite-check-result ]
+ with-out-parameters drop ;
: sqlite-bind-parameter-index ( handle name -- index )
sqlite3_bind_parameter_index ;
dup search dup lexical? [ nip ] [ drop ] if ;
: scan-string-param ( -- name/param )
- scan >string-param ;
+ scan-token >string-param ;
: scan-c-type-param ( -- c-type/param )
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences db.tuples alarms calendar db fry
+USING: kernel sequences db.tuples timers calendar db fry
furnace.db
furnace.cache
furnace.asides
: expire-state ( class -- )
new
- -1/0. system-micros [a,b] >>expires
+ -1/0. gmt timestamp>micros [a,b] >>expires
delete-tuples ;
TUPLE: server-state-manager < filter-responder timeout ;
USING: assocs kernel math.intervals math.parser namespaces
strings random accessors quotations hashtables sequences
continuations fry calendar combinators combinators.short-circuit
-destructors alarms io.sockets db db.tuples db.types
+destructors io.sockets db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
furnace.cache furnace.scopes furnace.utilities ;
IN: furnace.sessions
: query-pointer ( -- x y buttons )
dpy get dup XDefaultRootWindow
{ int int int int int int int }
- [ XQueryPointer drop ] [ ] with-out-parameters
+ [ XQueryPointer drop ] with-out-parameters
[ 4 ndrop ] 3dip ;
SYMBOL: mouse-reset?
! Copyright (C) 2009 Anton Gorenko.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.enums alien.parser arrays
-assocs classes.parser classes.struct combinators
-combinators.short-circuit definitions effects fry gir.common gir.types
-kernel locals math.parser namespaces parser quotations sequences
-sequences.generalizations vocabs.parser words words.constant ;
+USING: accessors alien alien.c-types alien.parser arrays
+classes.parser classes.struct combinators combinators.short-circuit
+definitions effects fry gir.common gir.types kernel math.parser
+namespaces parser quotations sequences sequences.generalizations words
+words.constant ;
IN: gir.ffi
: string>c-type ( str -- c-type )
} case ;
: define-ffi-enum ( enum -- word )
- [ c-type>> (CREATE-C-TYPE) dup ]
[
members>> [
[ c-identifier>> create-in ]
- [ value>> ] bi 2array
- ] map
- ] bi int swap define-enum ;
+ [ value>> ] bi define-constant
+ ] each
+ ] [ c-type>> (CREATE-C-TYPE) [ int swap typedef ] keep ] bi ;
: define-ffi-enums ( enums -- )
[ define-ffi-enum ] define-each ;
[ drop { } ] tri <struct-slot-spec>
] map ;
-! Сделать для всех типов создание DEFER:
: define-ffi-record-defer ( record -- word )
c-type>> create-in void* swap [ typedef ] keep ;
: define-ffi-interfaces ( interfaces -- )
[ define-ffi-interface ] define-each ;
-! Доделать
: define-ffi-interface-content ( interface -- )
{
[ methods>> define-ffi-functions ]
--- /dev/null
+Joe Groff\r
--- /dev/null
+! (c)2010 Joe Groff bsd license\r
+USING: assocs hashtables.identity kernel literals tools.test ;\r
+IN: hashtables.identity.tests\r
+\r
+CONSTANT: the-real-slim-shady "marshall mathers"\r
+\r
+CONSTANT: will\r
+ IH{\r
+ { $ the-real-slim-shady t }\r
+ { "marshall mathers" f }\r
+ }\r
+\r
+: please-stand-up ( assoc key -- value )\r
+ swap at ;\r
+\r
+[ t ] [ will the-real-slim-shady please-stand-up ] unit-test\r
+[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test\r
+\r
+[ 2 ] [ will assoc-size ] unit-test\r
+[ { { "marshall mathers" f } } ] [\r
+ the-real-slim-shady will clone\r
+ [ delete-at ] [ >alist ] bi\r
+] unit-test\r
+[ t ] [\r
+ t the-real-slim-shady identity-associate\r
+ t the-real-slim-shady identity-associate =\r
+] unit-test\r
+[ f ] [\r
+ t the-real-slim-shady identity-associate\r
+ t "marshall mathers" identity-associate =\r
+] unit-test\r
--- /dev/null
+! (c)2010 Joe Groff bsd license\r
+USING: accessors arrays assocs fry hashtables kernel parser\r
+sequences vocabs.loader ;\r
+IN: hashtables.identity\r
+\r
+TUPLE: identity-wrapper\r
+ { underlying read-only } ;\r
+C: <identity-wrapper> identity-wrapper\r
+\r
+M: identity-wrapper equal?\r
+ over identity-wrapper?\r
+ [ [ underlying>> ] bi@ eq? ]\r
+ [ 2drop f ] if ; inline\r
+\r
+M: identity-wrapper hashcode*\r
+ nip underlying>> identity-hashcode ; inline\r
+\r
+TUPLE: identity-hashtable\r
+ { underlying hashtable read-only } ;\r
+\r
+: <identity-hashtable> ( n -- ihash )\r
+ <hashtable> identity-hashtable boa ; inline\r
+\r
+<PRIVATE\r
+: identity@ ( key ihash -- ikey hash )\r
+ [ <identity-wrapper> ] [ underlying>> ] bi* ; inline\r
+PRIVATE>\r
+\r
+M: identity-hashtable at*\r
+ identity@ at* ; inline\r
+\r
+M: identity-hashtable clear-assoc\r
+ underlying>> clear-assoc ; inline\r
+\r
+M: identity-hashtable delete-at\r
+ identity@ delete-at ; inline\r
+\r
+M: identity-hashtable assoc-size\r
+ underlying>> assoc-size ; inline\r
+\r
+M: identity-hashtable set-at\r
+ identity@ set-at ; inline\r
+\r
+: identity-associate ( value key -- hash )\r
+ 2 <identity-hashtable> [ set-at ] keep ; inline\r
+\r
+M: identity-hashtable >alist\r
+ underlying>> >alist [ [ first underlying>> ] [ second ] bi 2array ] map ;\r
+ \r
+M: identity-hashtable clone\r
+ underlying>> clone identity-hashtable boa ; inline\r
+\r
+M: identity-hashtable equal?\r
+ over identity-hashtable? [ [ underlying>> ] bi@ = ] [ 2drop f ] if ;\r
+\r
+: >identity-hashtable ( assoc -- ihashtable )\r
+ dup assoc-size <identity-hashtable> [ '[ swap _ set-at ] assoc-each ] keep ;\r
+\r
+SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ;\r
+\r
+{ "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when\r
+{ "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when\r
--- /dev/null
+USING: hashtables.identity mirrors ;\r
+IN: hashtables.identity.mirrors\r
+\r
+M: identity-hashtable make-mirror ;\r
--- /dev/null
+! (c)2010 Joe Groff bsd license\r
+USING: assocs continuations hashtables.identity kernel\r
+namespaces prettyprint.backend prettyprint.config\r
+prettyprint.custom ;\r
+IN: hashtables.identity.prettyprint\r
+\r
+M: identity-hashtable >pprint-sequence >alist ;\r
+M: identity-hashtable pprint-delims drop \ IH{ \ } ;\r
+\r
+M: identity-hashtable pprint*\r
+ nesting-limit inc\r
+ [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;\r
--- /dev/null
+Hashtables keyed by object identity (eq?) rather than by logical value (=)\r
: :lint-failures ( -- ) lint-failures get values errors. ;
-: unlinked-words ( words -- seq )
- all-word-help [ article-parent not ] filter ;
+: unlinked-words ( vocab -- seq )
+ words all-word-help [ article-parent not ] filter ;
: linked-undocumented-words ( -- seq )
all-words
[ "HTTP/" write version>> write crlf ]
tri ;
-: url-host ( url -- string )
- [ host>> ] [ port>> ] bi dup "http" protocol-port =
- [ drop ] [ ":" swap number>string 3append ] if ;
-
: set-host-header ( request header -- request header )
- over url>> url-host "host" pick set-at ;
+ over url>> host>> "host" pick set-at ;
: set-cookie-header ( header cookies -- header )
unparse-cookie "cookie" pick set-at ;
{ $notes "Instead of using this word, it is better to use " { $vocab-link "furnace.actions" } " and the associated validation machinery, which allows you to access values using " { $link "html.forms.values" } " words." } ;
ARTICLE: "http.server.requests" "HTTP request variables"
-"The following variables are set by the HTTP server at the beginning of a request."
+"The following variables are set by the HTTP server at the beginning of a request. Responder implementations may access these variables."
{ $subsections
request
url
- post-request?
responder-nesting
params
}
"Utility words:"
{ $subsections
+ post-request?
param
set-param
request-params
}
-"Additional vocabularies may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
+"Additional variables may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
ARTICLE: "http.server.responders" "HTTP server responders"
+"Responders process requests and output " { $link "http.responses" } ". To implement a responder, define a new class and implement a method on the following generic word:"
+{ $subsections call-responder* }
"The HTTP server dispatches requests to a main responder:"
{ $subsections main-responder }
-"The main responder may in turn dispatch it a subordinate dispatcher, and so on."
-$nl
-"Responders process requests and output " { $link "http.responses" } "; concretely are instances of classes which implement a generic word:"
-{ $subsections call-responder* }
-"To actually call a subordinate responder, use the following word instead:"
+"The main responder may in turn dispatch it a subordinate dispatcher, and so on. To call a subordinate responder, use the following word:"
{ $subsections call-responder }
"A simple implementation of a responder which always outputs the same response:"
{ $subsections
trivial-responder
<trivial-responder>
}
-{ $vocab-subsection "Furnace actions" "furnace.actions" }
-"In particular, writing new responders by hand is rarely necessary, because in most cases it is easier to use " { $vocab-link "furnace.actions" } " instead." ;
+"Writing new responders by hand is rarely necessary, because in most cases it is easier to use " { $vocab-link "furnace.actions" } " instead."
+{ $vocab-subsection "Furnace actions" "furnace.actions" } ;
ARTICLE: "http.server.variables" "HTTP server variables"
"The following global variables control the behavior of the HTTP server. Both are off by default."
io.encodings.binary
io.streams.limited
io.streams.string
+io.streams.throwing
io.servers.connection
io.timeouts
io.crlf
html.streams
html
mime.types
+math.order
xml.writer ;
FROM: mime.multipart => parse-multipart ;
IN: http.server
: read-multipart-data ( request -- mime-parts )
[ "content-type" header ]
[ "content-length" header string>number ] bi
- unlimited-input
- upload-limit get stream-throws limit-input
- stream-eofs limit-input
+ upload-limit get min limited-input
binary decode-input
parse-multipart-form-data parse-multipart ;
-
+
: read-content ( request -- bytes )
"content-length" header string>number read ;
] when ;
: extract-host ( request -- request )
- [ ] [ url>> ] [ "host" header parse-host ] tri
- [ >>host ] [ >>port ] bi*
- drop ;
+ [ ] [ url>> ] [ "host" header dup [ url-decode ] when ] tri
+ >>host drop ;
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookie >>cookies ] when* ;
SYMBOL: request-limit
-64 1024 * request-limit set-global
+request-limit [ 64 1024 * ] initialize
M: http-server handle-client*
drop [
- request-limit get stream-throws limit-input
+ request-limit get limited-input
?refresh-all
[ read-request ] ?benchmark
[ do-request ] ?benchmark
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays byte-arrays columns
-combinators compression.run-length endian fry grouping images
-images.loader images.normalization io io.binary
-io.encodings.8-bit.latin1 io.encodings.binary
-io.encodings.string io.files io.streams.limited kernel locals
-macros math math.bitwise math.functions namespaces sequences
-specialized-arrays summary ;
+USING: accessors alien.c-types arrays byte-arrays combinators
+compression.run-length fry grouping images images.loader
+images.normalization io io.binary io.encodings.8-bit.latin1
+io.encodings.string kernel math math.bitwise sequences
+specialized-arrays summary io.streams.throwing ;
QUALIFIED-WITH: bitstreams b
SPECIALIZED-ARRAYS: uint ushort ;
IN: images.bitmap
: load-bitmap ( stream -- loading-bitmap )
[
- \ loading-bitmap new
- parse-file-header [ >>file-header ] [ ] bi magic>> {
- { "BM" [
- dup file-header>> header-length>> parse-header >>header
- parse-color-palette
- parse-color-data
- ] }
- ! { "BA" [ parse-os2-bitmap-array ] }
- ! { "CI" [ parse-os2-color-icon ] }
- ! { "CP" [ parse-os2-color-pointer ] }
- ! { "IC" [ parse-os2-icon ] }
- ! { "PT" [ parse-os2-pointer ] }
- [ unsupported-bitmap-file ]
- } case
+ [
+ \ loading-bitmap new
+ parse-file-header [ >>file-header ] [ ] bi magic>> {
+ { "BM" [
+ dup file-header>> header-length>> parse-header >>header
+ parse-color-palette
+ parse-color-data
+ ] }
+ ! { "BA" [ parse-os2-bitmap-array ] }
+ ! { "CI" [ parse-os2-color-icon ] }
+ ! { "CP" [ parse-os2-color-pointer ] }
+ ! { "IC" [ parse-os2-icon ] }
+ ! { "PT" [ parse-os2-pointer ] }
+ [ unsupported-bitmap-file ]
+ } case
+ ] throw-on-eof
] with-input-stream ;
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
+++ /dev/null
-Doug Coleman
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays byte-arrays combinators
-compression.run-length fry grouping images images.loader io
-io.binary io.encodings.binary
-io.encodings.string io.streams.limited kernel math math.bitwise
-io.encodings.8-bit.latin1 sequences specialized-arrays summary images.bitmap ;
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators
-grouping compression.huffman images fry
-images.processing io io.binary io.encodings.binary io.files
-io.streams.byte-array kernel locals math math.bitwise
-math.constants math.functions math.matrices math.order
-math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep images.loader io.streams.limited ;
-IN: images.jpeg
-
+compression.huffman fry grouping images images.loader
+images.processing io io.binary io.encodings.binary
+io.streams.byte-array io.streams.limited io.streams.throwing
+kernel locals math math.bitwise math.blas.matrices
+math.blas.vectors math.constants math.functions math.matrices
+math.order math.vectors memoize namespaces sequences
+sequences.deep ;
QUALIFIED-WITH: bitstreams bs
+IN: images.jpeg
SINGLETON: jpeg-image
] with-byte-reader ;
: decode-huff-table ( chunk -- )
- data>> [ binary <byte-reader> ] [ length ] bi
- stream-throws limit
- [
- [ input-stream get [ count>> ] [ limit>> ] bi < ]
+ data>> [ binary <byte-reader> ] [ length ] bi limit-stream [
[
- read4/4 swap 2 * +
- 16 read
- dup [ ] [ + ] map-reduce read
- binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
- swap jpeg> huff-tables>> set-nth
- ] while
- ] with-input-stream* ;
+ [ input-stream get stream>> [ count>> ] [ limit>> ] bi < ]
+ [
+ read4/4 swap 2 * +
+ 16 read
+ dup [ ] [ + ] map-reduce read
+ binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
+ swap jpeg> huff-tables>> set-nth
+ ] while
+ ] with-input-stream*
+ ] stream-throw-on-eof ;
: decode-scan ( chunk -- )
data>>
: idct-factor ( b -- b' ) dct-matrix v.m ;
-USE: math.blas.vectors
-USE: math.blas.matrices
-
MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: V.M ( x A -- x.A ) Mtranspose swap M.V ;
: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
[
parse-marker { SOI } = [ not-a-jpeg-image ] unless
parse-headers
- unlimited-input contents <loading-jpeg>
+ contents <loading-jpeg>
] with-input-stream ;
PRIVATE>
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs byte-arrays combinators images
-io.encodings.binary io.files io.pathnames io.streams.byte-array
-io.streams.limited kernel namespaces sequences splitting
-strings unicode.case ;
+USING: assocs byte-arrays io.encodings.binary io.files
+io.pathnames io.streams.byte-array io.streams.limited
+io.streams.throwing kernel namespaces sequences strings
+unicode.case fry ;
IN: images.loader
ERROR: unknown-image-extension extension ;
[ unknown-image-extension ] unless ;
: open-image-file ( path -- stream )
- binary stream-throws <limited-file-reader> ;
+ binary <limited-file-reader> ;
PRIVATE>
: load-image ( path -- image )
[ open-image-file ] [ image-class ] bi load-image* ;
-M: byte-array load-image*
- [
- [ binary <byte-reader> ]
- [ length stream-throws <limited-stream> ] bi
- ] dip stream>image ;
+M: object load-image* stream>image ;
-M: limited-stream load-image* stream>image ;
+M: byte-array load-image*
+ [ binary <byte-reader> ] dip stream>image ;
M: string load-image* [ open-image-file ] dip stream>image ;
USING: accessors arrays ascii bit-arrays byte-arrays combinators
continuations grouping images images.loader io io.encodings.ascii
io.encodings.string kernel locals make math math.functions math.parser
-sequences ;
+sequences io.streams.throwing ;
IN: images.pbm
SINGLETON: pbm-image
PRIVATE>
M: pbm-image stream>image
- drop [ read-pbm ] with-input-stream ;
+ drop [ [ read-pbm ] throw-on-eof ] with-input-stream ;
M: pbm-image image>stream
drop {
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types ascii combinators images images.loader
io io.encodings.ascii io.encodings.string kernel locals make math
-math.parser sequences specialized-arrays ;
+math.parser sequences specialized-arrays io.streams.throwing ;
SPECIALIZED-ARRAY: ushort
IN: images.pgm
wide [ ushort-components ] [ ubyte-components ] if >>component-type ;
M: pgm-image stream>image
- drop [ read-pgm ] with-input-stream ;
+ drop [ [ read-pgm ] throw-on-eof ] with-input-stream ;
M: pgm-image image>stream
drop {
compression.inflate fry grouping images images.loader io
io.binary io.encodings.ascii io.encodings.string kernel locals
math math.bitwise math.ranges sequences sorting assocs
-math.functions math.order byte-arrays ;
+math.functions math.order byte-arrays io.streams.throwing ;
QUALIFIED-WITH: bitstreams bs
IN: images.png
: load-png ( stream -- loading-png )
[
- <loading-png>
- read-png-header
- read-png-chunks
- parse-ihdr-chunk
+ [
+ <loading-png>
+ read-png-header
+ read-png-chunks
+ parse-ihdr-chunk
+ ] throw-on-eof
] with-input-stream ;
M: png-image stream>image
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii combinators images images.loader io
io.encodings.ascii io.encodings.string kernel locals make math
-math.parser sequences ;
+math.parser sequences io.streams.throwing ;
IN: images.ppm
SINGLETON: ppm-image
ubyte-components >>component-type ;
M: ppm-image stream>image
- drop [ read-ppm ] with-input-stream ;
+ drop [ [ read-ppm ] throw-on-eof ] with-input-stream ;
M: ppm-image image>stream
drop {
USING: accessors images images.loader io io.binary kernel
locals math sequences io.encodings.ascii io.encodings.string
calendar math.ranges math.parser colors arrays hashtables
-ui.pixel-formats combinators continuations ;
+ui.pixel-formats combinators continuations io.streams.throwing ;
IN: images.tga
SINGLETON: tga-image
ubyte-components >>component-type ;
M: tga-image stream>image
- drop [ read-tga ] with-input-stream ;
+ drop [ [ read-tga ] throw-on-eof ] with-input-stream ;
M: tga-image image>stream
drop
io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack sequences
strings math.vectors specialized-arrays locals
-images.loader ;
+images.loader io.streams.throwing ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: images.tiff
: with-tiff-endianness ( loading-tiff quot -- )
[ dup endianness>> ] dip with-endianness ; inline
-: load-tiff-ifds ( stream -- loading-tiff )
- [
- <loading-tiff>
- read-header [
- dup ifd-offset>> read-ifds
- process-ifds
- ] with-tiff-endianness
- ] with-input-stream* ;
+: load-tiff-ifds ( -- loading-tiff )
+ <loading-tiff>
+ read-header [
+ dup ifd-offset>> read-ifds
+ process-ifds
+ ] with-tiff-endianness ;
: process-chunky-ifd ( ifd -- )
read-strips
: process-tif-ifds ( loading-tiff -- )
ifds>> [ process-ifd ] each ;
-: load-tiff ( stream -- loading-tiff )
- [ load-tiff-ifds dup ]
- [
- [ [ 0 seek-absolute ] dip stream-seek ]
- [
- [
- [ process-tif-ifds ] with-tiff-endianness
- ] with-input-stream
- ] bi
- ] bi ;
+: load-tiff ( -- loading-tiff )
+ load-tiff-ifds dup
+ 0 seek-absolute seek-input
+ [ process-tif-ifds ] with-tiff-endianness ;
! tiff files can store several images -- we just take the first for now
M: tiff-image stream>image ( stream tiff-image -- image )
- drop load-tiff tiff>image ;
+ drop [ [ load-tiff tiff>image ] throw-on-eof ] with-input-stream ;
{ "tif" "tiff" } [ tiff-image register-image-class ] each
nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
master-completion-port get-global
{ int void* pointer: OVERLAPPED }
- [ timeout GetQueuedCompletionStatus zero? ] [ ] with-out-parameters
+ [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
:> ( error? bytes key overlapped )
bytes overlapped error? ;
: (open-process-token) ( handle -- handle )
flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY }
{ PHANDLE }
- [ OpenProcessToken win32-error=0/f ] [ ]
+ [ OpenProcessToken win32-error=0/f ]
with-out-parameters ;
: open-process-token ( -- handle )
TUPLE: windows-file-info < file-info attributes ;
: get-compressed-file-size ( path -- n )
- { DWORD } [ GetCompressedFileSize ] [ ] with-out-parameters
+ { DWORD } [ GetCompressedFileSize ] with-out-parameters
over INVALID_FILE_SIZE = [ win32-error-string throw ] [ >64bit ] if ;
: set-windows-size-on-disk ( file-info path -- file-info )
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
{ { ushort path-length } DWORD DWORD DWORD { ushort path-length } }
[ [ path-length ] 4dip path-length GetVolumeInformation win32-error=0/f ]
- [ [ utf16n alien>string ] 4dip utf16n alien>string ]
- with-out-parameters ;
+ with-out-parameters
+ [ utf16n alien>string ] 4dip utf16n alien>string ;
: file-system-space ( normalized-path -- available-space total-space free-space )
{ ULARGE_INTEGER ULARGE_INTEGER ULARGE_INTEGER }
- [ GetDiskFreeSpaceEx win32-error=0/f ] [ ]
+ [ GetDiskFreeSpaceEx win32-error=0/f ]
with-out-parameters ;
: calculate-file-system-info ( file-system-info -- file-system-info' )
: volume>paths ( string -- array )
{ { ushort names-buf-length } uint }
[ [ names-buf-length ] dip GetVolumePathNamesForVolumeName win32-error=0/f ]
- [ head utf16n alien>string { CHAR: \0 } split ]
- with-out-parameters ;
+ with-out-parameters
+ head utf16n alien>string { CHAR: \0 } split ;
: find-first-volume ( -- string handle )
{ { ushort path-length } }
[ path-length FindFirstVolume dup win32-error=0/f ]
- [ utf16n alien>string ]
- with-out-parameters swap ;
+ with-out-parameters utf16n alien>string swap ;
: find-next-volume ( handle -- string/f )
{ { ushort path-length } }
- [ path-length FindNextVolume ]
- [
- swap 0 = [
- GetLastError ERROR_NO_MORE_FILES =
- [ drop f ] [ win32-error-string throw ] if
- ] [ utf16n alien>string ] if
- ] with-out-parameters ;
+ [ path-length FindNextVolume ] with-out-parameters
+ swap 0 = [
+ GetLastError ERROR_NO_MORE_FILES =
+ [ drop f ] [ win32-error-string throw ] if
+ ] [ utf16n alien>string ] if ;
: find-volumes ( -- array )
find-first-volume
normalize-path open-read &dispose handle>>
{ FILETIME FILETIME FILETIME }
[ GetFileTime win32-error=0/f ]
- [ [ FILETIME>timestamp >local-time ] tri@ ]
with-out-parameters
+ [ FILETIME>timestamp >local-time ] tri@
] with-destructors ;
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators continuations fry io io.backend
io.directories io.directories.hierarchy io.files io.pathnames
-kernel math math.bitwise math.parser namespaces random
+kernel locals math math.bitwise math.parser namespaces random
sequences system vocabs.loader ;
IN: io.files.unique
: temporary-file ( -- path ) "" unique-file ;
-: with-working-directory ( path quot -- )
- over make-directories
- dupd '[ _ _ with-temporary-directory ] with-directory ; inline
+:: cleanup-unique-working-directory ( quot -- )
+ unique-directory :> path
+ path [ path quot with-temporary-directory ] with-directory
+ path delete-tree ; inline
{
{ [ os unix? ] [ "io.files.unique.unix" ] }
dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
M: unix wait-for-processes ( -- ? )
- { int } [ -1 swap WNOHANG waitpid ] [ ] with-out-parameters
+ { int } [ -1 swap WNOHANG waitpid ] with-out-parameters
swap dup 0 <= [
2drop t
] [
: exit-code ( process -- n )
hProcess>>
- { DWORD } [ GetExitCodeProcess ] [ ] with-out-parameters
+ { DWORD } [ GetExitCodeProcess ] with-out-parameters
swap win32-error=0/f ;
: process-exited ( process -- )
'[ _ call( -- result ) ] with-streams*
] with-destructors ;
-: <pipes> ( n -- pipes )
+GENERIC: <pipes> ( obj -- pipes )
+
+M: integer <pipes> ( n -- pipes )
[
[ (pipe) |dispose ] replicate
T{ pipe } [ prefix ] [ suffix ] bi
2 <clumps>
] with-destructors ;
+M: sequence <pipes>
+ [ { } ] [ length 1 - <pipes> ] if-empty ;
+
PRIVATE>
: run-pipeline ( seq -- results )
- [ length dup zero? [ drop { } ] [ 1 - <pipes> ] if ] keep
+ [ <pipes> ] keep
[
[ [ first in>> ] [ second out>> ] bi ] dip
run-pipeline-element
byte-vectors system io.encodings math.order io.backend
continuations classes byte-arrays namespaces splitting grouping
dlists alien alien.c-types assocs io.encodings.binary summary
-accessors destructors combinators fry specialized-arrays ;
+accessors destructors combinators fry specialized-arrays
+locals ;
SPECIALIZED-ARRAY: uchar
IN: io.ports
[ nip ] [ buffer>> buffer-capacity <= ] 2bi
[ drop ] [ stream-flush ] if ; inline
-M: output-port stream-element-type stream>> stream-element-type ; inline
+M: output-port stream-element-type
+ stream>> stream-element-type ; inline
M: output-port stream-write1
dup check-disposed
HOOK: (wait-to-write) io-backend ( port -- )
+: port-flush ( port -- )
+ dup buffer>> buffer-empty?
+ [ drop ] [ dup (wait-to-write) port-flush ] if ;
+
+M: output-port stream-flush ( port -- )
+ [ check-disposed ] [ port-flush ] bi ;
+
HOOK: tell-handle os ( handle -- n )
+
HOOK: seek-handle os ( n seek-type handle -- )
-M: buffered-port stream-tell ( stream -- n )
+M: input-port stream-tell ( stream -- n )
+ [ check-disposed ]
+ [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi - ] bi ;
+
+M: output-port stream-tell ( stream -- n )
[ check-disposed ]
- [ handle>> tell-handle ]
- [ [ buffer>> size>> - 0 max ] [ buffer>> pos>> ] bi + ] tri ;
+ [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi + ] bi ;
+
+:: do-seek-relative ( n seek-type stream -- n seek-type stream )
+ ! seek-relative needs special handling here, because of the
+ ! buffer.
+ seek-type seek-relative eq?
+ [ n stream stream-tell + seek-absolute ] [ n seek-type ] if
+ stream ;
M: input-port stream-seek ( n seek-type stream -- )
+ do-seek-relative
[ check-disposed ]
[ buffer>> 0 swap buffer-reset ]
[ handle>> seek-handle ] tri ;
M: output-port stream-seek ( n seek-type stream -- )
+ do-seek-relative
[ check-disposed ]
[ stream-flush ]
[ handle>> seek-handle ] tri ;
M: object shutdown drop ;
-: port-flush ( port -- )
- dup buffer>> buffer-empty?
- [ drop ] [ dup (wait-to-write) port-flush ] if ;
-
-M: output-port stream-flush ( port -- )
- [ check-disposed ] [ port-flush ] bi ;
-
M: output-port dispose*
[
{
<client>
with-client
}
+"The local address of a client socket can be controlled with this word:"
+{ $subsections
+ with-local-address
+}
"Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
{ $subsections
<server>
HELP: resolve-host
{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } }
{ $description "Resolves host names to IP addresses." } ;
+
+HELP: with-local-address
+{ $values { "addr" "an " { $link inet4 } " or " { $link inet6 } " address specifier" } { "quot" quotation } }
+{ $description "Client sockets opened within the scope of the quotation passed to this combinator will have their local address bound to the given address." }
+{ $examples
+ { "Binds the local address of a newly created client socket within the quotation to 127.0.0.1."
+ "This ensures that all traffic originates from the given address (the port is choosen by the TCP stack)." }
+ { $code "\"127.0.0.1\" 0 <inet4> [ ] with-local-address" }
+ $nl
+ { "Binds the local address of a newly created client socket within the quotation to the local address 192.168.0.1 and the local port 23000. "
+ "Be aware that you can only have one client socket with the same local address at a time or else an I/O error (\"address already in use\") will be thrown."
+ }
+ { $code "\"192.168.0.1\" 23000 <inet4> [ ] with-local-address" }
+} ;
WSAIoctl SOCKET_ERROR = [
winsock-error-string throw
] when
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
TUPLE: ConnectEx-args port
s name namelen lpSendBuffer dwSendDataLength
HELP: <limited-stream>
{ $values
- { "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
+ { "stream" "an input stream" } { "limit" integer }
{ "stream'" "an input stream" }
}
-{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit } " or " { $link limit-input } "." } ;
+{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit-stream } " or " { $link limited-input } "." } ;
-HELP: limit
+HELP: limit-stream
{ $values
- { "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
+ { "stream" "an input stream" } { "limit" integer }
{ "stream'" "a stream" }
}
{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." }
-{ $examples "Throwing an exception:"
- { $example
- "USING: continuations io io.streams.limited io.streams.string"
- "kernel prettyprint ;"
- "["
- " \"123456\" <string-reader> 3 stream-throws limit"
- " 100 swap stream-read ."
- "] [ ] recover ."
-"""T{ limit-exceeded
- { n 1 }
- { stream
- T{ limited-stream
- { stream
- T{ string-reader
- { underlying "123456" }
- { i 3 }
- }
- }
- { mode stream-throws }
- { count 4 }
- { limit 3 }
- }
- }
-}"""
- }
- "Returning " { $link f } " on exhaustion:"
+{ $examples
+ "Limiting a longer stream to length three:"
{ $example
"USING: accessors continuations io io.streams.limited"
"io.streams.string kernel prettyprint ;"
- "\"123456\" <string-reader> 3 stream-eofs limit"
+ "\"123456\" <string-reader> 3 limit-stream"
"100 swap stream-read ."
"\"123\""
}
} ;
-HELP: unlimited
-{ $values
- { "stream" "an input stream" }
- { "stream'" "a stream" }
-}
-{ $description "Returns the underlying stream of a limited stream." } ;
-
HELP: limited-stream
{ $values
{ "value" "a limited-stream class" }
}
{ $description "Limited streams wrap other streams, changing their behavior to throw an exception or return " { $link f } " upon exhaustion." } ;
-HELP: limit-input
-{ $values
- { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
-}
+HELP: limited-input
+{ $values { "limit" integer } }
{ $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ;
-HELP: unlimited-input
-{ $description "Returns the underlying stream of the limited-stream stored in " { $link input-stream } "." } ;
-
-HELP: stream-eofs
-{ $values
- { "value" { $link stream-throws } " or " { $link stream-eofs } }
-}
-{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will return " { $link f } " upon exhaustion." } ;
-
-HELP: stream-throws
-{ $values
- { "value" { $link stream-throws } " or " { $link stream-eofs } }
-}
-{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will throw " { $link limit-exceeded } " upon exhaustion." } ;
-
-{ stream-eofs stream-throws } related-words
-
ARTICLE: "io.streams.limited" "Limited input streams"
"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end. Limiting a non-seekable stream keeps a byte count and triggers the end-of-stream behavior when this byte count has been reached. However, limiting a seekable stream creates a window of bytes that supports seeking and re-reading of bytes in that window." $nl
"Wrap a stream in a limited stream:"
-{ $subsections limit }
+{ $subsections limited-stream }
"Wrap the current " { $link input-stream } " in a limited stream:"
-{ $subsections limit-input }
-"Unlimits a limited stream:"
-{ $subsections unlimited }
-"Unlimits the current " { $link input-stream } ":"
-{ $subsections unlimited-input }
-"Make a limited stream throw an exception on exhaustion:"
-{ $subsections stream-throws }
-"Make a limited stream return " { $link f } " on exhaustion:"
-{ $subsections stream-eofs } ;
+{ $subsections limited-input } ;
ABOUT: "io.streams.limited"
ascii encode binary <byte-reader> "data" set
] unit-test
-[ ] [ "data" get 24 stream-throws <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 24 <limited-stream> "limited" set ] unit-test
[ CHAR: h ] [ "limited" get stream-read1 ] unit-test
[ "how " ] [ 4 "decoded" get stream-read ] unit-test
-[ "decoded" get stream-readln ] [ limit-exceeded? ] must-fail-with
+[ "are you " ] [ "decoded" get stream-readln ] unit-test
+
+[ f ] [ "decoded" get stream-readln ] unit-test
+
[ ] [
"abc\ndef\nghi"
ascii encode binary <byte-reader> "data" set
] unit-test
-[ ] [ "data" get 7 stream-throws <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 4 <limited-stream> "limited" set ] unit-test
-[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
+[ "abc" CHAR: \n ]
+[ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
-[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with
+[ "" f ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
-[ "he" CHAR: l ] [
- B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
- ascii <byte-reader> [
- 5 stream-throws limit-input
- "l" read-until
- ] with-input-stream
-] unit-test
[ CHAR: a ]
-[ "a" <string-reader> 1 stream-eofs <limited-stream> stream-read1 ] unit-test
+[ "a" <string-reader> 1 <limited-stream> stream-read1 ] unit-test
[ "abc" ]
[
- "abc" <string-reader> 3 stream-eofs <limited-stream>
+ "abc" <string-reader> 3 <limited-stream>
4 swap stream-read
] unit-test
[ f ]
[
- "abc" <string-reader> 3 stream-eofs <limited-stream>
+ "abc" <string-reader> 3 <limited-stream>
4 over stream-read drop 10 swap stream-read
] unit-test
-[ t ]
-[
- "abc" <string-reader> 3 stream-eofs limit unlimited
- "abc" <string-reader> =
-] unit-test
-
-[ t ]
-[
- "abc" <string-reader> 3 stream-eofs limit unlimited
- "abc" <string-reader> =
-] unit-test
-
-[ t ]
-[
- [
- "resource:license.txt" utf8 <file-reader> &dispose
- 3 stream-eofs limit unlimited
- "resource:license.txt" utf8 <file-reader> &dispose
- [ decoder? ] both?
- ] with-destructors
-] unit-test
-
-[ "HELL" ] [
- "HELLO"
- [ f stream-throws limit-input 4 read ]
- with-string-reader
-] unit-test
-
-
-[ "asdf" ] [
- "asdf" <string-reader> 2 stream-eofs <limited-stream> [
- unlimited-input contents
- ] with-input-stream
-] unit-test
-
-[ 4 ] [
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input tell-input
- ] with-input-stream
-] unit-test
-
-[
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input
- 4 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input
- -2 seek-relative
- 2 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[
- "abcdefgh" <string-reader> [
- 4 seek-relative seek-input
- 2 stream-throws limit-input
- -2 seek-relative seek-input
- 2 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[ "ef" ] [
- "abcdefgh" <string-reader> [
- 4 seek-relative seek-input
- 2 stream-throws limit-input
- 4 seek-absolute seek-input
- 2 read
- ] with-input-stream
-] unit-test
-
-[ "ef" ] [
- "abcdefgh" <string-reader> [
- 4 seek-absolute seek-input
- 2 stream-throws limit-input
- 2 seek-absolute seek-input
- 4 seek-absolute seek-input
- 2 read
- ] with-input-stream
-] unit-test
-
-! stream-throws, pipes are duplex and not seekable
-[ "as" ] [
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- 2 swap stream-read
-] unit-test
-
-[
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- 3 swap stream-read
-] [
- limit-exceeded?
-] must-fail-with
-
-! stream-eofs, pipes are duplex and not seekable
+! pipes are duplex and not seekable
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
2 swap stream-read
] unit-test
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
! test seeking on limited unseekable streams
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
2 swap stream-read
] unit-test
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
-
-[
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- 2 seek-absolute rot in>> stream-seek
-] must-fail
-
-[
- "as"
-] [
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- [ 2 seek-absolute rot in>> stream-seek ] [ drop ] recover
- 2 swap stream-read
-] unit-test
-
-[ 7 ] [
- image binary stream-throws <limited-file-reader> [
- 7 read drop
- tell-input
- ] with-input-stream
-] unit-test
-
-[ 70000 ] [
- image binary stream-throws <limited-file-reader> [
- 70000 read drop
- tell-input
- ] with-input-stream
-] unit-test
namespaces sequences ;
IN: io.streams.limited
-TUPLE: limited-stream
- stream mode
- count limit
- current start stop ;
+TUPLE: limited-stream stream count limit current start stop ;
-SINGLETONS: stream-throws stream-eofs ;
-
-: <limited-stream> ( stream limit mode -- stream' )
+: <limited-stream> ( stream limit -- stream' )
limited-stream new
- swap >>mode
swap >>limit
swap >>stream
0 >>count ;
-: <limited-file-reader> ( path encoding mode -- stream' )
- [
- [ <file-reader> ]
- [ drop file-info size>> ] 2bi
- ] dip <limited-stream> ;
-
-GENERIC# limit 2 ( stream limit mode -- stream' )
-
-M: decoder limit ( stream limit mode -- stream' )
- [ clone ] 2dip '[ _ _ limit ] change-stream ;
-
-M: object limit ( stream limit mode -- stream' )
- over [ <limited-stream> ] [ 2drop ] if ;
+: <limited-file-reader> ( path encoding -- stream' )
+ [ <file-reader> ]
+ [ drop file-info size>> ] 2bi
+ <limited-stream> ;
-GENERIC: unlimited ( stream -- stream' )
+GENERIC# limit-stream 1 ( stream limit -- stream' )
-M: decoder unlimited ( stream -- stream' )
- [ stream>> ] change-stream ;
+M: decoder limit-stream ( stream limit -- stream' )
+ [ clone ] dip '[ _ limit-stream ] change-stream ;
-M: object unlimited ( stream -- stream' )
- stream>> ;
+M: object limit-stream ( stream limit -- stream' )
+ <limited-stream> ;
-: limit-input ( limit mode -- )
- [ input-stream ] 2dip '[ _ _ limit ] change ;
+: limited-input ( limit -- )
+ [ input-stream ] dip '[ _ limit-stream ] change ;
-: unlimited-input ( -- )
- input-stream [ unlimited ] change ;
-
-: with-unlimited-stream ( stream quot -- )
- [ clone unlimited ] dip call ; inline
-
-: with-limited-stream ( stream limit mode quot -- )
- [ limit ] dip call ; inline
+: with-limited-stream ( stream limit quot -- )
+ [ limit-stream ] dip call ; inline
ERROR: limit-exceeded n stream ;
-ERROR: bad-stream-mode mode ;
-
<PRIVATE
: adjust-current-limit ( n stream -- n' stream )
2dup [ + ] change-current
[ current>> ] [ stop>> ] bi >
[
- dup mode>> {
- { stream-throws [ limit-exceeded ] }
- { stream-eofs [
- dup [ current>> ] [ stop>> ] bi -
- '[ _ - ] dip
- ] }
- [ bad-stream-mode ]
- } case
+ dup [ current>> ] [ stop>> ] bi -
+ '[ _ - ] dip
] when ; inline
: adjust-count-limit ( n stream -- n' stream )
2dup [ + ] change-count
[ count>> ] [ limit>> ] bi >
[
- dup mode>> {
- { stream-throws [ limit-exceeded ] }
- { stream-eofs [
- dup [ count>> ] [ limit>> ] bi -
- '[ _ - ] dip
- dup limit>> >>count
- ] }
- [ bad-stream-mode ]
- } case
+ dup [ count>> ] [ limit>> ] bi -
+ '[ _ - ] dip
+ dup limit>> >>count
] when ; inline
: check-count-bounds ( n stream -- n stream )
: (read-until) ( stream seps buf -- stream seps buf sep/f )
3dup [ [ stream-read1 dup ] dip member-eq? ] dip
- swap [ drop ] [ push (read-until) ] if ;
+ swap [
+ drop
+ ] [
+ over [ push (read-until) ] [ drop ] if
+ ] if ;
:: limited-stream-seek ( n seek-type stream -- )
seek-type {
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.encodings.utf8 io.files io.streams.string
+io.streams.throwing kernel tools.test destructors ;
+IN: io.streams.throwing.tests
+
+[ "asdf" ]
+[
+ "asdf" [ [ 6 read-partial ] throw-on-eof ] with-string-reader
+] unit-test
+
+[
+ "asdf" [ [ 4 read read1 ] throw-on-eof ] with-string-reader
+] [ stream-exhausted? ] must-fail-with
+
+[
+ [
+ "asdf" <string-reader> &dispose [
+ [ 4 swap stream-read ]
+ [ stream-read1 ] bi
+ ] stream-throw-on-eof
+ ] with-destructors
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" [ [ 5 read ] throw-on-eof ] with-string-reader
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" [ [ 4 read 4 read ] throw-on-eof ] with-string-reader
+] [ stream-exhausted? ] must-fail-with
+
+[ "as" "df" ] [
+ "asdf" [ [ 2 read ] throw-on-eof 3 read ] with-string-reader
+] unit-test
+
+[ "as" "df\n" ] [
+ "vocab:io/streams/throwing/asdf.txt" utf8 [
+ [ 2 read ] throw-on-eof 20 read
+ ] with-file-reader
+] unit-test
+
+[ "asdf" "asdf" ] [
+ "asdf" [
+ [ 4 read 0 seek-absolute seek-input 4 read ] throw-on-eof
+ ] with-string-reader
+] unit-test
+
+[
+ "asdf" [ [ 1 seek-absolute seek-input 4 read drop ] throw-on-eof ] with-string-reader
+] [ stream-exhausted? ] must-fail-with
+
+[ "asd" CHAR: f ] [
+ "asdf" [ [ "f" read-until ] throw-on-eof ] with-string-reader
+] unit-test
+
+[
+ "asdf" [ [ "g" read-until ] throw-on-eof ] with-string-reader
+] [ stream-exhausted? ] must-fail-with
+
+[ 1 ] [
+ "asdf" [ [ 1 seek-absolute seek-input tell-input ] throw-on-eof ] with-string-reader
+] unit-test
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors destructors io kernel locals namespaces
+sequences fry ;
+IN: io.streams.throwing
+
+ERROR: stream-exhausted n stream word ;
+
+<PRIVATE
+
+TUPLE: throws-on-eof-stream stream ;
+
+C: <throws-on-eof-stream> throws-on-eof-stream
+
+M: throws-on-eof-stream stream-element-type stream>> stream-element-type ;
+
+M: throws-on-eof-stream dispose stream>> dispose ;
+
+M:: throws-on-eof-stream stream-read1 ( stream -- obj )
+ stream stream>> stream-read1
+ [ 1 stream \ read1 stream-exhausted ] unless* ;
+
+M:: throws-on-eof-stream stream-read ( n stream -- seq )
+ n stream stream>> stream-read
+ dup length n = [ n stream \ read stream-exhausted ] unless ;
+
+M:: throws-on-eof-stream stream-read-partial ( n stream -- seq )
+ n stream stream>> stream-read-partial
+ [ n stream \ read-partial stream-exhausted ] unless* ;
+
+M: throws-on-eof-stream stream-tell
+ stream>> stream-tell ;
+
+M: throws-on-eof-stream stream-seek
+ stream>> stream-seek ;
+
+M: throws-on-eof-stream stream-read-until
+ [ stream>> stream-read-until ]
+ [ '[ length _ \ read-until stream-exhausted ] unless* ] bi ;
+
+PRIVATE>
+
+: stream-throw-on-eof ( ..a stream quot: ( ..a stream' -- ..b ) -- ..b )
+ [ <throws-on-eof-stream> ] dip call ; inline
+
+: throw-on-eof ( ..a quot: ( ..a -- ..b ) -- ..b )
+ [ input-stream get <throws-on-eof-stream> ] dip with-input-stream* ; inline
! Copyright (C) 2008 Slava Pestov, Doug Coleman\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel calendar alarms io io.encodings accessors\r
+USING: kernel calendar timers io io.encodings accessors\r
namespaces fry io.streams.null ;\r
IN: io.timeouts\r
\r
\r
GENERIC: cancel-operation ( obj -- )\r
\r
-: queue-timeout ( obj timeout -- alarm )\r
+: queue-timeout ( obj timeout -- timer )\r
[ '[ _ cancel-operation ] ] dip later ;\r
\r
: with-timeout* ( obj timeout quot -- )\r
- 3dup drop queue-timeout [ nip call ] dip stop-alarm ;\r
+ 3dup drop queue-timeout [ nip call ] dip stop-timer ;\r
inline\r
\r
: with-timeout ( obj quot -- )\r
dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;
: master-port ( -- port )
- MACH_PORT_NULL { uint } [ IOMasterPort mach-error ] [ ] with-out-parameters ;
+ MACH_PORT_NULL { uint } [ IOMasterPort mach-error ] with-out-parameters ;
: io-services-matching-dictionary ( nsdictionary -- iterator )
master-port swap
- { uint } [ IOServiceGetMatchingServices mach-error ] [ ] with-out-parameters ;
+ { uint } [ IOServiceGetMatchingServices mach-error ] with-out-parameters ;
: io-services-matching-service ( service -- iterator )
IOServiceMatching io-services-matching-dictionary ;
: free ( alien -- )
>c-ptr [ delete-malloc ] [ (free) ] bi ;
+FUNCTION: void memset ( void* buf, int char, size_t size ) ;
+
FUNCTION: void memcpy ( void* dst, void* src, ulong size ) ;
FUNCTION: int memcmp ( void* a, void* b, ulong size ) ;
H{ } clone (parse-lambda) ;
: parse-binding ( end -- pair/f )
- scan {
- { [ dup not ] [ unexpected-eof ] }
+ scan-token {
{ [ 2dup = ] [ 2drop f ] }
[ nip scan-object 2array ]
} cond ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: logging.analysis logging.server logging smtp kernel\r
-io.files io.streams.string namespaces make alarms assocs\r
+io.files io.streams.string namespaces make timers assocs\r
io.encodings.utf8 accessors calendar sequences ;\r
QUALIFIED: io.sockets\r
IN: logging.insomniac\r
{ $notes "For clarification, the following two statements are equivalent:" { $code "10 factoradic >permutation" "{ 1 2 0 0 } >permutation" } }
{ $examples { $example "USING: math.combinatorics.private prettyprint ;" "{ 0 0 0 0 } >permutation ." "{ 0 1 2 3 }" } } ;
+HELP: all-subsets
+{ $values { "seq" sequence } { "subsets" sequence } }
+{ $description
+ "Returns all the subsets of a sequence."
+}
+{ $examples
+ { $example
+ "USING: math.combinatorics prettyprint ;"
+ "{ 1 2 3 } all-subsets ."
+ "{ { } { 1 } { 2 } { 3 } { 1 2 } { 1 3 } { 2 3 } { 1 2 3 } }"
+ }
+} ;
+
+HELP: selections
+{ $values { "seq" sequence } { "n" integer } { "selections" sequence } }
+{ $description
+ "Returns all the ways to take n (possibly the same) items from the "
+ "sequence of items."
+}
+{ $examples
+ { $example
+ "USING: math.combinatorics prettyprint ;"
+ "{ 1 2 } 2 selections ."
+ "{ { 1 1 } { 1 2 } { 2 1 } { 2 2 } }"
+ }
+} ;
[ { { "a" "b" } { "a" "c" }
{ "a" "d" } { "b" "c" }
{ "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test
+
+[ { { } } ] [ { } all-subsets ] unit-test
+
+[ { { } { 1 } { 2 } { 3 } { 1 2 } { 1 3 } { 2 3 } { 1 2 3 } } ]
+[ { 1 2 3 } all-subsets ] unit-test
+
+[ { } ] [ { 1 2 } 0 selections ] unit-test
+
+[ { { 1 2 } } ] [ { 1 2 } 1 selections ] unit-test
+
+[ { { 1 1 } { 1 2 } { 2 1 } { 2 2 } } ]
+[ { 1 2 } 2 selections ] unit-test
+
+[ { { 1 1 1 } { 1 1 2 } { 1 2 1 } { 1 2 2 }
+ { 2 1 1 } { 2 1 2 } { 2 2 1 } { 2 2 2 } } ]
+[ { 1 2 } 3 selections ] unit-test
+
-! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer.
+! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer, John Benediktsson.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs binary-search fry kernel locals math math.order
- math.ranges namespaces sequences sorting ;
+ math.ranges namespaces sequences sorting make sequences.deep arrays
+ combinators ;
IN: math.combinatorics
<PRIVATE
: reduce-combinations ( seq k identity quot -- result )
[ -rot ] dip each-combination ; inline
+
+: all-subsets ( seq -- subsets )
+ dup length [0,b] [
+ [ dupd all-combinations [ , ] each ] each
+ ] { } make nip ;
+
+: (selections) ( seq n -- selections )
+ dupd [ dup 1 > ] [
+ swap pick cartesian-product [
+ [ [ dup length 1 > [ flatten ] when , ] each ] each
+ ] { } make swap 1 -
+ ] while drop nip ;
+
+: selections ( seq n -- selections )
+ {
+ { 0 [ drop { } ] }
+ { 1 [ 1array ] }
+ [ (selections) ]
+ } case ;
+
[ t ] [ { 1 1 1 } { 1 1 1 } p= ] unit-test
[ { 0 0 } { 1 1 } ] [ { 1 1 1 1 } { 1 1 } pgcd ] unit-test
+[ { 10 200 3000 } ] [ { 1 10 100 1000 } pdiff ] unit-test
+
[ V{ 0 } clone V{ 1 } clone ] 2dip swap (pgcd) [ >array ] bi@ ;
: pdiff ( p -- p' )
- dup length v* { 0 } ?head drop ;
+ dup length iota v* rest ;
: polyval ( x p -- p[x] )
[ length swap powers ] [ nip ] 2bi v. ;
[ t ] [ qi qi q- q0 = ] unit-test
[ t ] [ qi qj q+ qj qi q+ = ] unit-test
[ t ] [ qi qj q- qj qi q- -1 q*n = ] unit-test
+
+[ { 2 2 2 2 } ] [ { 1 1 1 1 } 2 q*n ] unit-test
+[ { 2 2 2 2 } ] [ 2 { 1 1 1 1 } n*q ] unit-test
: q/ ( u v -- u/v )
qrecip q* ; inline
-: n*q ( q n -- r )
- v*n ; inline
+: n*q ( n q -- r )
+ n*v ; inline
: q*n ( q n -- r )
v*n ; inline
--- /dev/null
+USING: math.vectors.simd math.vectors.simd.cords tools.test ;\r
+IN: math.vectors.simd.cords.tests\r
+\r
+[ float-4{ 1.0 2.0 3.0 4.0 } ] [ double-4{ 1.0 2.0 3.0 4.0 } >float-4 ] unit-test\r
WHERE
: >A ( seq -- A )
- [ N head >A/2 ]
- [ N tail >A/2 ] bi cord-append ;
+ [ N head-slice >A/2 ]
+ [ N tail-slice >A/2 ] bi cord-append ;
\ A-boa
{ N ndip A/2-boa cord-append } { A/2-boa } >quotation prefix >quotation
{ c:int float-4 } [
[ 123 swap 0 c:int c:set-alien-value ]
[ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi*
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
[ 123 float-4{ 1 2 3 4 } ] [ simd-stack-test ] unit-test
{ c:int } [
123 swap 0 c:int c:set-alien-value
>float (simd-stack-spill-test) float-4-with swap cos v*n
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
[ ] [
1.047197551196598 simd-stack-spill-test
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors alarms fry kernel models ;\r
+USING: accessors timers fry kernel models ;\r
IN: models.delay\r
\r
-TUPLE: delay < model model timeout alarm ;\r
+TUPLE: delay < model model timeout timer ;\r
\r
: update-delay-model ( delay -- )\r
[ model>> value>> ] keep set-model ;\r
[ add-dependency ] keep ;\r
\r
: stop-delay ( delay -- )\r
- alarm>> [ stop-alarm ] when* ;\r
+ timer>> [ stop-timer ] when* ;\r
\r
: start-delay ( delay -- )\r
dup\r
- [ '[ _ f >>alarm update-delay-model ] ] [ timeout>> ] bi\r
+ [ '[ _ f >>timer update-delay-model ] ] [ timeout>> ] bi\r
later\r
- >>alarm drop ;\r
+ >>timer drop ;\r
\r
M: delay model-changed nip dup stop-delay start-delay ;\r
\r
USING: help.syntax help.markup kernel math classes classes.tuple
-calendar ;
+calendar sequences growable ;
IN: models
HELP: model
{ $values { "value" object } { "model" model } }
{ $description "Changes the value of a model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
-{ set-model change-model (change-model) } related-words
+{ set-model change-model change-model* (change-model) push-model pop-model } related-words
HELP: change-model
-{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
+{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b newobj )" } } }
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value, and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
+HELP: change-model*
+{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b )" } } }
+{ $description "Applies the quotation to the current value of the model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } " without actually changing the value of the model. This is useful for notifying observers of operations that mutate a value, as in " { $link push-model } " and " { $link pop-model } "." } ;
+
HELP: (change-model)
-{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
+{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b newobj )" } } }
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." }
{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ;
+HELP: push-model
+{ $values { "value" object } { "model" model } }
+{ $description { $link push } "es " { $snippet "value" } " onto the " { $link growable } " sequence stored as the value of " { $snippet "model" } " and calls " { $link model-changed } " on all observers registered for the model with " { $link add-connection } "." } ;
+
+HELP: pop-model
+{ $values { "model" model } { "value" object } }
+{ $description { $link pop } "s the topmost " { $snippet "value" } " off of the " { $link growable } " sequence stored as the value of " { $snippet "model" } " and calls " { $link model-changed } " on all observers registered for the model with " { $link add-connection } "." } ;
+
HELP: range-value
{ $values { "model" model } { "value" object } }
{ $contract "Outputs the current value of a range model." } ;
[ T{ model-tester f t } ]
[
- T{ model-tester f f } 3 <model> 2dup add-connection
+ T{ model-tester f f } clone 3 <model> 2dup add-connection
5 swap set-model
] unit-test
"tester" get
"model-c" get value>>
] unit-test
+
+[ T{ model-tester f t } V{ 5 } ]
+[
+ T{ model-tester f f } clone V{ } clone <model> 2dup add-connection
+ 5 swap [ push-model ] [ value>> ] bi
+] unit-test
+
+[ T{ model-tester f t } 5 V{ } ]
+[
+ T{ model-tester f f } clone V{ 5 } clone <model> 2dup add-connection
+ [ pop-model ] [ value>> ] bi
+] unit-test
+
: ((change-model)) ( model quot -- newvalue model )
over [ [ value>> ] dip call ] dip ; inline
-: change-model ( model quot -- )
+: change-model ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
((change-model)) set-model ; inline
-: (change-model) ( model quot -- )
+: (change-model) ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
((change-model)) value<< ; inline
GENERIC: range-value ( model -- value )
: clamp-value ( value range -- newvalue )
[ range-min-value ] [ range-max-value* ] bi clamp ;
+
+: change-model* ( ..a model quot: ( ..a obj -- ..b ) -- ..b )
+ '[ _ keep ] change-model ; inline
+
+: push-model ( value model -- )
+ [ push ] change-model* ;
+
+: pop-model ( model -- value )
+ [ pop ] change-model* ;
+
: framebuffer-attachment ( attachment -- id )
GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
- { uint } [ glGetFramebufferAttachmentParameteriv ] [ ] with-out-parameters ;
+ { uint } [ glGetFramebufferAttachmentParameteriv ] with-out-parameters ;
swap glPushAttrib call glPopAttrib ; inline
: (gen-gl-object) ( quot -- id )
- [ 1 { uint } ] dip [ ] with-out-parameters ; inline
+ [ 1 { uint } ] dip with-out-parameters ; inline
: (delete-gl-object) ( id quot -- )
[ 1 swap <uint> ] dip call ; inline
dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
: gl-shader-get-int ( shader enum -- value )
- { int } [ glGetShaderiv ] [ ] with-out-parameters ;
+ { int } [ glGetShaderiv ] with-out-parameters ;
: gl-shader-ok? ( shader -- ? )
GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
: gl-program-get-int ( program enum -- value )
- { int } [ glGetProgramiv ] [ ] with-out-parameters ;
+ { int } [ glGetProgramiv ] with-out-parameters ;
: gl-program-ok? ( program -- ? )
GL_LINK_STATUS gl-program-get-int c-bool> ;
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
: get-texture-float ( target level enum -- value )
- { float } [ glGetTexLevelParameterfv ] [ ] with-out-parameters ; inline
+ { float } [ glGetTexLevelParameterfv ] with-out-parameters ; inline
: get-texture-int ( target level enum -- value )
- { int } [ glGetTexLevelParameteriv ] [ ] with-out-parameters ; inline
+ { int } [ glGetTexLevelParameteriv ] with-out-parameters ; inline
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
-M: hashtable pprint* pprint-object ;
+
+: with-extra-nesting-level ( quot -- )
+ nesting-limit [ dup [ 1 + ] [ f ] if* ] change
+ [ nesting-limit set ] curry [ ] cleanup ; inline
+
+M: hashtable pprint*
+ [ pprint-object ] with-extra-nesting-level ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
M: hash-set pprint* pprint-object ;
] [
[ \ final-tuple see ] with-string-writer "\n" split
] unit-test
+
+[ "H{ { 1 2 } }\n" ] [ [ H{ { 1 2 } } short. ] with-string-writer ] unit-test
+
+[ "H{ { 1 ~array~ } }\n" ] [ [ H{ { 1 { 2 } } } short. ] with-string-writer ] unit-test
+
+[ "{ ~array~ }\n" ] [ [ { { 1 2 } } short. ] with-string-writer ] unit-test
+
+[ "H{ { 1 { 2 3 } } }\n" ] [
+ f nesting-limit [
+ [ H{ { 1 { 2 3 } } } . ] with-string-writer
+ ] with-variable
+] unit-test
+
type
flags
CryptAcquireContextW
- ] [ ] with-out-parameters ;
+ ] with-out-parameters ;
: acquire-crypto-context ( provider type -- handle )
CRYPT_MACHINE_KEYSET
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences sorting binary-search fry math
-math.order arrays classes combinators kernel functors math.functions
-math.vectors ;
+math.order arrays classes combinators kernel functors locals
+math.functions math.vectors ;
IN: sequences.cords
MIXIN: cord
[ [ head>> ] dip call ]
[ [ tail>> ] dip call ] 2bi cord-append ; inline
-: cord-2map ( cord cord quot -- cord' )
- [ [ [ head>> ] bi@ ] dip call ]
- [ [ [ tail>> ] bi@ ] dip call ] 3bi cord-append ; inline
+:: cord-2map ( cord-a cord-b quot fallback -- cord' )
+ cord-a cord-b 2dup [ cord? ] both? [
+ [ [ head>> ] bi@ quot call ]
+ [ [ tail>> ] bi@ quot call ] 2bi cord-append
+ ] [ fallback call ] if ; inline
: cord-both ( cord quot -- h t )
[ [ head>> ] [ tail>> ] bi ] dip bi@ ; inline
-: cord-2both ( cord cord quot -- h t )
- [ [ [ head>> ] bi@ ] dip call ]
- [ [ [ tail>> ] bi@ ] dip call ] 3bi ; inline
+:: cord-2both ( cord-a cord-b quot combine fallback -- result )
+ cord-a cord-b 2dup [ cord? ] both? [
+ [ [ head>> ] bi@ quot call ]
+ [ [ tail>> ] bi@ quot call ] 2bi combine call
+ ] [ fallback call ] if ; inline
<PRIVATE
: split-shuffle ( shuf -- sh uf )
dup length 2 /i cut* ; foldable
PRIVATE>
-M: cord v+ [ v+ ] cord-2map ; inline
-M: cord v- [ v- ] cord-2map ; inline
+M: cord v+ [ v+ ] [ call-next-method ] cord-2map ; inline
+M: cord v- [ v- ] [ call-next-method ] cord-2map ; inline
M: cord vneg [ vneg ] cord-map ; inline
-M: cord v+- [ v+- ] cord-2map ; inline
-M: cord vs+ [ vs+ ] cord-2map ; inline
-M: cord vs- [ vs- ] cord-2map ; inline
-M: cord vs* [ vs* ] cord-2map ; inline
-M: cord v* [ v* ] cord-2map ; inline
-M: cord v/ [ v/ ] cord-2map ; inline
-M: cord vmin [ vmin ] cord-2map ; inline
-M: cord vmax [ vmax ] cord-2map ; inline
-M: cord v. [ v. ] cord-2both + ; inline
+M: cord v+- [ v+- ] [ call-next-method ] cord-2map ; inline
+M: cord vs+ [ vs+ ] [ call-next-method ] cord-2map ; inline
+M: cord vs- [ vs- ] [ call-next-method ] cord-2map ; inline
+M: cord vs* [ vs* ] [ call-next-method ] cord-2map ; inline
+M: cord v* [ v* ] [ call-next-method ] cord-2map ; inline
+M: cord v/ [ v/ ] [ call-next-method ] cord-2map ; inline
+M: cord vmin [ vmin ] [ call-next-method ] cord-2map ; inline
+M: cord vmax [ vmax ] [ call-next-method ] cord-2map ; inline
+M: cord v.
+ [ v. ] [ + ] [ call-next-method ] cord-2both ; inline
M: cord vsqrt [ vsqrt ] cord-map ; inline
M: cord sum [ sum ] cord-both + ; inline
M: cord vabs [ vabs ] cord-map ; inline
-M: cord vbitand [ vbitand ] cord-2map ; inline
-M: cord vbitandn [ vbitandn ] cord-2map ; inline
-M: cord vbitor [ vbitor ] cord-2map ; inline
-M: cord vbitxor [ vbitxor ] cord-2map ; inline
+M: cord vbitand [ vbitand ] [ call-next-method ] cord-2map ; inline
+M: cord vbitandn [ vbitandn ] [ call-next-method ] cord-2map ; inline
+M: cord vbitor [ vbitor ] [ call-next-method ] cord-2map ; inline
+M: cord vbitxor [ vbitxor ] [ call-next-method ] cord-2map ; inline
M: cord vbitnot [ vbitnot ] cord-map ; inline
-M: cord vand [ vand ] cord-2map ; inline
-M: cord vandn [ vandn ] cord-2map ; inline
-M: cord vor [ vor ] cord-2map ; inline
-M: cord vxor [ vxor ] cord-2map ; inline
+M: cord vand [ vand ] [ call-next-method ] cord-2map ; inline
+M: cord vandn [ vandn ] [ call-next-method ] cord-2map ; inline
+M: cord vor [ vor ] [ call-next-method ] cord-2map ; inline
+M: cord vxor [ vxor ] [ call-next-method ] cord-2map ; inline
M: cord vnot [ vnot ] cord-map ; inline
M: cord vlshift '[ _ vlshift ] cord-map ; inline
M: cord vrshift '[ _ vrshift ] cord-map ; inline
M: cord (vmerge-head) [ head>> ] bi@ (vmerge) cord-append ; inline
M: cord (vmerge-tail) [ tail>> ] bi@ (vmerge) cord-append ; inline
-M: cord v<= [ v<= ] cord-2map ; inline
-M: cord v< [ v< ] cord-2map ; inline
-M: cord v= [ v= ] cord-2map ; inline
-M: cord v> [ v> ] cord-2map ; inline
-M: cord v>= [ v>= ] cord-2map ; inline
-M: cord vunordered? [ vunordered? ] cord-2map ; inline
+M: cord v<= [ v<= ] [ call-next-method ] cord-2map ; inline
+M: cord v< [ v< ] [ call-next-method ] cord-2map ; inline
+M: cord v= [ v= ] [ call-next-method ] cord-2map ; inline
+M: cord v> [ v> ] [ call-next-method ] cord-2map ; inline
+M: cord v>= [ v>= ] [ call-next-method ] cord-2map ; inline
+M: cord vunordered? [ vunordered? ] [ call-next-method ] cord-2map ; inline
M: cord vany? [ vany? ] cord-both or ; inline
M: cord vall? [ vall? ] cord-both and ; inline
M: cord vnone? [ vnone? ] cord-both and ; inline
!
USING: namespaces sequences kernel math io math.functions
io.binary strings classes words sbufs classes.tuple arrays
-vectors byte-arrays quotations hashtables assocs help.syntax
-help.markup splitting io.streams.byte-array io.encodings.string
-io.encodings.utf8 io.encodings.binary combinators accessors
-locals prettyprint compiler.units sequences.private
-classes.tuple.private vocabs.loader ;
+vectors byte-arrays quotations hashtables hashtables.identity
+assocs help.syntax help.markup splitting io.streams.byte-array
+io.encodings.string io.encodings.utf8 io.encodings.binary
+combinators accessors locals prettyprint compiler.units
+sequences.private classes.tuple.private vocabs.loader ;
IN: serialize
GENERIC: (serialize) ( obj -- )
! Variable holding a assoc of objects already serialized
SYMBOL: serialized
-TUPLE: id obj ;
-
-C: <id> id
-
-M: id hashcode* nip obj>> identity-hashcode ;
-
-M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
-
: add-object ( obj -- )
#! Add an object to the sequence of already serialized
#! objects.
- serialized get [ assoc-size swap <id> ] keep set-at ;
+ serialized get [ assoc-size swap ] keep set-at ;
: object-id ( obj -- id )
#! Return the id of an already serialized object
- <id> serialized get at ;
+ serialized get at ;
! Numbers are serialized as follows:
! 0 => B{ 0 }
[ (deserialize) ] with-variable ;
: serialize ( obj -- )
- H{ } clone serialized [ (serialize) ] with-variable ;
+ IH{ } clone serialized [ (serialize) ] with-variable ;
: bytes>object ( bytes -- obj )
binary [ deserialize ] with-byte-reader ;
"<" %
64 random-bits #
"-" %
- system-micros #
+ gmt timestamp>micros #
"@" %
smtp-domain get [ host-name ] unless* %
">" %
word>> name>> "Cannot compile call to “" "”" surround ;
M: unbalanced-branches-error summary
- word>> name>>
- "The input quotations to “" "” don't match their expected effects" surround ;
+ [ word>> name>> ] [ quots>> length 1 = ] bi
+ [ "The input quotation to “" "” doesn't match its expected effect" ]
+ [ "The input quotations to “" "” don't match their expected effects" ] if
+ surround ;
M: unbalanced-branches-error error.
dup summary print
\ quot-compiled? { quotation } { object } define-primitive
\ quotation-code { quotation } { integer integer } define-primitive \ quotation-code make-flushable
\ reset-dispatch-stats { } { } define-primitive
-\ resize-array { integer array } { array } define-primitive \ resize-array make-flushable
-\ resize-byte-array { integer byte-array } { byte-array } define-primitive \ resize-byte-array make-flushable
-\ resize-string { integer string } { string } define-primitive \ resize-string make-flushable
+\ resize-array { integer array } { array } define-primitive
+\ resize-byte-array { integer byte-array } { byte-array } define-primitive
+\ resize-string { integer string } { string } define-primitive
\ retainstack { } { array } define-primitive \ retainstack make-flushable
\ retainstack-for { c-ptr } { array } define-primitive \ retainstack-for make-flushable
\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
\ special-object { fixnum } { object } define-primitive \ special-object make-flushable
\ string-nth-fast { fixnum string } { fixnum } define-primitive \ string-nth-fast make-flushable
\ strip-stack-traces { } { } define-primitive
-\ system-micros { } { integer } define-primitive \ system-micros make-flushable
\ tag { object } { fixnum } define-primitive \ tag make-foldable
\ unimplemented { } { } define-primitive
\ word-code { word } { integer integer } define-primitive \ word-code make-flushable
:: (effect-here) ( inner-d old-meta-d-length old-input-count -- effect )
old-meta-d-length inner-d - input-count get old-input-count - +
- meta-d length inner-d -
- [ "x" <array> ] bi@ terminated? get <terminated-effect> ; inline
+ terminated? get [ [ 0 ] [ meta-d length inner-d - ] if [ "x" <array> ] bi@ ] keep
+ <terminated-effect> ; inline
: with-effect-here ( quot -- effect )
meta-d length input-count get
--- /dev/null
+Doug Coleman
--- /dev/null
+One-time and recurring timers for relative time offsets
--- /dev/null
+USING: help.markup help.syntax calendar quotations system ;\r
+IN: timers\r
+\r
+HELP: timer\r
+{ $class-description "A timer. Can be passed to " { $link stop-timer } "." } ;\r
+\r
+HELP: start-timer\r
+{ $values { "timer" timer } }\r
+{ $description "Starts a timer." } ;\r
+\r
+HELP: restart-timer\r
+{ $values { "timer" timer } }\r
+{ $description "Starts or restarts a timer. Restarting a timer causes the a sleep of initial delay nanoseconds before looping. An timer's parameters may be modified and restarted with this word." } ;\r
+\r
+HELP: stop-timer\r
+{ $values { "timer" timer } }\r
+{ $description "Prevents a timer from calling its quotation again. Has no effect on timers that are not currently running." } ;\r
+\r
+HELP: every\r
+{ $values\r
+ { "quot" quotation } { "interval-duration" duration }\r
+ { "timer" timer } }\r
+{ $description "Creates a timer that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the timer will stop." }\r
+{ $examples\r
+ { $unchecked-example\r
+ "USING: timers io calendar ;"\r
+ """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
+ ""\r
+ }\r
+} ;\r
+\r
+HELP: later\r
+{ $values { "quot" quotation } { "delay-duration" duration } { "timer" timer } }\r
+{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the timer before " { $snippet "quot" } " runs. This timer is not repeated." }\r
+{ $examples\r
+ { $unchecked-example\r
+ "USING: timers io calendar ;"\r
+ """[ "Break's over!" print flush ] 15 minutes later drop"""\r
+ ""\r
+ }\r
+} ;\r
+\r
+HELP: delayed-every\r
+{ $values\r
+ { "quot" quotation } { "duration" duration }\r
+ { "timer" timer } }\r
+{ $description "Creates a timer that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the timer will stop." }\r
+{ $examples\r
+ { $unchecked-example\r
+ "USING: timers io calendar ;"\r
+ """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
+ ""\r
+ }\r
+} ;\r
+\r
+ARTICLE: "timers" "Alarms"\r
+"The " { $vocab-link "timers" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Alarms run in a single green thread per timer and consist of a quotation, a delay duration, and an interval duration. After starting a timer, the timer thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the timer. If a recurring timer's quotation would be scheduled to run again before the previous quotation has finished processing, the timer will be run again immediately afterwards. This may result in the timer falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring timers that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the timer from drifting over time. Alarms use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl\r
+"The timer class:"\r
+{ $subsections timer }\r
+"Create a timer before starting it:"\r
+{ $subsections <timer> }\r
+"Starting a timer:"\r
+{ $subsections start-timer restart-timer }\r
+"Stopping a timer:"\r
+{ $subsections stop-timer }\r
+\r
+"A recurring timer without an initial delay:"\r
+{ $subsections every }\r
+"A one-time timer with an initial delay:"\r
+{ $subsections later }\r
+"A recurring timer with an initial delay:"\r
+{ $subsections delayed-every } ;\r
+\r
+ABOUT: "timers"\r
--- /dev/null
+USING: timers timers.private calendar concurrency.count-downs\r
+concurrency.promises fry kernel math math.order sequences\r
+threads tools.test tools.time ;\r
+IN: timers.tests\r
+\r
+[ ] [\r
+ 1 <count-down>\r
+ { f } clone 2dup\r
+ [ first stop-timer count-down ] 2curry 1 seconds later\r
+ swap set-first\r
+ await\r
+] unit-test\r
+\r
+[ ] [\r
+ self [ resume ] curry instant later drop\r
+ "test" suspend drop\r
+] unit-test\r
+\r
+[ t ] [\r
+ [\r
+ <promise>\r
+ [ '[ t _ fulfill ] 2 seconds later drop ]\r
+ [ 5 seconds ?promise-timeout drop ] bi\r
+ ] benchmark 1,500,000,000 2,500,000,000 between?\r
+] unit-test\r
+\r
+[ { 3 } ] [\r
+ { 3 } dup\r
+ '[ 4 _ set-first ] 2 seconds later\r
+ 1/2 seconds sleep\r
+ stop-timer\r
+] unit-test\r
+\r
+[ { 1 } ] [\r
+ { 0 }\r
+ dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later\r
+ [ stop-timer ] [ start-timer ] bi\r
+ 4 seconds sleep\r
+] unit-test\r
+\r
+[ { 0 } ] [\r
+ { 0 }\r
+ dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later\r
+ 2 seconds sleep stop-timer\r
+ 1/2 seconds sleep\r
+] unit-test\r
+\r
+[ { 0 } ] [\r
+ { 0 }\r
+ dup '[ 1 _ set-first ] 300 milliseconds later\r
+ 150 milliseconds sleep\r
+ [ restart-timer ] [ 200 milliseconds sleep stop-timer ] bi\r
+] unit-test\r
+\r
+[ { 1 } ] [\r
+ { 0 }\r
+ dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later\r
+ 100 milliseconds sleep restart-timer 300 milliseconds sleep\r
+] unit-test\r
+\r
+[ { 4 } ] [\r
+ { 0 }\r
+ dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds\r
+ <timer> dup start-timer\r
+ 700 milliseconds sleep dup restart-timer\r
+ 700 milliseconds sleep stop-timer 500 milliseconds sleep\r
+] unit-test\r
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar combinators.short-circuit fry
+heaps init kernel math math.functions math.parser namespaces
+quotations sequences system threads ;
+IN: timers
+
+TUPLE: timer
+ { quot callable initial: [ ] }
+ start-nanos
+ delay-nanos
+ interval-nanos
+ iteration-start-nanos
+ quotation-running?
+ restart?
+ thread ;
+
+<PRIVATE
+
+GENERIC: >nanoseconds ( obj -- duration/f )
+M: f >nanoseconds ;
+M: real >nanoseconds >integer ;
+M: duration >nanoseconds duration>nanoseconds >integer ;
+
+: set-next-timer-time ( timer -- timer )
+ ! start + delay + ceiling((now - (start + delay)) / interval) * interval
+ nano-count
+ over start-nanos>> -
+ over delay-nanos>> [ - ] when*
+ over interval-nanos>> / ceiling
+ over interval-nanos>> *
+ over start-nanos>> +
+ over delay-nanos>> [ + ] when*
+ >>iteration-start-nanos ;
+
+: stop-timer? ( timer -- ? )
+ { [ thread>> self eq? not ] [ restart?>> ] } 1|| ;
+
+DEFER: call-timer-loop
+
+: loop-timer ( timer -- )
+ nano-count over
+ [ iteration-start-nanos>> - ] [ interval-nanos>> ] bi <
+ [ set-next-timer-time ] dip
+ [ dup iteration-start-nanos>> ] [ 0 ] if
+ 0 or sleep-until call-timer-loop ;
+
+: maybe-loop-timer ( timer -- )
+ dup { [ stop-timer? ] [ interval-nanos>> not ] } 1||
+ [ drop ] [ loop-timer ] if ;
+
+: call-timer-loop ( timer -- )
+ dup stop-timer? [
+ drop
+ ] [
+ [
+ [ t >>quotation-running? drop ]
+ [ quot>> call( -- ) ]
+ [ f >>quotation-running? drop ] tri
+ ] keep
+ maybe-loop-timer
+ ] if ;
+
+: sleep-delay ( timer -- )
+ dup stop-timer? [
+ drop
+ ] [
+ nano-count >>start-nanos
+ delay-nanos>> [ sleep ] when*
+ ] if ;
+
+: timer-loop ( timer -- )
+ [ sleep-delay ]
+ [ nano-count >>iteration-start-nanos call-timer-loop ]
+ [ dup restart?>> [ f >>restart? timer-loop ] [ drop ] if ] tri ;
+
+PRIVATE>
+
+: <timer> ( quot delay-duration/f interval-duration/f -- timer )
+ timer new
+ swap >nanoseconds >>interval-nanos
+ swap >nanoseconds >>delay-nanos
+ swap >>quot ; inline
+
+: start-timer ( timer -- )
+ [
+ '[ _ timer-loop ] "Timer execution" spawn
+ ] keep thread<< ;
+
+: stop-timer ( timer -- )
+ dup quotation-running?>> [
+ f >>thread drop
+ ] [
+ [ [ interrupt ] when* f ] change-thread drop
+ ] if ;
+
+: restart-timer ( timer -- )
+ t >>restart?
+ dup quotation-running?>> [
+ drop
+ ] [
+ dup thread>> [ nip interrupt ] [ start-timer ] if*
+ ] if ;
+
+<PRIVATE
+
+: (start-timer) ( quot start-duration interval-duration -- timer )
+ <timer> [ start-timer ] keep ;
+
+PRIVATE>
+
+: every ( quot interval-duration -- timer )
+ [ f ] dip (start-timer) ;
+
+: later ( quot delay-duration -- timer )
+ f (start-timer) ;
+
+: delayed-every ( quot duration -- timer )
+ dup (start-timer) ;
+
+: nanos-since ( nano-count -- nanos )
+ [ nano-count ] dip - ;
HELP: deploy-threads?
{ $description "Deploy flag. If set, thread support will be included in the final image."
$nl
-"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, alarms, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ;
+"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, timers, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ;
HELP: deploy-ui?
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
io.files io.files.info io.files.temp kernel tools.deploy.config
tools.deploy.config.editor tools.deploy.backend math sequences
io.launcher arrays namespaces continuations layouts accessors
-urls math.parser io.directories tools.deploy.test ;
+urls math.parser io.directories tools.deploy tools.deploy.test
+vocabs ;
IN: tools.deploy.tests
+[ "no such vocab, fool!" deploy ] [ no-vocab? ] must-fail-with
+
[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
deploy-test-command ascii [ readln ] with-process-reader
"test.image" temp-file =
] unit-test
+
+[ ] [ "resource:license.txt" "license.txt" temp-file copy-file ] unit-test
+
+[ ] [ "tools.deploy.test.19" shake-and-bake run-temp-image ] unit-test
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.deploy.backend system vocabs.loader kernel
+USING: tools.deploy.backend system vocabs vocabs.loader kernel
combinators tools.deploy.config.editor ;
IN: tools.deploy
-: deploy ( vocab -- ) deploy* ;
+: deploy ( vocab -- )
+ dup find-vocab-root [ deploy* ] [ no-vocab ] if ;
: deploy-image-only ( vocab image -- )
[ vm ] 2dip swap dup deploy-config make-deploy-image drop ;
QUALIFIED: source-files
QUALIFIED: source-files.errors
QUALIFIED: vocabs
+QUALIFIED: vocabs.loader
FROM: alien.libraries.private => >deployed-library-path ;
FROM: namespaces => set ;
FROM: sets => members ;
strip-io? [ io-backend , ] when
{ } {
- "alarms"
+ "timers"
"tools"
"io.launcher"
"random"
vocabs:dictionary
vocabs:load-vocab-hook
vocabs:vocab-observers
+ vocabs.loader:add-vocab-root-hook
word
parser-notes
} %
: startup-stripper ( -- )
t "quiet" set-global
f output-stream set-global
- V{ "resource:" } clone vocab-roots set-global ;
+ [ V{ "resource:" } clone vocab-roots set-global ]
+ "vocabs.loader" startup-hooks get-global set-at ;
: next-method* ( method -- quot )
[ "method-class" word-prop ]
: pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
-IN: cocoa.application
-
-: objc-error ( error -- ) die ;
-
-[ [ die ] 19 set-special-object ] "cocoa.application" add-startup-hook
-
H{ } clone \ pool [
global [
! Only keeps those methods that we actually call
FROM: alien.c-types => float ;
IN: tools.deploy.test.14
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "Bar" }
-} {
- "bar:"
- float
- { id SEL NSRect }
- [
- [ origin>> [ x>> ] [ y>> ] bi + ]
- [ size>> [ w>> ] [ h>> ] bi + ]
- bi +
+CLASS: Bar < NSObject
+[
+ METHOD: float bar: NSRect rect [
+ rect origin>> [ x>> ] [ y>> ] bi +
+ rect size>> [ w>> ] [ h>> ] bi +
+ +
]
-} ;
+]
: main ( -- )
Bar -> alloc -> init
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.files io.encodings.ascii ;
+IN: tools.deploy.test.19
+
+: main ( -- )
+ "vocab:license.txt" ascii file-contents write ;
+
+MAIN: main
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "tools.deploy.test.19" }
+ { deploy-ui? f }
+ { deploy-c-types? f }
+ { deploy-console? t }
+ { deploy-unicode? f }
+ { "stop-after-last-window?" t }
+ { deploy-io 2 }
+ { deploy-reflection 1 }
+ { deploy-word-props? f }
+ { deploy-math? f }
+ { deploy-threads? f }
+ { deploy-word-defs? f }
+}
--- /dev/null
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--- /dev/null
+license.txt
USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ;
{
- { [ os linux? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] }
- { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ ud heap-size ] unit-test ] }
- { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] }
+ {
+ [ cpu x86.32? ]
+ [
+ os windows?
+ [ [ 624 ] [ ud heap-size ] unit-test ]
+ [ [ 604 ] [ ud heap-size ] unit-test ] if
+ ]
+ }
+ { [ cpu x86.64? ] [ [ 672 ] [ ud heap-size ] unit-test ] }
[ ]
} cond
\ No newline at end of file
{ c3 uchar }
{ inp_cache uchar[256] }
{ inp_sess uchar[64] }
- { itab_entry void* } ;
+ { have_modrm uchar }
+ { modrm uchar }
+ { user_opaque_data void* }
+ { itab_entry void* }
+ { le void* } ;
FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ;
f <model> (error-list-model) set-global
(error-list-model) get-global 100 milliseconds <delay> error-list-model set-global
updater add-error-observer
-] "ui.tools.error-list" add-startup-hook
-
+] "tools.errors.model" add-startup-hook
vocabs.loader vocabs.metadata io combinators calendar accessors
math.parser io.streams.string ui.tools.operations quotations
strings arrays prettyprint words vocabs sorting sets classes
-math alien urls splitting ascii combinators.short-circuit alarms
+math alien urls splitting ascii combinators.short-circuit timers
words.symbol system summary ;
IN: tools.scaffold
<PRIVATE
-: vocab-root? ( string -- ? ) vocab-roots get member? ;
+: vocab-root? ( string -- ? )
+ trim-tail-separators
+ vocab-roots get member? ;
: contains-dot? ( string -- ? ) ".." swap subseq? ;
{ "ch" "a character" }
{ "word" word }
{ "array" array }
- { "alarm" alarm }
+ { "timers" timer }
{ "duration" duration }
{ "path" "a pathname string" }
{ "vocab" "a vocabulary specifier" }
ABOUT: "tools.test"
HELP: unit-test
-{ $syntax "[ output ] [ input ] unit-test" }
+{ $syntax "{ output } [ input ] unit-test" }
{ $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } }
{ $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ;
{ $values { "quot" quotation } }
{ $description "Runs a quotation, gathering statistics about method dispatch and garbage collection, and then prints the total run time." } ;
-{ benchmark system-micros time } related-words
+{ benchmark time } related-words
HELP: collect-gc-events
{ $values { "quot" quotation } { "gc-events" "a sequence of " { $link gc-event } " instances" } }
-USING: definitions kernel locals.definitions see see.private typed words ;
+USING: definitions kernel locals.definitions see see.private typed words
+summary make accessors classes ;
IN: typed.prettyprint
PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
M: typed-word definition "typed-def" word-prop ;
M: typed-word declarations. "typed-word" word-prop declarations. ;
+M: input-mismatch-error summary
+ [
+ "Typed word “" %
+ dup word>> name>> %
+ "” expected input value of type " %
+ dup expected-type>> name>> %
+ " but got " %
+ dup value>> class name>> %
+ drop
+ ] "" make ;
+
+M: output-mismatch-error summary
+ [
+ "Typed word “" %
+ dup word>> name>> %
+ "” expected to output value of type " %
+ dup expected-type>> name>> %
+ " but gave " %
+ dup value>> class name>> %
+ drop
+ ] "" make ;
USING: accessors effects eval kernel layouts math namespaces
-quotations tools.test typed words words.symbol
-compiler.tree.debugger prettyprint definitions compiler.units ;
+quotations tools.test typed words words.symbol combinators.short-circuit
+compiler.tree.debugger prettyprint definitions compiler.units sequences ;
IN: typed.tests
TYPED: f+ ( a: float b: float -- c: float )
TYPED: dum ( x: tweedle-dum -- y )
drop \ tweedle-dum ;
-[ \ tweedle-dum new dee ] [ input-mismatch-error? ] must-fail-with
-[ \ tweedle-dee new dum ] [ input-mismatch-error? ] must-fail-with
+[ \ tweedle-dum new dee ]
+[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dee = ] [ value>> tweedle-dum? ] } 1&& ] must-fail-with
+[ \ tweedle-dee new dum ]
+[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
TYPED: dumdum ( x -- y: tweedle-dum )
drop \ tweedle-dee new ;
-[ f dumdum ] [ output-mismatch-error? ] must-fail-with
+[ f dumdum ]
+[ { [ output-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
TYPED:: f+locals ( a: float b: float -- c: float )
a b + ;
FROM: classes.tuple.private => tuple-layout ;
IN: typed
-ERROR: type-mismatch-error word expected-types ;
+ERROR: type-mismatch-error value expected-type word expected-types ;
ERROR: input-mismatch-error < type-mismatch-error ;
ERROR: output-mismatch-error < type-mismatch-error ;
: typed-stack-effect? ( effect -- ? )
[ object = ] all? not ;
-: input-mismatch-quot ( word types -- quot )
- [ input-mismatch-error ] 2curry ;
-
: depends-on-unboxing ( class -- )
[ dup tuple-layout depends-on-tuple-layout ]
[ depends-on-final ]
:: unboxer ( error-quot word types type -- quot )
type "coercer" word-prop [ ] or
- [ dup type instance? [ word types error-quot call ] unless ]
+ type type word types error-quot '[ dup _ instance? [ _ _ _ @ ] unless ]
type (unboxer)
compose compose ;
[ drop f ]
[
first
- { int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] [ ]
+ { int } [ swap 0 -> getValues:forAttribute:forVirtualScreen: ]
with-out-parameters
] if-empty ;
] [ 2drop ] if*
init-thread-timer ;
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorApplicationDelegate" }
-}
-
-{ "applicationDidUpdate:" void { id SEL id }
- [ 3drop reset-run-loop ]
-} ;
+CLASS: FactorApplicationDelegate < NSObject
+[
+ METHOD: void applicationDidUpdate: id obj
+ [ reset-run-loop ]
+]
: install-app-delegate ( -- )
NSApp FactorApplicationDelegate install-delegate ;
image save-panel [ save-image ] when* ;
! Handle Open events from the Finder
-CLASS: {
- { +superclass+ "FactorApplicationDelegate" }
- { +name+ "FactorWorkspaceApplicationDelegate" }
-}
-
-{ "application:openFiles:" void { id SEL id id }
- [ [ 3drop ] dip finder-run-files ]
-}
+CLASS: FactorWorkspaceApplicationDelegate < FactorApplicationDelegate
+[
+ METHOD: void application: id app openFiles: id files [ files finder-run-files ]
-{ "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int }
- [ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
-}
+ METHOD: int applicationShouldHandleReopen: id app hasVisibleWindows: int flag [ flag 0 = [ show-listener ] when 1 ]
-{ "factorListener:" id { id SEL id }
- [ 3drop show-listener f ]
-}
+ METHOD: id factorListener: id app [ show-listener f ]
-{ "factorBrowser:" id { id SEL id }
- [ 3drop show-browser f ]
-}
+ METHOD: id factorBrowser: id app [ show-browser f ]
-{ "newFactorListener:" id { id SEL id }
- [ 3drop listener-window f ]
-}
+ METHOD: id newFactorListener: id app [ listener-window f ]
-{ "newFactorBrowser:" id { id SEL id }
- [ 3drop browser-window f ]
-}
+ METHOD: id newFactorBrowser: id app [ browser-window f ]
-{ "runFactorFile:" id { id SEL id }
- [ 3drop menu-run-files f ]
-}
+ METHOD: id runFactorFile: id app [ menu-run-files f ]
-{ "saveFactorImage:" id { id SEL id }
- [ 3drop save f ]
-}
+ METHOD: id saveFactorImage: id app [ save f ]
-{ "saveFactorImageAs:" id { id SEL id }
- [ 3drop menu-save-image f ]
-}
+ METHOD: id saveFactorImageAs: id app [ menu-save-image f ]
-{ "refreshAll:" id { id SEL id }
- [ 3drop [ refresh-all ] \ refresh-all call-listener f ]
-} ;
+ METHOD: id refreshAll: id app [ [ refresh-all ] \ refresh-all call-listener f ]
+]
: install-app-delegate ( -- )
NSApp FactorWorkspaceApplicationDelegate install-delegate ;
dup [ quot call( string -- result/f ) ] when
[ pboard set-pasteboard-string ] when* ;
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorServiceProvider" }
-} {
- "evalInListener:userData:error:"
- void
- { id SEL id id id }
- [
- nip
- [ eval-listener f ] do-service
- 2drop
- ]
-} {
- "evalToString:userData:error:"
- void
- { id SEL id id id }
+CLASS: FactorServiceProvider < NSObject
+[
+ METHOD: void evalInListener: id pboard userData: id userData error: id error
+ [ pboard error [ eval-listener f ] do-service ]
+
+ METHOD: void evalToString: id pboard userData: id userData error: id error
[
- nip
+ pboard error
[ [ (eval>string) ] with-interactive-vocabs ] do-service
- 2drop
]
-} ;
+]
: register-services ( -- )
NSApp
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
cocoa.classes cocoa.views cocoa.application cocoa.pasteboard
-cocoa.runtime cocoa.types cocoa.windows sequences io.encodings.utf8
-ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
-core-foundation.strings core-graphics core-graphics.types threads
-combinators math.rectangles ;
+cocoa.runtime cocoa.types cocoa.windows sequences
+io.encodings.utf8 locals ui ui.private ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures
+core-foundation.strings core-graphics core-graphics.types
+threads combinators math.rectangles ;
IN: ui.backend.cocoa.views
: send-mouse-moved ( view event -- )
- [ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ;
+ [ mouse-location ] [ drop window ] 2bi
+ dup [ move-hand fire-motion yield ] [ 2drop ] if ;
: button ( event -- n )
#! Cocoa -> Factor UI button mapping
[ event-modifiers ] [ key-code ] bi ;
: send-key-event ( view gesture -- )
- swap window propagate-key-gesture ;
+ swap window dup [ propagate-key-gesture ] [ 2drop ] if ;
: interpret-key-event ( view event -- )
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
[ nip mouse-event>gesture <button-down> ]
[ mouse-location ]
[ drop window ]
- 2tri send-button-down ;
+ 2tri
+ dup [ send-button-down ] [ 3drop ] if ;
: send-button-up$ ( view event -- )
[ nip mouse-event>gesture <button-up> ]
[ mouse-location ]
[ drop window ]
- 2tri send-button-up ;
+ 2tri
+ dup [ send-button-up ] [ 3drop ] if ;
: send-scroll$ ( view event -- )
[ nip [ -> deltaX ] [ -> deltaY ] bi [ neg ] bi@ 2array ]
[ mouse-location ]
[ drop window ]
- 2tri send-scroll ;
+ 2tri
+ dup [ send-scroll ] [ 3drop ] if ;
-: send-action$ ( view event gesture -- junk )
- [ drop window ] dip send-action f ;
+: send-action$ ( view event gesture -- )
+ [ drop window ] dip over [ send-action ] [ 2drop ] if ;
: add-resize-observer ( observer object -- )
[
}
: validate-action ( world selector -- ? validated? )
- selector>action at
- [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
+ selector>action at
+ [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
-CLASS: {
- { +superclass+ "NSOpenGLView" }
- { +name+ "FactorView" }
- { +protocols+ { "NSTextInput" } }
-}
+CLASS: FactorView < NSOpenGLView NSTextInput
+[
+ ! Rendering
+ METHOD: void drawRect: NSRect rect [ self window [ draw-world ] when* ]
-! Rendering
-{ "drawRect:" void { id SEL NSRect }
- [ 2drop window draw-world ]
-}
+ ! Events
+ METHOD: char acceptsFirstMouse: id event [ 1 ]
-! Events
-{ "acceptsFirstMouse:" char { id SEL id }
- [ 3drop 1 ]
-}
+ METHOD: void mouseEntered: id event [ self event send-mouse-moved ]
-{ "mouseEntered:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void mouseExited: id event [ forget-rollover ]
-{ "mouseExited:" void { id SEL id }
- [ 3drop forget-rollover ]
-}
+ METHOD: void mouseMoved: id event [ self event send-mouse-moved ]
-{ "mouseMoved:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void mouseDragged: id event [ self event send-mouse-moved ]
-{ "mouseDragged:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ]
-{ "rightMouseDragged:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ]
-{ "otherMouseDragged:" void { id SEL id }
- [ nip send-mouse-moved ]
-}
+ METHOD: void mouseDown: id event [ self event send-button-down$ ]
-{ "mouseDown:" void { id SEL id }
- [ nip send-button-down$ ]
-}
-
-{ "mouseUp:" void { id SEL id }
- [ nip send-button-up$ ]
-}
+ METHOD: void mouseUp: id event [ self event send-button-up$ ]
-{ "rightMouseDown:" void { id SEL id }
- [ nip send-button-down$ ]
-}
+ METHOD: void rightMouseDown: id event [ self event send-button-down$ ]
-{ "rightMouseUp:" void { id SEL id }
- [ nip send-button-up$ ]
-}
+ METHOD: void rightMouseUp: id event [ self event send-button-up$ ]
-{ "otherMouseDown:" void { id SEL id }
- [ nip send-button-down$ ]
-}
+ METHOD: void otherMouseDown: id event [ self event send-button-down$ ]
-{ "otherMouseUp:" void { id SEL id }
- [ nip send-button-up$ ]
-}
+ METHOD: void otherMouseUp: id event [ self event send-button-up$ ]
-{ "scrollWheel:" void { id SEL id }
- [ nip send-scroll$ ]
-}
+ METHOD: void scrollWheel: id event [ self event send-scroll$ ]
-{ "keyDown:" void { id SEL id }
- [ nip send-key-down-event ]
-}
+ METHOD: void keyDown: id event [ self event send-key-down-event ]
-{ "keyUp:" void { id SEL id }
- [ nip send-key-up-event ]
-}
+ METHOD: void keyUp: id event [ self event send-key-up-event ]
-{ "validateUserInterfaceItem:" char { id SEL id }
+ METHOD: char validateUserInterfaceItem: id event
[
- nip -> action
- 2dup [ window ] [ utf8 alien>string ] bi* validate-action
- [ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if
+ self window [
+ event -> action utf8 alien>string validate-action
+ [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if
+ ] [ 0 ] if*
]
-}
-{ "undo:" id { id SEL id }
- [ nip undo-action send-action$ ]
-}
+ METHOD: id undo: id event [ self event undo-action send-action$ f ]
-{ "redo:" id { id SEL id }
- [ nip redo-action send-action$ ]
-}
+ METHOD: id redo: id event [ self event redo-action send-action$ f ]
-{ "cut:" id { id SEL id }
- [ nip cut-action send-action$ ]
-}
+ METHOD: id cut: id event [ self event cut-action send-action$ f ]
-{ "copy:" id { id SEL id }
- [ nip copy-action send-action$ ]
-}
+ METHOD: id copy: id event [ self event copy-action send-action$ f ]
-{ "paste:" id { id SEL id }
- [ nip paste-action send-action$ ]
-}
+ METHOD: id paste: id event [ self event paste-action send-action$ f ]
-{ "delete:" id { id SEL id }
- [ nip delete-action send-action$ ]
-}
+ METHOD: id delete: id event [ self event delete-action send-action$ f ]
-{ "selectAll:" id { id SEL id }
- [ nip select-all-action send-action$ ]
-}
+ METHOD: id selectAll: id event [ self event select-all-action send-action$ f ]
-{ "newDocument:" id { id SEL id }
- [ nip new-action send-action$ ]
-}
+ METHOD: id newDocument: id event [ self event new-action send-action$ f ]
-{ "openDocument:" id { id SEL id }
- [ nip open-action send-action$ ]
-}
+ METHOD: id openDocument: id event [ self event open-action send-action$ f ]
-{ "saveDocument:" id { id SEL id }
- [ nip save-action send-action$ ]
-}
+ METHOD: id saveDocument: id event [ self event save-action send-action$ f ]
-{ "saveDocumentAs:" id { id SEL id }
- [ nip save-as-action send-action$ ]
-}
+ METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ f ]
-{ "revertDocumentToSaved:" id { id SEL id }
- [ nip revert-action send-action$ ]
-}
+ METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ f ]
-! Multi-touch gestures: this is undocumented.
-! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
-{ "magnifyWithEvent:" void { id SEL id }
+ ! Multi-touch gestures
+ METHOD: void magnifyWithEvent: id event
[
- nip
+ self event
dup -> deltaZ sgn {
{ 1 [ zoom-in-action send-action$ ] }
{ -1 [ zoom-out-action send-action$ ] }
{ 0 [ 2drop ] }
} case
]
-}
-{ "swipeWithEvent:" void { id SEL id }
+ METHOD: void swipeWithEvent: id event
[
- nip
+ self event
dup -> deltaX sgn {
{ 1 [ left-action send-action$ ] }
{ -1 [ right-action send-action$ ] }
}
} case
]
-}
-! "rotateWithEvent:" void { id SEL id }}
+ METHOD: char acceptsFirstResponder [ 1 ]
-{ "acceptsFirstResponder" char { id SEL }
- [ 2drop 1 ]
-}
-
-! Services
-{ "validRequestorForSendType:returnType:" id { id SEL id id }
+ ! Services
+ METHOD: id validRequestorForSendType: id sendType returnType: id returnType
[
! We return either self or nil
- [ over window-focus ] 2dip
- valid-service? [ drop ] [ 2drop f ] if
+ self window [
+ world-focus sendType returnType
+ valid-service? [ self ] [ f ] if
+ ] [ f ] if*
]
-}
-{ "writeSelectionToPasteboard:types:" char { id SEL id id }
+ METHOD: char writeSelectionToPasteboard: id pboard types: id types
[
- CF>string-array NSStringPboardType swap member? [
- [ drop window-focus gadget-selection ] dip over
- [ set-pasteboard-string 1 ] [ 2drop 0 ] if
- ] [ 3drop 0 ] if
+ NSStringPboardType types CF>string-array member? [
+ self window [
+ world-focus gadget-selection
+ [ pboard set-pasteboard-string 1 ] [ 0 ] if*
+ ] [ 0 ] if*
+ ] [ 0 ] if
]
-}
-{ "readSelectionFromPasteboard:" char { id SEL id }
+ METHOD: char readSelectionFromPasteboard: id pboard
[
- pasteboard-string dup [
- [ drop window ] dip swap user-input 1
- ] [ 3drop 0 ] if
+ self window :> window
+ window [
+ pboard pasteboard-string
+ [ window user-input 1 ] [ 0 ] if*
+ ] [ 0 ] if
]
-}
-! Text input
-{ "insertText:" void { id SEL id }
- [ nip CF>string swap window user-input ]
-}
+ ! Text input
+ METHOD: void insertText: id text
+ [
+ self window :> window
+ window [
+ text CF>string window user-input
+ ] when
+ ]
-{ "hasMarkedText" char { id SEL }
- [ 2drop 0 ]
-}
+ METHOD: char hasMarkedText [ 0 ]
-{ "markedRange" NSRange { id SEL }
- [ 2drop 0 0 <NSRange> ]
-}
+ METHOD: NSRange markedRange [ 0 0 <NSRange> ]
-{ "selectedRange" NSRange { id SEL }
- [ 2drop 0 0 <NSRange> ]
-}
+ METHOD: NSRange selectedRange [ 0 0 <NSRange> ]
-{ "setMarkedText:selectedRange:" void { id SEL id NSRange }
- [ 2drop 2drop ]
-}
+ METHOD: void setMarkedText: id text selectedRange: NSRange range [ ]
-{ "unmarkText" void { id SEL }
- [ 2drop ]
-}
+ METHOD: void unmarkText [ ]
-{ "validAttributesForMarkedText" id { id SEL }
- [ 2drop NSArray -> array ]
-}
+ METHOD: id validAttributesForMarkedText [ NSArray -> array ]
-{ "attributedSubstringFromRange:" id { id SEL NSRange }
- [ 3drop f ]
-}
+ METHOD: id attributedSubstringFromRange: NSRange range [ f ]
-{ "characterIndexForPoint:" NSUInteger { id SEL NSPoint }
- [ 3drop 0 ]
-}
+ METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ]
-{ "firstRectForCharacterRange:" NSRect { id SEL NSRange }
- [ 3drop 0 0 0 0 <CGRect> ]
-}
+ METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 <CGRect> ]
-{ "conversationIdentifier" NSInteger { id SEL }
- [ drop alien-address ]
-}
+ METHOD: NSInteger conversationIdentifier [ self alien-address ]
-! Initialization
-{ "updateFactorGadgetSize:" void { id SEL id }
- [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
-}
+ ! Initialization
+ METHOD: void updateFactorGadgetSize: id notification
+ [
+ self window :> window
+ window [
+ self view-dim window dim<< yield
+ ] when
+ ]
-{ "doCommandBySelector:" void { id SEL SEL }
- [ 3drop ]
-}
+ METHOD: void doCommandBySelector: SEL selector [ ]
-{ "initWithFrame:pixelFormat:" id { id SEL NSRect id }
+ METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat
[
- [ drop ] 2dip
- SUPER-> initWithFrame:pixelFormat:
+ self frame pixelFormat SUPER-> initWithFrame:pixelFormat:
dup dup add-resize-observer
]
-}
-{ "isOpaque" char { id SEL }
- [
- 2drop 0
- ]
-}
+ METHOD: char isOpaque [ 0 ]
-{ "dealloc" void { id SEL }
+ METHOD: void dealloc
[
- drop
- [ unregister-window ]
- [ remove-observer ]
- [ SUPER-> dealloc ]
- tri
+ self remove-observer
+ self SUPER-> dealloc
]
-} ;
+]
: sync-refresh-to-screen ( GLView -- )
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
: save-position ( world window -- )
-> frame CGRect-top-left 2array >>window-loc drop ;
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorWindowDelegate" }
-}
-
-{ "windowDidMove:" void { id SEL id }
+CLASS: FactorWindowDelegate < NSObject
+[
+ METHOD: void windowDidMove: id notification
[
- 2nip -> object [ -> contentView window ] keep save-position
+ notification -> object -> contentView window
+ [ notification -> object save-position ] when*
]
-}
-{ "windowDidBecomeKey:" void { id SEL id }
+ METHOD: void windowDidBecomeKey: id notification
[
- 2nip -> object -> contentView window focus-world
+ notification -> object -> contentView window
+ [ focus-world ] when*
]
-}
-{ "windowDidResignKey:" void { id SEL id }
+ METHOD: void windowDidResignKey: id notification
[
forget-rollover
- 2nip -> object -> contentView
- dup -> isInFullScreenMode zero?
- [ window unfocus-world ]
- [ drop ] if
+ notification -> object -> contentView :> view
+ view window :> window
+ window [
+ view -> isInFullScreenMode 0 =
+ [ window unfocus-world ] when
+ ] when
]
-}
-{ "windowShouldClose:" char { id SEL id }
- [
- 3drop 1
- ]
-}
+ METHOD: char windowShouldClose: id notification [ 1 ]
-{ "windowWillClose:" void { id SEL id }
+ METHOD: void windowWillClose: id notification
[
- 2nip -> object -> contentView window ungraft
+ notification -> object -> contentView
+ [ window ungraft ] [ unregister-window ] bi
]
-} ;
+]
: install-window-delegate ( window -- )
FactorWindowDelegate install-delegate ;
! Copyright (C) 2010 Anton Gorenko, Philipp Brüschweiler.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.accessors alien.c-types alien.data alien.enums
+USING: accessors alien.accessors alien.c-types alien.data
alien.strings arrays assocs classes.struct command-line destructors
gdk.ffi gdk.gl.ffi glib.ffi gobject.ffi gtk.ffi gtk.gl.ffi
io.backend.unix.multiplexers io.encodings.utf8 io.thread kernel libc
C: <gtk-clipboard> gtk-clipboard
-PIXEL-FORMAT-ATTRIBUTE-TABLE: gl-config-attribs { $[ GDK_GL_USE_GL enum>number GDK_GL_RGBA enum>number ] } H{
- { double-buffered { $[ GDK_GL_DOUBLEBUFFER enum>number ] } }
- { stereo { $[ GDK_GL_STEREO enum>number ] } }
- ! { offscreen { $[ GDK_GL_DRAWABLE_TYPE enum>number ] 2 } }
- ! { fullscreen { $[ GDK_GL_DRAWABLE_TYPE enum>number ] 1 } }
- ! { windowed { $[ GDK_GL_DRAWABLE_TYPE enum>number ] 1 } }
- { color-bits { $[ GDK_GL_BUFFER_SIZE enum>number ] } }
- { red-bits { $[ GDK_GL_RED_SIZE enum>number ] } }
- { green-bits { $[ GDK_GL_GREEN_SIZE enum>number ] } }
- { blue-bits { $[ GDK_GL_BLUE_SIZE enum>number ] } }
- { alpha-bits { $[ GDK_GL_ALPHA_SIZE enum>number ] } }
- { accum-red-bits { $[ GDK_GL_ACCUM_RED_SIZE enum>number ] } }
- { accum-green-bits { $[ GDK_GL_ACCUM_GREEN_SIZE enum>number ] } }
- { accum-blue-bits { $[ GDK_GL_ACCUM_BLUE_SIZE enum>number ] } }
- { accum-alpha-bits { $[ GDK_GL_ACCUM_ALPHA_SIZE enum>number ] } }
- { depth-bits { $[ GDK_GL_DEPTH_SIZE enum>number ] } }
- { stencil-bits { $[ GDK_GL_STENCIL_SIZE enum>number ] } }
- { aux-buffers { $[ GDK_GL_AUX_BUFFERS enum>number ] } }
- { sample-buffers { $[ GDK_GL_SAMPLE_BUFFERS enum>number ] } }
- { samples { $[ GDK_GL_SAMPLES enum>number ] } }
+PIXEL-FORMAT-ATTRIBUTE-TABLE: gl-config-attribs ${ GDK_GL_USE_GL GDK_GL_RGBA } H{
+ { double-buffered ${ GDK_GL_DOUBLEBUFFER } }
+ { stereo ${ GDK_GL_STEREO } }
+ ! { offscreen ${ GDK_GL_DRAWABLE_TYPE 2 } }
+ ! { fullscreen ${ GDK_GL_DRAWABLE_TYPE 1 } }
+ ! { windowed ${ GDK_GL_DRAWABLE_TYPE 1 } }
+ { color-bits ${ GDK_GL_BUFFER_SIZE } }
+ { red-bits ${ GDK_GL_RED_SIZE } }
+ { green-bits ${ GDK_GL_GREEN_SIZE } }
+ { blue-bits ${ GDK_GL_BLUE_SIZE } }
+ { alpha-bits ${ GDK_GL_ALPHA_SIZE } }
+ { accum-red-bits ${ GDK_GL_ACCUM_RED_SIZE } }
+ { accum-green-bits ${ GDK_GL_ACCUM_GREEN_SIZE } }
+ { accum-blue-bits ${ GDK_GL_ACCUM_BLUE_SIZE } }
+ { accum-alpha-bits ${ GDK_GL_ACCUM_ALPHA_SIZE } }
+ { depth-bits ${ GDK_GL_DEPTH_SIZE } }
+ { stencil-bits ${ GDK_GL_STENCIL_SIZE } }
+ { aux-buffers ${ GDK_GL_AUX_BUFFERS } }
+ { sample-buffers ${ GDK_GL_SAMPLE_BUFFERS } }
+ { samples ${ GDK_GL_SAMPLES } }
}
M: gtk-ui-backend (make-pixel-format)
with-out-parameters ;
CONSTANT: events-mask
- {
+ flags{
GDK_POINTER_MOTION_MASK
GDK_POINTER_MOTION_HINT_MASK
GDK_ENTER_NOTIFY_MASK
CONSTANT: modifiers
{
- { S+ $[ GDK_SHIFT_MASK enum>number ] }
- { C+ $[ GDK_CONTROL_MASK enum>number ] }
- { A+ $[ GDK_MOD1_MASK enum>number ] }
+ { S+ $ GDK_SHIFT_MASK }
+ { C+ $ GDK_CONTROL_MASK }
+ { A+ $ GDK_MOD1_MASK }
}
CONSTANT: action-key-codes
H{
- ${ GDK_BackSpace "BACKSPACE" }
- ${ GDK_Tab "TAB" }
- ${ GDK_Return "RET" }
- ${ GDK_KP_Enter "ENTER" }
- ${ GDK_Escape "ESC" }
- ${ GDK_Delete "DELETE" }
- ${ GDK_Home "HOME" }
- ${ GDK_Left "LEFT" }
- ${ GDK_Up "UP" }
- ${ GDK_Right "RIGHT" }
- ${ GDK_Down "DOWN" }
- ${ GDK_Page_Up "PAGE_UP" }
- ${ GDK_Page_Down "PAGE_DOWN" }
- ${ GDK_End "END" }
- ${ GDK_Begin "BEGIN" }
- ${ GDK_F1 "F1" }
- ${ GDK_F2 "F2" }
- ${ GDK_F3 "F3" }
- ${ GDK_F4 "F4" }
- ${ GDK_F5 "F5" }
- ${ GDK_F6 "F6" }
- ${ GDK_F7 "F7" }
- ${ GDK_F8 "F8" }
- ${ GDK_F9 "F9" }
- ${ GDK_F10 "F10" }
- ${ GDK_F11 "F11" }
- ${ GDK_F12 "F12" }
+ { $ GDK_BackSpace "BACKSPACE" }
+ { $ GDK_Tab "TAB" }
+ { $ GDK_Return "RET" }
+ { $ GDK_KP_Enter "ENTER" }
+ { $ GDK_Escape "ESC" }
+ { $ GDK_Delete "DELETE" }
+ { $ GDK_Home "HOME" }
+ { $ GDK_Left "LEFT" }
+ { $ GDK_Up "UP" }
+ { $ GDK_Right "RIGHT" }
+ { $ GDK_Down "DOWN" }
+ { $ GDK_Page_Up "PAGE_UP" }
+ { $ GDK_Page_Down "PAGE_DOWN" }
+ { $ GDK_End "END" }
+ { $ GDK_Begin "BEGIN" }
+ { $ GDK_F1 "F1" }
+ { $ GDK_F2 "F2" }
+ { $ GDK_F3 "F3" }
+ { $ GDK_F4 "F4" }
+ { $ GDK_F5 "F5" }
+ { $ GDK_F6 "F6" }
+ { $ GDK_F7 "F7" }
+ { $ GDK_F8 "F8" }
+ { $ GDK_F9 "F9" }
+ { $ GDK_F10 "F10" }
+ { $ GDK_F11 "F11" }
+ { $ GDK_F12 "F12" }
}
: event-modifiers ( event -- seq )
: scroll-direction ( event -- pair )
direction>> {
- ${ GDK_SCROLL_UP { 0 -1 } }
- ${ GDK_SCROLL_DOWN { 0 1 } }
- ${ GDK_SCROLL_LEFT { -1 0 } }
- ${ GDK_SCROLL_RIGHT { 1 0 } }
+ { $ GDK_SCROLL_UP { 0 -1 } }
+ { $ GDK_SCROLL_DOWN { 0 1 } }
+ { $ GDK_SCROLL_LEFT { -1 0 } }
+ { $ GDK_SCROLL_RIGHT { 1 0 } }
} at ;
: mouse-event>gesture ( event -- modifiers button loc )
yield t ;
CONSTANT: poll-fd-events
- {
+ flags{
G_IO_IN
G_IO_OUT
G_IO_PRI
: create-poll-fd ( -- poll-fd )
GPollFD malloc-struct &free
mx get fd>> >>fd
- poll-fd-events [ enum>number ] [ bitor ] map-reduce >>events ;
+ poll-fd-events >>events ;
: init-io-event-source ( -- )
GSourceFuncs malloc-struct &free
f connect-signal-with-data ;
:: connect-signals ( win -- )
- win events-mask [ enum>number ] [ bitor ] map-reduce
- gtk_widget_add_events
+ win events-mask gtk_widget_add_events
win "expose-event" [ on-expose yield ]
GtkWidget:expose-event connect-signal
2drop window handle>> im-context>>
[ gtk_im_context_focus_out ] [ gtk_im_context_reset ] bi f ;
-: im-on-destroy ( sender user-data -- result )
+: im-on-destroy ( sender user-data -- )
nip [ f gtk_im_context_set_client_window ]
- [ g_object_unref ] bi f ;
+ [ g_object_unref ] bi ;
! for testing only
CONSTANT: window-controls>decor-flags
H{
{ close-button 0 }
- { minimize-button $[ GDK_DECOR_MINIMIZE enum>number ] }
- { maximize-button $[ GDK_DECOR_MAXIMIZE enum>number ] }
- { resize-handles $[ GDK_DECOR_RESIZEH enum>number ] }
- { small-title-bar $[ GDK_DECOR_TITLE enum>number ] }
- { normal-title-bar $[ GDK_DECOR_TITLE enum>number ] }
+ { minimize-button $ GDK_DECOR_MINIMIZE }
+ { maximize-button $ GDK_DECOR_MAXIMIZE }
+ { resize-handles $ GDK_DECOR_RESIZEH }
+ { small-title-bar $ GDK_DECOR_TITLE }
+ { normal-title-bar $ GDK_DECOR_TITLE }
{ textured-background 0 }
}
CONSTANT: window-controls>func-flags
H{
- { close-button $[ GDK_FUNC_CLOSE enum>number ] }
- { minimize-button $[ GDK_FUNC_MINIMIZE enum>number ] }
- { maximize-button $[ GDK_FUNC_MAXIMIZE enum>number ] }
- { resize-handles $[ GDK_FUNC_RESIZE enum>number ] }
+ { close-button $ GDK_FUNC_CLOSE }
+ { minimize-button $ GDK_FUNC_MINIMIZE }
+ { maximize-button $ GDK_FUNC_MAXIMIZE }
+ { resize-handles $ GDK_FUNC_RESIZE }
{ small-title-bar 0 }
{ normal-title-bar 0 }
{ textured-background 0 }
] [
[ gtk_widget_get_window ] dip
window-controls>decor-flags symbols>flags
- GDK_DECOR_BORDER enum>number bitor gdk_window_set_decorations
+ GDK_DECOR_BORDER bitor gdk_window_set_decorations
] [
[ gtk_widget_get_window ] dip
window-controls>func-flags symbols>flags
- GDK_FUNC_MOVE enum>number bitor gdk_window_set_functions
+ GDK_FUNC_MOVE bitor gdk_window_set_functions
] 2tri ;
: setup-gl ( world -- ? )
[
[ handle>> window>> ] [ handle>> ] bi*
- f t GDK_GL_RGBA_TYPE enum>number gtk_widget_set_gl_capability
+ f t GDK_GL_RGBA_TYPE gtk_widget_set_gl_capability
] with-world-pixel-format ;
: auto-position ( win loc -- )
: arb-make-pixel-format ( world attributes -- pf )
[ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 { int int }
- [ wglChoosePixelFormatARB win32-error=0/f ] [ ] with-out-parameters drop ;
+ [ wglChoosePixelFormatARB win32-error=0/f ] with-out-parameters drop ;
: arb-pixel-format-attribute ( pixel-format attribute -- value )
>WGL_ARB
[ drop f ] [
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
first <int> { int }
- [ wglGetPixelFormatAttribivARB win32-error=0/f ] [ ]
+ [ wglGetPixelFormatAttribivARB win32-error=0/f ]
with-out-parameters
] if-empty ;
[ [ execute( -- wm ) add-wm-handler ] with each ]
[ wm-handlers get-global set-at ] if ;
+: remove-wm-handler ( wm -- )
+ wm-handlers get-global delete-at ;
+
[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
XGetWindowProperty
Success assert=
]
+ with-out-parameters
[| type format n-atoms bytes-after atoms |
atoms n-atoms <direct-ulong-array> >array
atoms XFree
- ]
- with-out-parameters ;
+ ] call ;
: net-wm-hint-supported? ( atom -- ? )
supported-net-wm-hints member? ;
[ handle>> ] [ >glx-visual ] bi*
[ 2drop f ] [
first
- { int } [ glXGetConfig drop ] [ ] with-out-parameters
+ { int } [ glXGetConfig drop ] with-out-parameters
] if-empty ;
CONSTANT: modifiers
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays assocs calendar colors.constants
+USING: accessors timers arrays assocs calendar colors.constants
combinators combinators.short-circuit documents
documents.elements fry grouping kernel locals make math
math.functions math.order math.ranges math.rectangles
TUPLE: editor < line-gadget
caret-color
caret mark
-focused? blink blink-alarm ;
+focused? blink blink-timer ;
<PRIVATE
750 milliseconds blink-interval set-global
: stop-blinking ( editor -- )
- blink-alarm>> [ stop-alarm ] when* ;
+ blink-timer>> [ stop-timer ] when* ;
: start-blinking ( editor -- )
t >>blink
- blink-alarm>> [ restart-alarm ] when* ;
+ blink-timer>> [ restart-timer ] when* ;
: restart-blinking ( editor -- )
dup focused?>> [
[ dup mark>> activate-editor-model ]
[
[
- '[ _ blink-caret ] blink-interval get dup <alarm>
- ] keep blink-alarm<<
+ '[ _ blink-caret ] blink-interval get dup <timer>
+ ] keep blink-timer<<
] tri ;
M: editor ungraft*
- [ [ stop-blinking ] [ f >>blink-alarm drop ] bi ]
+ [ [ stop-blinking ] [ f >>blink-timer drop ] bi ]
[ dup caret>> deactivate-editor-model ]
[ dup mark>> deactivate-editor-model ] tri ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs continuations kernel math models
-namespaces opengl opengl.textures sequences io colors combinators
-combinators.short-circuit fry math.vectors math.rectangles cache
-ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.pixel-formats destructors literals strings ;
+USING: accessors arrays assocs cache colors combinators
+combinators.short-circuit concurrency.promises continuations
+destructors fry io kernel literals math math.rectangles
+math.vectors models namespaces opengl opengl.textures sequences
+strings ui.backend ui.gadgets ui.gadgets.tracks ui.gestures
+ui.pixel-formats ui.render ;
IN: ui.gadgets.worlds
SYMBOLS:
window-loc
pixel-format-attributes
background-color
+ promise
window-controls
window-resources ;
f >>active?
{ 0 0 } >>window-loc
f >>grab-input?
- V{ } clone >>window-resources ;
+ V{ } clone >>window-resources
+ <promise> >>promise ;
: initial-background-color ( attributes -- color )
window-controls>> textured-background swap member-eq?
{ $var-description "Global variable. The mouse button most recently pressed." } ;
HELP: hand-last-time
-{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link system-micros } "." } ;
+{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link nano-count } "." } ;
HELP: hand-buttons
{ $var-description "Global variable. A vector of mouse buttons currently held down." } ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes boxes calendar alarms combinators
+math.vectors classes.tuple classes boxes calendar timers combinators
sets columns fry deques ui.gadgets ui.gadgets.private ascii
combinators.short-circuit ;
FROM: namespaces => set ;
[ drag-gesture ]
300 milliseconds
100 milliseconds
- <alarm>
+ <timer>
[ drag-timer get-global >box ]
- [ start-alarm ] bi
+ [ start-timer ] bi
] when ;
: stop-drag-timer ( -- )
hand-buttons get-global empty? [
drag-timer get-global ?box
- [ stop-alarm ] [ drop ] if
+ [ stop-timer ] [ drop ] if
] when ;
: fire-motion ( -- )
error-list-model get-global [ drop all-errors ] <arrow>
<error-list-gadget> ;
+[ \ error-list-gadget reset-memoized ] "ui.tools.error-list" add-startup-hook
+
: show-error-list ( -- )
[ error-list-gadget eq? ] find-window
[ raise-window ] [ error-list-gadget "Errors" open-status-window ] if* ;
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel models namespaces arrays
-fry prettyprint ui ui.commands ui.gadgets ui.gadgets.labeled assocs
+fry prettyprint sequences inspector models.arrow fonts ui
+ui.commands ui.gadgets ui.gadgets.labeled assocs
ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
ui.gadgets.status-bar ui.gadgets.scrollers ui.gadgets.borders
-ui.gadgets.tables ui.gestures sequences inspector
-models.arrow fonts ;
+ui.gadgets.tables ui.gestures ui.tools.common ;
QUALIFIED-WITH: ui.tools.inspector i
IN: ui.tools.traceback
: <retainstack-display> ( model -- gadget )
[ retain>> ] "Retain stack" <stack-display> ;
-TUPLE: traceback-gadget < track ;
+TUPLE: traceback-gadget < tool ;
: <traceback-gadget> ( model -- gadget )
[
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs boxes io kernel math models namespaces make
-dlists deques sequences threads words continuations init
-combinators combinators.short-circuit hashtables
-concurrency.flags sets accessors calendar fry destructors
-ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gadgets.tracks ui.gestures ui.backend ui.render strings
-classes.tuple classes.tuple.parser lexer vocabs.parser parser ;
+USING: accessors arrays assocs boxes classes.tuple
+classes.tuple.parser combinators combinators.short-circuit
+concurrency.flags concurrency.promises continuations deques
+destructors dlists fry init kernel lexer make math namespaces
+parser sequences sets strings threads ui.backend ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures vocabs.parser
+words ;
IN: ui
<PRIVATE
: window ( handle -- world ) windows get-global at ;
-: window-focus ( handle -- gadget ) window world-focus ;
-
: register-window ( world handle -- )
#! Add the new window just below the topmost window. Why?
#! So that if the new window doesn't actually receive focus
[ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
[ [ (close-window) f ] change-handle drop ]
[ unfocus-world ]
+ [ promise>> t swap fulfill ]
} cleave ;
: init-ui ( -- )
FUNCTION: int getgrgid_r ( gid_t gid, group* grp, c-string buffer, size_t bufsize, group** result ) ;
FUNCTION: int getgrnam_r ( c-string name, group* grp, c-string buffer, size_t bufsize, group** result ) ;
FUNCTION: passwd* getpwent ( ) ;
+FUNCTION: void setpwent ( ) ;
+FUNCTION: void setpassent ( int stayopen ) ;
FUNCTION: passwd* getpwuid ( uid_t uid ) ;
FUNCTION: passwd* getpwnam ( c-string login ) ;
FUNCTION: int getpwnam_r ( c-string login, passwd* pwd, c-string buffer, size_t bufsize, passwd** result ) ;
FUNCTION: int setpriority ( int which, id_t who, int prio ) ;
FUNCTION: int getrusage ( int who, rusage* r_usage ) ;
FUNCTION: group* getgrent ;
+FUNCTION: void endgrent ( ) ;
FUNCTION: int gethostname ( c-string name, int len ) ;
FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ;
FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ;
FUNCTION: ushort htons ( ushort n ) ;
! FUNCTION: int issetugid ;
FUNCTION: int isatty ( int fildes ) ;
-FUNCTION: int ioctl ( int fd, ulong request, c-string argp ) ;
+FUNCTION: int ioctl ( int fd, ulong request, void* argp ) ;
FUNCTION: int lchown ( c-string path, uid_t owner, gid_t group ) ;
FUNCTION: int listen ( int s, int backlog ) ;
FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
HELP: with-effective-group
{ $values
- { "string/id" "a string or a group id" } { "quot" quotation } }
-{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call." } ;
+ { "string/id/f" "a string, a group id, or f" } { "quot" quotation } }
+{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
HELP: with-group-cache
{ $values
HELP: with-real-group
{ $values
- { "string/id" "a string or a group id" } { "quot" quotation } }
-{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
+ { "string/id/f" "a string or a group id" } { "quot" quotation } }
+{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
+
+HELP: ?group-id
+{ $values
+ { "string" string }
+ { "id" "a group id" }
+}
+{ $description "Returns a group id or throws an exception." } ;
+
+HELP: all-group-names
+{ $values
+
+ { "seq" sequence }
+}
+{ $description "Returns a sequence of group names as strings." } ;
+
+HELP: group-exists?
+{ $values
+ { "name/id" "a name or a group id" }
+ { "?" boolean }
+}
+{ $description "Returns a boolean representing the group's existence." } ;
ARTICLE: "unix.groups" "Unix groups"
"The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
$nl
-"Listing all groups:"
+"Listing all group structures:"
{ $subsections all-groups }
-"Real groups:"
+"Listing all group names:"
+{ $subsections all-group-names }
+"Checking if a group exists:"
+{ $subsections group-exists? }
+"Querying/setting the current real group:"
{ $subsections
real-group-name
real-group-id
set-real-group
}
-"Effective groups:"
+"Querying/setting the current effective group:"
{ $subsections
effective-group-name
effective-group-id
set-effective-group
}
+"Getting a group id from a group name or id:"
+{ $subsections
+ ?group-id
+}
"Combinators to change groups:"
{ $subsections
with-real-group
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test unix.groups kernel strings math ;
+USING: kernel math sequences strings tools.test unix.groups ;
IN: unix.groups.tests
[ ] [ all-groups drop ] unit-test
[ ] [ real-group-id group-name drop ] unit-test
[ "888888888888888" ] [ 888888888888888 group-name ] unit-test
+[ f ] [ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test
+[ f ] [ "please-oh-please-don't-have-a-group-named-this123lalala" group-exists? ] unit-test
+[ "please-oh-please-don't-have-a-group-named-this123lalala" ?group-id ] must-fail
+
+[ 3 ] [ f [ 3 ] with-effective-group ] unit-test
+[ 3 ] [ f [ 3 ] with-real-group ] unit-test
+
+[ f ]
+[ all-groups drop all-groups empty? ] unit-test
+
[ f ]
-[ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test
+[ all-group-names drop all-group-names empty? ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings io.encodings.utf8
-io.backend.unix kernel math sequences splitting strings
-combinators.short-circuit byte-arrays combinators
-accessors math.parser fry assocs namespaces continuations
-unix.users unix.utilities classes.struct unix ;
-IN: unix.groups
-
+USING: accessors alien alien.c-types alien.strings assocs
+byte-arrays classes.struct combinators
+combinators.short-circuit continuations fry io.backend.unix
+io.encodings.utf8 kernel math math.parser namespaces sequences
+splitting strings unix unix.ffi unix.users unix.utilities ;
QUALIFIED: unix.ffi
-
QUALIFIED: grouping
+IN: unix.groups
TUPLE: group id name passwd members ;
: group-id ( string -- id/f )
group-struct dup [ gr_gid>> ] when ;
+ERROR: no-group string ;
+
+: ?group-id ( string -- id )
+ dup group-struct [ nip gr_gid>> ] [ no-group ] if* ;
+
<PRIVATE
: >groups ( byte-array n -- groups )
user-name (user-groups) ;
: all-groups ( -- seq )
- [ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip ;
+ [ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip
+ endgrent ;
+
+: all-group-names ( -- seq )
+ all-groups [ name>> ] map ;
: <group-cache> ( -- assoc )
all-groups [ [ id>> ] keep ] H{ } map>assoc ;
: effective-group-name ( -- string )
effective-group-id group-name ; inline
+: group-exists? ( name/id -- ? ) group-id >boolean ;
+
GENERIC: set-real-group ( obj -- )
GENERIC: set-effective-group ( obj -- )
-: with-real-group ( string/id quot -- )
+: (with-real-group) ( string/id quot -- )
'[ _ set-real-group @ ]
real-group-id '[ _ set-real-group ] [ ] cleanup ; inline
-: with-effective-group ( string/id quot -- )
+: with-real-group ( string/id/f quot -- )
+ over [ (with-real-group) ] [ nip call ] if ; inline
+
+: (with-effective-group) ( string/id quot -- )
'[ _ set-effective-group @ ]
effective-group-id '[ _ set-effective-group ] [ ] cleanup ; inline
+: with-effective-group ( string/id/f quot -- )
+ over [ (with-effective-group) ] [ nip call ] if ; inline
+
<PRIVATE
: (set-real-group) ( id -- )
PRIVATE>
-M: string set-real-group ( string -- )
- group-id (set-real-group) ;
-
M: integer set-real-group ( id -- )
(set-real-group) ;
+M: string set-real-group ( string -- )
+ ?group-id (set-real-group) ;
+
M: integer set-effective-group ( id -- )
(set-effective-group) ;
M: string set-effective-group ( string -- )
- group-id (set-effective-group) ;
+ ?group-id (set-effective-group) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel alien.syntax alien.c-types math unix.types
-classes.struct accessors ;
+USING: accessors alien.c-types alien.syntax
+classes.struct kernel math unix.types ;
IN: unix.time
STRUCT: timeval
swap >>nsec
swap >>sec ;
+STRUCT: timezone
+ { tz_minuteswest int }
+ { tz_dsttime int } ;
+
STRUCT: tm
{ sec int }
{ min int }
FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;
FUNCTION: int gettimeofday ( timespec* TP, void* TZP ) ;
+FUNCTION: int settimeofday ( timeval* TP, timezone* TZP ) ;
+FUNCTION: int adjtime ( timeval* delta, timeval* olddelta ) ;
{ freebsd [ "unix.types.freebsd" require ] }
{ openbsd [ "unix.types.openbsd" require ] }
{ netbsd [ "unix.types.netbsd" require ] }
- { winnt [ ] }
} case
-
HELP: with-effective-user
{ $values
- { "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
+ { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
+{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
HELP: with-user-cache
{ $values
HELP: with-real-user
{ $values
- { "string/id" "a string or a uid" } { "quot" quotation } }
-{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
+ { "string/id/f" "a string, a uid, or f" } { "quot" quotation } }
+{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call. If the first parameter is " { $link f } ", the quotation is called as the current user." } ;
{
real-user-name real-user-id set-real-user
set-effective-user
} related-words
+HELP: ?user-id
+{ $values
+ { "string" string }
+ { "id/f" "an integer or " { $link f } }
+}
+{ $description "Returns a group id or throws an exception." } ;
+
+HELP: all-user-names
+{ $values
+
+ { "seq" sequence }
+}
+{ $description "Returns a sequence of group names as strings." } ;
+
+HELP: user-exists?
+{ $values
+ { "name/id" "a string or an integer" }
+ { "?" boolean }
+}
+{ $description "Returns a boolean representing the user's existence." } ;
+
ARTICLE: "unix.users" "Unix users"
"The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
$nl
"Listing all users:"
{ $subsections all-users }
-"Real user:"
+"Listing all user names:"
+{ $subsections all-user-names }
+"Checking if a user exists:"
+{ $subsections user-exists? }
+"Querying/setting the current real user:"
{ $subsections
real-user-name
real-user-id
set-real-user
}
-"Effective user:"
+"Querying/setting the current effective user:"
{ $subsections
effective-user-name
effective-user-id
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test unix.users kernel strings math ;
+USING: tools.test unix.users kernel strings math sequences ;
IN: unix.users.tests
[ ] [ all-users drop ] unit-test
[ f ] [ 89898989898989898989898989898 user-passwd ] unit-test
[ f ] [ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" user-id ] unit-test
+[ f ] [ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" user-exists? ] unit-test
+[ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" ?user-id ] must-fail
+
+[ 3 ] [ f [ 3 ] with-effective-user ] unit-test
+[ 3 ] [ f [ 3 ] with-real-user ] unit-test
+
+[ f ]
+[ all-users drop all-users empty? ] unit-test
+
+[ f ]
+[ all-user-names drop all-user-names empty? ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings io.encodings.utf8
-io.backend.unix kernel math sequences splitting strings
-combinators.short-circuit grouping byte-arrays combinators
-accessors math.parser fry assocs namespaces continuations
-vocabs.loader system classes.struct unix ;
-IN: unix.users
+USING: accessors alien alien.c-types alien.strings assocs
+byte-arrays classes.struct combinators
+combinators.short-circuit continuations fry grouping
+io.backend.unix io.encodings.utf8 kernel math math.parser
+namespaces sequences splitting strings system unix unix.ffi
+vocabs.loader ;
QUALIFIED: unix.ffi
+IN: unix.users
TUPLE: passwd user-name password uid gid gecos dir shell ;
} cleave ;
: with-pwent ( quot -- )
+ setpwent
[ unix.ffi:endpwent ] [ ] cleanup ; inline
PRIVATE>
[ unix.ffi:getpwent dup ] [ passwd>new-passwd ] produce nip
] with-pwent ;
+: all-user-names ( -- seq )
+ all-users [ user-name>> ] map ;
+
SYMBOL: user-cache
: <user-cache> ( -- assoc )
: user-id ( string -- id/f )
user-passwd dup [ uid>> ] when ;
+ERROR: no-user string ;
+
+: ?user-id ( string -- id/f )
+ dup user-passwd [ nip uid>> ] [ no-user ] if* ;
+
: real-user-id ( -- id )
unix.ffi:getuid ; inline
: effective-user-name ( -- string )
effective-user-id user-name ; inline
+: user-exists? ( name/id -- ? ) user-id >boolean ;
+
GENERIC: set-real-user ( string/id -- )
GENERIC: set-effective-user ( string/id -- )
-: with-real-user ( string/id quot -- )
+: (with-real-user) ( string/id quot -- )
'[ _ set-real-user @ ]
real-user-id '[ _ set-real-user ]
[ ] cleanup ; inline
-: with-effective-user ( string/id quot -- )
+: with-real-user ( string/id/f quot -- )
+ over [ (with-real-user) ] [ nip call ] if ; inline
+
+: (with-effective-user) ( string/id quot -- )
'[ _ set-effective-user @ ]
effective-user-id '[ _ set-effective-user ]
[ ] cleanup ; inline
+: with-effective-user ( string/id/f quot -- )
+ over [ (with-effective-user) ] [ nip call ] if ; inline
+
<PRIVATE
: (set-real-user) ( id -- )
PRIVATE>
-M: string set-real-user ( string -- )
- user-id (set-real-user) ;
-
M: integer set-real-user ( id -- )
(set-real-user) ;
+M: string set-real-user ( string -- )
+ ?user-id (set-real-user) ;
+
M: integer set-effective-user ( id -- )
(set-effective-user) ;
M: string set-effective-user ( string -- )
- user-id (set-effective-user) ;
+ ?user-id (set-effective-user) ;
os {
{ [ dup bsd? ] [ drop "unix.users.bsd" require ] }
[ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
+[ "~foo" ] [ "~foo" url-encode ] unit-test
+[ "~foo" ] [ "~foo" url-encode-full ] unit-test
+
+[ ":foo" ] [ ":foo" url-encode ] unit-test
+[ "%3Afoo" ] [ ":foo" url-encode-full ] unit-test
+
[ "hello world" ] [ "hello+world" query-decode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
[ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
+[ "foo=%3A" ] [ { { "foo" ":" } } assoc>query ] unit-test
+
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
[ "a" ] [ { { "a" f } } assoc>query ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ascii combinators combinators.short-circuit
sequences splitting fry namespaces make assocs arrays strings
[ letter? ]
[ LETTER? ]
[ digit? ]
- [ "/_-.:" member? ]
+ [ "-._~/:" member? ]
} 1|| ; foldable
! see http://tools.ietf.org/html/rfc3986#section-2.2
: assoc>query ( assoc -- str )
[
assoc-strings [
- [ url-encode ] dip
- [ [ url-encode "=" glue , ] with each ] [ , ] if*
+ [ url-encode-full ] dip
+ [ [ url-encode-full "=" glue , ] with each ] [ , ] if*
] assoc-each
] { } make "&" join ;
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: byte-arrays checksums checksums.md5 checksums.sha
-kernel math math.parser math.ranges random unicode.case
-sequences strings system io.binary ;
-
-IN: uuid
+USING: byte-arrays calendar checksums checksums.md5
+checksums.sha io.binary kernel math math.parser math.ranges
+random sequences strings system unicode.case ;
+IN: uuid
<PRIVATE
! 0x01b21dd213814000L is the number of 100-ns intervals
! between the UUID epoch 1582-10-15 00:00:00 and the
! Unix epoch 1970-01-01 00:00:00.
- system-micros 10 * HEX: 01b21dd213814000 +
+ gmt timestamp>micros 10 * HEX: 01b21dd213814000 +
[ -48 shift HEX: 0fff bitand ]
[ -32 shift HEX: ffff bitand ]
[ HEX: ffffffff bitand ]
: composition-enabled? ( -- ? )
windows-major 6 >=
- [ { bool } [ DwmIsCompositionEnabled drop ] [ ] with-out-parameters ]
+ [ { bool } [ DwmIsCompositionEnabled drop ] with-out-parameters ]
[ f ] if ;
! FUNCTION: SetProcessWorkingSetSize
! FUNCTION: SetStdHandle
! FUNCTION: SetSystemPowerState
-! FUNCTION: SetSystemTime
+FUNCTION: BOOL SetSystemTime ( SYSTEMTIME* lpSystemTime ) ;
! FUNCTION: SetSystemTimeAdjustment
! FUNCTION: SetTapeParameters
! FUNCTION: SetTapePosition
[ nip ]
[
swap (bitmap-info) DIB_RGB_COLORS { void* }
- [ f 0 CreateDIBSection ] [ ] with-out-parameters
+ [ f 0 CreateDIBSection ] with-out-parameters
] 2bi
[ [ SelectObject drop ] keep ] dip ;
swap ! icp
FALSE ! fTrailing
] if
- { int } [ ScriptStringCPtoX ole32-error ] [ ] with-out-parameters ;
+ { int } [ ScriptStringCPtoX ole32-error ] with-out-parameters ;
: x>line-offset ( x script-string -- n trailing )
ssa>> ! ssa
swap ! iX
- { int int } [ ScriptStringXtoCP ole32-error ] [ ] with-out-parameters ;
+ { int int } [ ScriptStringXtoCP ole32-error ] with-out-parameters ;
<PRIVATE
3array
4array
}
+"Resizing arrays:"
+{ $subsections resize-array }
"The class of two-element arrays:"
{ $subsections pair }
"Arrays can be accessed without bounds checks in a pointer unsafe way."
{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "array" array } }
{ $description "Create a new array with four elements, with " { $snippet "w" } " appearing first." } ;
-HELP: resize-array ( n array -- newarray )
-{ $values { "n" "a non-negative integer" } { "array" array } { "newarray" "a new array" } }
-{ $description "Creates a new array of " { $snippet "n" } " elements. The contents of the existing array are copied into the new array; if the new array is shorter, only an initial segment is copied, and if the new array is longer the remaining space is filled in with "{ $link f } "." } ;
+HELP: resize-array ( n array -- new-array )
+{ $values { "n" "a non-negative integer" } { "array" array } { "new-array" array } }
+{ $description "Resizes the array to have a length of " { $snippet "n" } " elements. When making the array shorter, this word may either create a new array or modify the existing array in place. When making the array longer, this word always allocates a new array, filling remaining space with " { $link f } "." }
+{ $side-effects "array" } ;
HELP: pair
{ $class-description "The class of two-element arrays, known as pairs." } ;
{ "dll-valid?" "alien.libraries" "primitive_dll_validp" (( dll -- ? )) }
{ "current-callback" "alien.private" "primitive_current_callback" (( -- n )) }
{ "<array>" "arrays" "primitive_array" (( n elt -- array )) }
- { "resize-array" "arrays" "primitive_resize_array" (( n array -- newarray )) }
+ { "resize-array" "arrays" "primitive_resize_array" (( n array -- new-array )) }
{ "(byte-array)" "byte-arrays" "primitive_uninitialized_byte_array" (( n -- byte-array )) }
{ "<byte-array>" "byte-arrays" "primitive_byte_array" (( n -- byte-array )) }
- { "resize-byte-array" "byte-arrays" "primitive_resize_byte_array" (( n byte-array -- newbyte-array )) }
+ { "resize-byte-array" "byte-arrays" "primitive_resize_byte_array" (( n byte-array -- new-byte-array )) }
{ "<tuple-boa>" "classes.tuple.private" "primitive_tuple_boa" (( slots... layout -- tuple )) }
{ "<tuple>" "classes.tuple.private" "primitive_tuple" (( layout -- tuple )) }
{ "modify-code-heap" "compiler.units" "primitive_modify_code_heap" (( alist update-existing? reset-pics? -- )) }
{ "set-string-nth-fast" "strings.private" "primitive_set_string_nth_fast" (( ch n string -- )) }
{ "(exit)" "system" "primitive_exit" (( n -- * )) }
{ "nano-count" "system" "primitive_nano_count" (( -- ns )) }
- { "system-micros" "system" "primitive_system_micros" (( -- us )) }
{ "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
{ "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) }
{ "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) }
3byte-array
4byte-array
}
-"Resizing byte-arrays:"
+"Resizing byte arrays:"
{ $subsections resize-byte-array } ;
ABOUT: "byte-arrays"
{ 1byte-array 2byte-array 3byte-array 4byte-array } related-words
-HELP: resize-byte-array ( n byte-array -- newbyte-array )
-{ $values { "n" "a non-negative integer" } { "byte-array" byte-array }
- { "newbyte-array" byte-array } }
-{ $description "Creates a new byte-array of n elements. The contents of the existing byte-array are copied into the new byte-array; if the new byte-array is shorter, only an initial segment is copied, and if the new byte-array is longer the remaining space is filled in with 0." } ;
+HELP: resize-byte-array ( n byte-array -- new-byte-array )
+{ $values { "n" "a non-negative integer" } { "byte-array" byte-array } { "new-byte-array" byte-array } }
+{ $description "Resizes the byte array to have a length of " { $snippet "n" } " elements. When making the byte array shorter, this word may either create a new byte array or modify the existing byte array in place. When making the byte array longer, this word always allocates a new byte array, filling remaining space with zeroes." }
+{ $side-effects "byte-array" } ;
[ scan , \ } parse-until % ] { } make ;
: parse-slot-name-delim ( end-delim string/f -- ? )
- #! This isn't meant to enforce any kind of policy, just
- #! to check for mistakes of this form:
- #!
- #! TUPLE: blahblah foo bing
- #!
- #! : ...
+ ! Check for mistakes of this form:
+ !
+ ! TUPLE: blahblah foo bing
+ !
+ ! : ...
{
- { [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond nip ;
: parse-tuple-slots-delim ( end-delim -- )
- dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+ dup scan-token parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
: parse-slot-name ( string/f -- ? )
";" swap parse-slot-name-delim ;
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 ] }
+ scan check-slot-name scan-object 2array , scan-token {
{ "}" [ ] }
[ bad-literal-tuple ]
} case ;
: (parse-slot-values) ( class slots -- )
2dup parse-slot-value
- scan {
- { f [ 2drop \ } unexpected-eof ] }
+ scan-token {
{ "{" [ (parse-slot-values) ] }
{ "}" [ 2drop ] }
[ 2nip bad-literal-tuple ]
assoc-union! seq>> boa>object ;
: parse-tuple-literal-slots ( class slots -- tuple )
- scan {
- { f [ unexpected-eof ] }
+ scan-token {
{ "f" [ drop \ } parse-until boa>object ] }
{ "{" [ 2dup parse-slot-values assoc>object ] }
{ "}" [ drop new ] }
: parse-effect-value ( token -- value )
":" ?tail [
- scan {
+ scan-token {
{ [ dup "(" = ] [ drop ")" parse-effect ] }
- { [ dup f = ] [ ")" unexpected-eof ] }
[ parse-word dup class? [ bad-effect ] unless ]
} cond 2array
] when ;
-USING: io.files io.streams.string io io.streams.byte-array
-tools.test kernel io.encodings.ascii io.encodings.utf8
-namespaces accessors io.encodings io.streams.limited ;
-IN: io.streams.encodings.tests
+USING: accessors io io.encodings io.encodings.ascii
+io.encodings.utf8 io.files io.streams.byte-array
+io.streams.string kernel namespaces tools.test ;
+IN: io.encodings.tests
[ { } ]
[ "vocab:io/test/empty-file.txt" ascii file-lines ]
"seek-test1" unique-file binary
[
[
- B{ 1 2 3 4 5 } write 0 seek-absolute seek-output
+ B{ 1 2 3 4 5 } write
+ tell-output 5 assert=
+ 0 seek-absolute seek-output
+ tell-output 0 assert=
B{ 3 } write
+ tell-output 1 assert=
] with-file-writer
] [
file-contents
"seek-test2" unique-file binary
[
[
- B{ 1 2 3 4 5 } write -1 seek-relative seek-output
+ B{ 1 2 3 4 5 } write
+ tell-output 5 assert=
+ -1 seek-relative seek-output
+ tell-output 4 assert=
B{ 3 } write
+ tell-output 5 assert=
] with-file-writer
] [
file-contents
"seek-test3" unique-file binary
[
[
- B{ 1 2 3 4 5 } write 1 seek-relative seek-output
+ B{ 1 2 3 4 5 } write
+ tell-output 5 assert=
+ 1 seek-relative seek-output
+ tell-output 6 assert=
B{ 3 } write
+ tell-output 7 assert=
] with-file-writer
] [
file-contents
set-file-contents
] [
[
- -3 seek-end seek-input 1 read
+ tell-input 0 assert=
+ -3 seek-end seek-input
+ tell-input 2 assert=
+ 1 read
+ tell-input 3 assert=
] with-file-reader
] 2bi
] unit-test
set-file-contents
] [
[
+ tell-input 0 assert=
3 seek-absolute seek-input
+ tell-input 3 assert=
-2 seek-relative seek-input
+ tell-input 1 assert=
1 read
+ tell-input 2 assert=
] with-file-reader
] 2bi
] unit-test
] with-file-reader
] must-fail
+[ ] [
+ "resource:misc/icons/Factor_48x48.png" binary [
+ 44 read drop
+ tell-input 44 assert=
+ -44 seek-relative seek-input
+ tell-input 0 assert=
+ ] with-file-reader
+] unit-test
+
[
"non-string-error" unique-file ascii [
{ } write
: stream-element-exemplar ( stream -- exemplar )
stream-element-type (stream-element-exemplar) ; inline
-: element-exemplar ( -- exemplar )
- input-stream get stream-element-exemplar ; inline
-
PRIVATE>
: each-stream-line ( stream quot -- )
HELP: scan
{ $values { "str/f" { $maybe string } } }
-{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." }
+{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word outputs " { $link f } " on end of input. To throw an error on end of input, use " { $link scan-token } " instead." }
+$parsing-note ;
+
+HELP: scan-token
+{ $values { "str" string } }
+{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace. This word throws " { $link unexpected-eof } " on end of input. To output " { $link f } " on end of input, use " { $link scan } " instead." }
$parsing-note ;
HELP: still-parsing?
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces math words strings
io vectors arrays math.parser combinators continuations
: 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 ;
+ 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 ;
[ line-text>> ]
} cleave subseq ;
-: parse-token ( lexer -- str/f )
+: parse-token ( lexer -- str/f )
dup still-parsing? [
dup skip-blank
dup still-parsing-line?
: unexpected-eof ( word -- * ) f unexpected ;
+: scan-token ( -- str ) scan [ "token" unexpected-eof ] unless* ;
+
: expect ( token -- )
- scan
- [ 2dup = [ 2drop ] [ unexpected ] if ]
- [ unexpected-eof ]
- if* ;
+ scan-token 2dup = [ 2drop ] [ unexpected ] if ;
: each-token ( ... end quot: ( ... token -- ... ) -- ... )
- [ scan ] 2dip {
- { [ 2over = ] [ 3drop ] }
- { [ pick not ] [ drop unexpected-eof ] }
- [ [ nip call ] [ each-token ] 2bi ]
- } cond ; inline recursive
+ [ scan-token ] 2dip 2over =
+ [ 3drop ] [ [ nip call ] [ each-token ] 2bi ] if ; inline recursive
: map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
collector [ each-token ] dip { } like ; inline
: <lexer-error> ( msg -- error )
\ lexer-error new
- lexer get [
- [ line>> >>line ]
- [ column>> >>column ] bi
- ] [
- [ line-text>> >>line-text ]
- [ parsing-words>> clone >>parsing-words ] bi
- ] bi
- swap >>error ;
+ lexer get [
+ [ line>> >>line ]
+ [ column>> >>column ] bi
+ ] [
+ [ line-text>> >>line-text ]
+ [ parsing-words>> clone >>parsing-words ] bi
+ ] bi
+ swap >>error ;
: simple-lexer-dump ( error -- )
[ line>> number>string ": " append ]
[ (parsing-word-lexer-dump) ] if ;
: lexer-dump ( error -- )
- dup parsing-words>> [ simple-lexer-dump ] [ last parsing-word-lexer-dump ] if-empty ;
+ 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
ARTICLE: "reading-ahead" "Reading ahead"
"Parsing words can consume input:"
+{ $subsections
+ scan-token
+ scan-object
+}
+"Lower-level words:"
{ $subsections
scan
scan-word
HELP: auto-use?
{ $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." }
{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "word-search-errors" } "." } ;
+
+HELP: scan-object
+{ $values { "object" object } }
+{ $description "Parses a literal representation of an object." }
+$parsing-note ;
! parse-tokens should do the right thing on EOF
[ "USING: kernel" eval( -- ) ]
-[ error>> T{ unexpected { want ";" } } = ] must-fail-with
+[ error>> T{ unexpected { want "token" } } = ] must-fail-with
! Test smudging
}
"Creating a string from a single character:"
{ $subsections 1string }
+"Resizing strings:"
+{ $subsections resize-string }
{ $see-also "syntax-strings" "sbufs" "unicode" "io.encodings" } ;
ABOUT: "strings"
HELP: resize-string ( n str -- newstr )
{ $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } }
-{ $description "Creates a new string " { $snippet "n" } " characters long The contents of the existing string are copied into the new string; if the new string is shorter, only an initial segment is copied, and if the new string is longer the remaining space is filled with " { $snippet "\\u000000" } "." } ;
+{ $description "Resizes the string to have a length of " { $snippet "n" } " elements. When making the string shorter, this word may either create a new string or modify the existing string in place. When making the string longer, this word always allocates a new string, filling remaining space with zeroes." }
+{ $side-effects "str" } ;
"#!" [ POSTPONE: ! ] define-core-syntax
- "IN:" [ scan set-current-vocab ] define-core-syntax
+ "IN:" [ scan-token set-current-vocab ] define-core-syntax
"<PRIVATE" [ begin-private ] define-core-syntax
"PRIVATE>" [ end-private ] define-core-syntax
- "USE:" [ scan use-vocab ] define-core-syntax
+ "USE:" [ scan-token use-vocab ] define-core-syntax
- "UNUSE:" [ scan unuse-vocab ] define-core-syntax
+ "UNUSE:" [ scan-token unuse-vocab ] define-core-syntax
"USING:" [ ";" [ use-vocab ] each-token ] define-core-syntax
- "QUALIFIED:" [ scan dup add-qualified ] define-core-syntax
+ "QUALIFIED:" [ scan-token dup add-qualified ] define-core-syntax
- "QUALIFIED-WITH:" [ scan scan add-qualified ] define-core-syntax
+ "QUALIFIED-WITH:" [ scan-token scan-token add-qualified ] define-core-syntax
"FROM:" [
- scan "=>" expect ";" parse-tokens add-words-from
+ scan-token "=>" expect ";" parse-tokens add-words-from
] define-core-syntax
"EXCLUDE:" [
- scan "=>" expect ";" parse-tokens add-words-excluding
+ scan-token "=>" expect ";" parse-tokens add-words-excluding
] define-core-syntax
"RENAME:" [
- scan scan "=>" expect scan add-renamed-word
+ scan-token scan-token "=>" expect scan-token add-renamed-word
] define-core-syntax
"HEX:" [ 16 parse-base ] define-core-syntax
"t" "syntax" lookup define-singleton-class
"CHAR:" [
- scan {
+ scan-token {
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape >string "" assert= ] }
[ name>char-hook get call( name -- char ) ]
] define-core-syntax
"DEFER:" [
- scan current-vocab create
+ scan-token current-vocab create
[ fake-definition ] [ set-word ] [ undefined-def define ] tri
] define-core-syntax
"PREDICATE:" [
CREATE-CLASS
- scan "<" assert=
+ "<" expect
scan-word
parse-definition define-predicate-class
] define-core-syntax
] define-core-syntax
"SLOT:" [
- scan define-protocol-slot
+ scan-token define-protocol-slot
] define-core-syntax
"C:" [
vm
image
}
-"Getting the current time:"
-{ $subsections
- system-micros
-}
"Getting a monotonically increasing nanosecond count:"
{ $subsections nano-count }
"Exiting the Factor VM:"
{ $values { "n" "an integer exit code" } }
{ $description "Exits the Factor process." } ;
-HELP: system-micros ( -- us )
-{ $values { "us" integer } }
-{ $description "Outputs the number of microseconds elapsed since midnight January 1, 1970." }
-{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting. For timing code, use " { $link nano-count } "." } ;
-
HELP: nano-count ( -- ns )
{ $values { "ns" integer } }
{ $description "Outputs a monotonically increasing count of nanoseconds elapsed since an arbitrary starting time. The difference of two calls to this word allows timing. This word is unaffected by system clock changes." }
-{ $notes "This is a low-level word. The " { $vocab-link "tools.time" } " vocabulary defines words to time code execution time. For system time, use " { $link system-micros } "." } ;
+{ $notes "This is a low-level word. The " { $vocab-link "tools.time" } " vocabulary defines words to time code execution time." } ;
HELP: image
{ $values { "path" "a pathname string" } }
$nl
"The second way is to create a configuration file. You can list additional vocabulary roots in a file that Factor reads at startup:"
{ $subsections "factor-roots" }
-"Finally, you can add vocabulary roots dynamically using a word:"
+"Finally, you can add vocabulary roots by calling a word from your " { $snippet "factor-rc" } " file (see " { $link "factor-rc" } "):"
{ $subsections add-vocab-root } ;
ARTICLE: "vocabs.roots" "Vocabulary roots"
] "vocabs.loader" add-startup-hook
: add-vocab-root ( root -- )
+ trim-tail-separators
[ vocab-roots get adjoin ]
[ add-vocab-root-hook get-global call( root -- ) ] bi ;
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors alien alien.c-types alien.handles alien.syntax
+destructors kernel math tools.test ;
+IN: alien.handles.tests
+
+TUPLE: thingy { x integer } ;
+C: <thingy> thingy
+
+CALLBACK: int thingy-callback ( uint thingy-handle ) ;
+CALLBACK: int thingy-ptr-callback ( void* thingy-handle ) ;
+
+: test-thingy-callback ( -- alien )
+ [ alien-handle> x>> 1 + ] thingy-callback ;
+
+: test-thingy-ptr-callback ( -- alien )
+ [ alien-handle-ptr> x>> 1 + ] thingy-ptr-callback ;
+
+: invoke-test-thingy-callback ( thingy -- n )
+ test-thingy-callback int { uint } cdecl alien-indirect ;
+: invoke-test-thingy-ptr-callback ( thingy -- n )
+ test-thingy-ptr-callback int { void* } cdecl alien-indirect ;
+
+[ t f ] [
+ [ 5 <thingy> <alien-handle> &release-alien-handle [ alien-handle? ] keep ] with-destructors
+ alien-handle?
+] unit-test
+
+[ t f ] [
+ [ 5 <thingy> <alien-handle-ptr> &release-alien-handle-ptr [ alien-handle-ptr? ] keep ] with-destructors
+ alien-handle-ptr?
+] unit-test
+
+[ 6 ] [
+ [
+ 5 <thingy> <alien-handle> &release-alien-handle
+ invoke-test-thingy-callback
+ ] with-destructors
+] unit-test
+
+[ 6 ] [
+ [
+ 5 <thingy> <alien-handle-ptr> &release-alien-handle-ptr
+ invoke-test-thingy-ptr-callback
+ ] with-destructors
+] unit-test
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: alien alien.destructors assocs kernel math math.bitwise
+namespaces ;
+IN: alien.handles
+
+<PRIVATE
+
+SYMBOLS: alien-handle-counter alien-handles ;
+
+alien-handle-counter [ 0 ] initialize
+alien-handles [ H{ } clone ] initialize
+
+: biggest-handle ( -- n )
+ -1 32 bits ; inline
+
+: (next-handle) ( -- n )
+ alien-handle-counter [ 1 + biggest-handle bitand dup ] change-global ; inline
+
+: next-handle ( -- n )
+ [ (next-handle) dup alien-handles get-global key? ] [ drop ] while ;
+
+PRIVATE>
+
+: <alien-handle> ( object -- int )
+ next-handle [ alien-handles get-global set-at ] keep ; inline
+: alien-handle> ( int -- object )
+ alien-handles get-global at ; inline
+
+: alien-handle? ( int -- ? )
+ alien-handles get-global key? >boolean ; inline
+
+: release-alien-handle ( int -- )
+ alien-handles get-global delete-at ; inline
+
+DESTRUCTOR: release-alien-handle
+
+: <alien-handle-ptr> ( object -- void* )
+ <alien-handle> <alien> ; inline
+: alien-handle-ptr> ( void* -- object )
+ alien-address alien-handle> ; inline
+
+: alien-handle-ptr? ( alien -- ? )
+ alien-address alien-handle? ; inline
+
+: release-alien-handle-ptr ( alien -- )
+ alien-address release-alien-handle ; inline
+
+DESTRUCTOR: release-alien-handle-ptr
+
--- /dev/null
+Generate integer handle values to allow Factor object references to be passed through the FFI
! (c)2009 Joe Groff bsd license
-USING: accessors alien audio classes.struct fry calendar alarms
+USING: accessors alien audio classes.struct fry calendar timers
combinators combinators.short-circuit destructors generalizations
kernel literals locals math openal sequences
sequences.generalizations specialized-arrays strings ;
listener
{ next-source integer }
clips
- update-alarm ;
+ update-timer ;
TUPLE: audio-clip < disposable
{ audio-engine audio-engine }
: start-audio ( audio-engine -- )
dup start-audio*
- dup '[ _ update-audio ] 20 milliseconds every >>update-alarm
+ dup '[ _ update-audio ] 20 milliseconds every >>update-timer
drop ;
: stop-audio ( audio-engine -- )
dup al-sources>> [
{
[ make-engine-current ]
- [ update-alarm>> [ stop-alarm ] when* ]
+ [ update-timer>> [ stop-timer ] when* ]
[ clips>> clone [ dispose ] each ]
[ al-sources>> free-sources ]
[
f >>al-sources
f >>clips
- f >>update-alarm
+ f >>update-timer
drop
]
[ al-context>> alcSuspendContext ]
! (c)2009 Joe Groff bsd license
-USING: accessors alarms audio audio.engine audio.loader calendar
+USING: accessors timers audio audio.engine audio.loader calendar
destructors io kernel locals math math.functions math.ranges specialized-arrays
sequences random math.vectors ;
FROM: alien.c-types => short ;
] when
engine update-audio
- ] 20 milliseconds every :> alarm
+ ] 20 milliseconds every :> timer
"Press Enter to stop the test." print
readln drop
- alarm stop-alarm
+ timer stop-timer
engine dispose ;
MAIN: audio-engine-test
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types classes.struct kernel memory
+system vm ;
+IN: benchmark.struct
+
+STRUCT: benchmark-data
+ { time ulonglong }
+ { data-room data-heap-room }
+ { code-room mark-sweep-sizes } ;
+
+STRUCT: benchmark-data-pair
+ { start benchmark-data }
+ { stop benchmark-data } ;
+
+: <benchmark-data> ( -- benchmark-data )
+ \ benchmark-data <struct>
+ nano-count >>time
+ code-room >>code-room
+ data-room >>data-room ; inline
+
+: <benchmark-data-pair> ( start stop -- benchmark-data-pair )
+ \ benchmark-data-pair <struct>
+ swap >>stop
+ swap >>start ; inline
+
+: with-benchmarking ( ... quot -- ... benchmark-data-pair )
+ <benchmark-data>
+ [ call ] dip
+ <benchmark-data> <benchmark-data-pair> ; inline
+
[ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
-[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } ]
-[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } turnaround ] unit-test
+[ H{ { "a" "a string" } { "b" H{ { "a" "アップルからの最新のニュースや情報を読む" } } } } ]
+[ H{ { "a" "a string" } { "b" H{ { "a" "アップルからの最新のニュースや情報を読む" } } } } turnaround ] unit-test
[ H{ { "a list" { 1 2.234 "hello world" } } } ]
[ H{ { "a list" { 1 2.234 "hello world" } } } turnaround ] unit-test
TUPLE: dbref ref id db ;
+TUPLE: mongo-timestamp incr seconds ;
+
+: <mongo-timestamp> ( incr seconds -- mongo-timestamp )
+ mongo-timestamp boa ;
+
+TUPLE: mongo-scoped-code code object ;
+
+: <mongo-scoped-code> ( code object -- mongo-scoped-code )
+ mongo-scoped-code boa ;
+
CONSTRUCTOR: dbref ( ref id -- dbref ) ;
: dbref>assoc ( dbref -- assoc )
CONSTANT: MDB_OID_FIELD "_id"
CONSTANT: MDB_META_FIELD "_mfd"
-CONSTANT: T_EOO 0
-CONSTANT: T_Double 1
-CONSTANT: T_Integer 16
-CONSTANT: T_Boolean 8
-CONSTANT: T_String 2
-CONSTANT: T_Object 3
-CONSTANT: T_Array 4
-CONSTANT: T_Binary 5
-CONSTANT: T_Undefined 6
-CONSTANT: T_OID 7
-CONSTANT: T_Date 9
-CONSTANT: T_NULL 10
-CONSTANT: T_Regexp 11
-CONSTANT: T_DBRef 12
-CONSTANT: T_Code 13
-CONSTANT: T_ScopedCode 17
-CONSTANT: T_Symbol 14
-CONSTANT: T_JSTypeMax 16
-CONSTANT: T_MaxKey 127
-
-CONSTANT: T_Binary_Function 1
-CONSTANT: T_Binary_Bytes 2
-CONSTANT: T_Binary_UUID 3
-CONSTANT: T_Binary_MD5 5
-CONSTANT: T_Binary_Custom 128
-
+CONSTANT: T_EOO 0
+CONSTANT: T_Double HEX: 1
+CONSTANT: T_String HEX: 2
+CONSTANT: T_Object HEX: 3
+CONSTANT: T_Array HEX: 4
+CONSTANT: T_Binary HEX: 5
+CONSTANT: T_Undefined HEX: 6
+CONSTANT: T_OID HEX: 7
+CONSTANT: T_Boolean HEX: 8
+CONSTANT: T_Date HEX: 9
+CONSTANT: T_NULL HEX: A
+CONSTANT: T_Regexp HEX: B
+CONSTANT: T_DBRef HEX: C
+CONSTANT: T_Code HEX: D
+CONSTANT: T_Symbol HEX: E
+CONSTANT: T_ScopedCode HEX: F
+CONSTANT: T_Integer HEX: 10
+CONSTANT: T_Timestamp HEX: 11
+CONSTANT: T_Integer64 HEX: 12
+CONSTANT: T_MinKey HEX: FF
+CONSTANT: T_MaxKey HEX: 7F
+
+CONSTANT: T_Binary_Default HEX: 0
+CONSTANT: T_Binary_Function HEX: 1
+CONSTANT: T_Binary_Bytes_Deprecated HEX: 2
+CONSTANT: T_Binary_UUID HEX: 3
+CONSTANT: T_Binary_MD5 HEX: 5
+CONSTANT: T_Binary_Custom HEX: 80
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs bson.constants calendar combinators
combinators.short-circuit io io.binary kernel math locals
+io.encodings.utf8 io.encodings
namespaces sequences serialize strings vectors byte-arrays ;
FROM: io.encodings.binary => binary ;
IN: bson.reader
-<PRIVATE
-
-TUPLE: element { type integer } name ;
-
-TUPLE: state
- { size initial: -1 }
- { exemplar assoc }
- result
- { scope vector }
- { elements vector } ;
+SYMBOL: state
-TYPED: (prepare-elements) ( -- elements-vector: vector )
- V{ } clone [ T_Object "" element boa swap push ] [ ] bi ; inline
+DEFER: stream>assoc
-: <state> ( exemplar -- state )
- [ state new ] dip
- {
- [ clone >>exemplar ]
- [ clone >>result ]
- [ V{ } clone [ push ] keep >>scope ]
- } cleave
- (prepare-elements) >>elements ;
+<PRIVATE
-TYPED: get-state ( -- state: state )
- state get ; inline
+DEFER: read-elements
-TYPED: read-int32 ( -- int32: integer )
+: read-int32 ( -- int32 )
4 read signed-le> ; inline
-TYPED: read-longlong ( -- longlong: integer )
+: read-longlong ( -- longlong )
8 read signed-le> ; inline
-TYPED: read-double ( -- double: float )
+: read-double ( -- double )
8 read le> bits>double ; inline
-TYPED: read-byte-raw ( -- byte-raw: byte-array )
+: read-byte-raw ( -- byte-raw )
1 read ; inline
-TYPED: read-byte ( -- byte: integer )
+: read-byte ( -- byte )
read-byte-raw first ; inline
-TYPED: read-cstring ( -- string: string )
- "\0" read-until drop >string ; inline
+: read-cstring ( -- string )
+ input-stream get utf8 <decoder>
+ "\0" swap stream-read-until drop ; inline
-TYPED: read-sized-string ( length: integer -- string: string )
- read 1 head-slice* >string ; inline
+: read-sized-string ( length -- string )
+ read binary [ read-cstring ] with-byte-reader ; inline
-TYPED: push-element ( type: integer name: string state: state -- )
- [ element boa ] dip elements>> push ; inline
+: read-timestamp ( -- timestamp )
+ 8 read [ 4 head signed-le> ] [ 4 tail signed-le> ] bi <mongo-timestamp> ;
-TYPED: pop-element ( state: state -- element: element )
- elements>> pop ; inline
+: object-result ( quot -- object )
+ [
+ state get clone
+ [ clear-assoc ] [ ] [ ] tri state
+ ] dip with-variable ; inline
-TYPED: peek-scope ( state: state -- ht )
- scope>> last ; inline
-
-: bson-object-data-read ( -- object )
- read-int32 drop get-state
- [ exemplar>> clone dup ] [ scope>> ] bi push ; inline
+: bson-object-data-read ( -- )
+ read-int32 drop read-elements ; inline recursive
: bson-binary-read ( -- binary )
read-int32 read-byte
{
- { T_Binary_Bytes [ read ] }
+ { T_Binary_Default [ read ] }
+ { T_Binary_Bytes_Deprecated [ drop read-int32 read ] }
{ T_Binary_Custom [ read bytes>object ] }
{ T_Binary_Function [ read ] }
[ drop read >string ]
TYPED: bson-oid-read ( -- oid: oid )
read-longlong read-int32 oid boa ; inline
-TYPED: element-data-read ( type: integer -- object )
- {
- { T_OID [ bson-oid-read ] }
- { T_String [ read-int32 read-sized-string ] }
- { T_Integer [ read-int32 ] }
- { T_Binary [ bson-binary-read ] }
- { T_Object [ bson-object-data-read ] }
- { T_Array [ bson-object-data-read ] }
- { T_Double [ read-double ] }
- { T_Boolean [ read-byte 1 = ] }
- { T_Date [ read-longlong millis>timestamp ] }
- { T_Regexp [ bson-regexp-read ] }
- { T_NULL [ f ] }
- } case ; inline
-
-TYPED: bson-array? ( type: integer -- ?: boolean )
- T_Array = ; inline
-
-TYPED: bson-object? ( type: integer -- ?: boolean )
- T_Object = ; inline
-
: check-object ( assoc -- object )
dup dbref-assoc? [ assoc>dbref ] when ; inline
-TYPED: fix-result ( assoc type: integer -- result )
+TYPED: element-data-read ( type: integer -- object )
{
- { T_Array [ values ] }
- { T_Object [ check-object ] }
- } case ; inline
-
-TYPED: end-element ( type: integer -- )
- { [ bson-object? ] [ bson-array? ] } 1||
- [ get-state pop-element drop ] unless ; inline
-
-TYPED: (>state<) ( -- state: state scope: vector element: element )
- get-state [ ] [ scope>> ] [ pop-element ] tri ; inline
-
-TYPED: (prepare-result) ( scope: vector element: element -- result )
- [ pop ] [ type>> ] bi* fix-result ; inline
-
-: bson-eoo-element-read ( -- cont?: boolean )
- (>state<)
- [ (prepare-result) ] [ ] [ drop empty? ] 2tri
- [ 2drop >>result drop f ]
- [ swap [ name>> ] [ last ] bi* set-at drop t ] if ; inline
-
-TYPED: (prepare-object) ( type: integer -- object )
- [ element-data-read ] [ end-element ] bi ; inline
-
-:: (read-object) ( type name state -- )
- state peek-scope :> scope
- type (prepare-object) name scope set-at ; inline
-
-TYPED: bson-not-eoo-element-read ( type: integer -- cont?: boolean )
- read-cstring get-state
- [ push-element ]
- [ (read-object) t ] 3bi ; inline
+ { T_OID [ bson-oid-read ] }
+ { T_String [ read-int32 read-sized-string ] }
+ { T_Integer [ read-int32 ] }
+ { T_Integer64 [ read-longlong ] }
+ { T_Binary [ bson-binary-read ] }
+ { T_Object [ [ bson-object-data-read ] object-result check-object ] }
+ { T_Array [ [ bson-object-data-read ] object-result values ] }
+ { T_Double [ read-double ] }
+ { T_Boolean [ read-byte 1 = ] }
+ { T_Date [ read-longlong millis>timestamp ] }
+ { T_Regexp [ bson-regexp-read ] }
+ { T_Timestamp [ read-timestamp ] }
+ { T_Code [ read-int32 read-sized-string ] }
+ { T_ScopedCode [ read-int32 drop read-cstring H{ } clone stream>assoc <mongo-scoped-code> ] }
+ { T_NULL [ f ] }
+ } case ; inline recursive
+
+TYPED: (read-object) ( type: integer name: string -- )
+ [ element-data-read ] dip state get set-at ; inline recursive
TYPED: (element-read) ( type: integer -- cont?: boolean )
dup T_EOO >
- [ bson-not-eoo-element-read ]
- [ drop bson-eoo-element-read ] if ; inline
+ [ read-cstring (read-object) t ]
+ [ drop f ] if ; inline recursive
: read-elements ( -- )
read-byte (element-read)
PRIVATE>
: stream>assoc ( exemplar -- assoc )
- <state> read-int32 >>size
- [ state [ read-elements ] with-variable ]
- [ result>> ] bi ;
+ clone [
+ state [ bson-object-data-read ] with-variable
+ ] keep ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs bson.constants byte-arrays
calendar combinators.short-circuit fry hashtables io io.binary
+io.encodings.utf8 io.encodings io.streams.byte-array
kernel linked-assocs literals math math.parser namespaces byte-vectors
quotations sequences serialize strings vectors dlists alien.accessors ;
FROM: words => word? word ;
TYPED: write-double ( real: float -- ) double>bits INT64-SIZE (>le) ; inline
+TYPED: write-utf8-string ( string: string -- )
+ output-stream get utf8 <encoder> stream-write ; inline
+
TYPED: write-cstring ( string: string -- )
- get-output [ length ] [ ] bi copy 0 write1 ; inline
+ write-utf8-string 0 write1 ; inline
: write-longlong ( object -- ) INT64-SIZE (>le) ; inline
TYPED: write-byte-array ( binary: byte-array -- )
[ length write-int32 ]
- [ T_Binary_Bytes write1 write ] bi ; inline
+ [ T_Binary_Default write1 write ] bi ; inline
TYPED: write-mdbregexp ( regexp: mdbregexp -- )
[ regexp>> write-cstring ]
[ length write-int32 ]
[ T_Binary_Custom write1 write ] bi ; inline
+: write-string-length ( string -- )
+ [ length>> 1 + ]
+ [ aux>> [ length ] [ 0 ] if* ] bi + write-int32 ; inline
+
TYPED: write-string ( string: string -- )
- '[ _ write-cstring ] with-length-prefix-excl ; inline
+ dup write-string-length write-cstring ; inline
TYPED: write-boolean ( bool: boolean -- )
[ 1 write1 ] [ 0 write1 ] if ; inline
--- /dev/null
+Joe Groff
+Doug Coleman
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays assocs calendar calendar.format
+combinators combinators.short-circuit fry io io.backend
+io.directories io.encodings.binary io.encodings.detect
+io.encodings.utf8 io.files io.files.info io.files.types
+io.files.unique io.launcher io.pathnames kernel locals math
+math.parser namespaces sequences sorting strings system
+unicode.categories xml.syntax xml.writer xmode.catalog
+xmode.marker xmode.tokens ;
+IN: codebook
+
+! Usage: "my/source/tree" codebook
+! Writes tree.opf, tree.ncx, and tree.html to a temporary directory
+! Writes tree.mobi to resource:codebooks
+! Requires kindlegen to compile tree.mobi for Kindle
+
+CONSTANT: codebook-style
+ {
+ { COMMENT1 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { COMMENT2 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { COMMENT3 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { COMMENT4 [ [XML <i><font color="#555555"><-></font></i> XML] ] }
+ { DIGIT [ [XML <font color="#333333"><-></font> XML] ] }
+ { FUNCTION [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD1 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD2 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD3 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { KEYWORD4 [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ { LABEL [ [XML <b><font color="#333333"><-></font></b> XML] ] }
+ { LITERAL1 [ [XML <font color="#333333"><-></font> XML] ] }
+ { LITERAL2 [ [XML <font color="#333333"><-></font> XML] ] }
+ { LITERAL3 [ [XML <font color="#333333"><-></font> XML] ] }
+ { LITERAL4 [ [XML <font color="#333333"><-></font> XML] ] }
+ { MARKUP [ [XML <b><font color="#333333"><-></font></b> XML] ] }
+ { OPERATOR [ [XML <b><font color="#111111"><-></font></b> XML] ] }
+ [ drop ]
+ }
+
+: first-line ( filename encoding -- line )
+ [ readln ] with-file-reader ;
+
+TUPLE: code-file
+ name encoding mode ;
+
+: include-file-name? ( name -- ? )
+ {
+ [ path-components [ "." head? ] any? not ]
+ [ link-info type>> +regular-file+ = ]
+ } 1&& ;
+
+: code-files ( dir -- files )
+ '[
+ [ include-file-name? ] filter [
+ dup detect-file dup binary?
+ [ f ] [ 2dup dupd first-line find-mode ] if
+ code-file boa
+ ] map [ mode>> ] filter [ name>> ] sort-with
+ ] with-directory-tree-files ;
+
+: html-name-char ( char -- str )
+ {
+ { [ dup alpha? ] [ 1string ] }
+ { [ dup digit? ] [ 1string ] }
+ [ >hex 6 CHAR: 0 pad-head "_" "_" surround ]
+ } cond ;
+
+: file-html-name ( name -- name )
+ [ html-name-char ] { } map-as concat ".html" append ;
+
+: toc-list ( files -- list )
+ [ name>> ] map natural-sort [
+ [ file-html-name ] keep
+ [XML <li><a href=<->><-></a></li> XML]
+ ] map ;
+
+! insert zero-width non-joiner between all characters so words can wrap anywhere
+: zwnj ( string -- s|t|r|i|n|g )
+ [ CHAR: \u00200c "" 2sequence ] { } map-as concat ;
+
+! We wrap every line in <tt> because Kindle tends to forget the font when
+! moving back pages
+: htmlize-tokens ( tokens line# -- html-tokens )
+ swap [
+ [ str>> zwnj ] [ id>> ] bi codebook-style case
+ ] map [XML <tt><font size="-2" color="#666666"><-></font> <-></tt> XML]
+ "\n" 2array ;
+
+: line#>string ( i line#len -- i-string )
+ [ number>string ] [ CHAR: \s pad-head ] bi* ;
+
+:: code>html ( dir file -- page )
+ file name>> :> name
+ "Generating HTML for " write name write "..." print flush
+ dir [ file [ name>> ] [ encoding>> ] bi file-lines ] with-directory :> lines
+ lines length 1 + number>string length :> line#len
+ file mode>> load-mode :> rules
+ f lines [| l i | l rules tokenize-line i 1 + line#len line#>string htmlize-tokens ]
+ map-index concat nip :> html-lines
+ <XML <html>
+ <head>
+ <title><-name-></title>
+ <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+ </head>
+ <body>
+ <h2><-name-></h2>
+ <pre><-html-lines-></pre>
+ <mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
+ </body>
+ </html> XML> ;
+
+:: code>toc-html ( dir name files -- html )
+ "Generating HTML table of contents" print flush
+
+ now timestamp>rfc822 :> timestamp
+ dir absolute-path :> source
+ dir [
+ files toc-list :> toc
+
+ <XML <html>
+ <head>
+ <title><-name-></title>
+ <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+ </head>
+ <body>
+ <h1><-name-></h1>
+ <font size="-2">Generated from<br/>
+ <b><tt><-source-></tt></b><br/>
+ at <-timestamp-></font><br/>
+ <br/>
+ <ul><-toc-></ul>
+ <mbp:pagebreak xmlns:mbp="http://www.mobipocket.com/mbp" />
+ </body>
+ </html> XML>
+ ] with-directory ;
+
+:: code>ncx ( dir name files -- xml )
+ "Generating NCX table of contents" print flush
+
+ files [| file i |
+ file name>> :> name
+ name file-html-name :> filename
+ i 2 + number>string :> istr
+
+ [XML <navPoint class="book" id=<-filename-> playOrder=<-istr->>
+ <navLabel><text><-name-></text></navLabel>
+ <content src=<-filename-> />
+ </navPoint> XML]
+ ] map-index :> file-nav-points
+
+ <XML <?xml version="1.0" encoding="UTF-8" ?>
+ <ncx version="2005-1" xmlns="http://www.daisy.org/z3986/2005/ncx/">
+ <navMap>
+ <navPoint class="book" id="toc" playOrder="1">
+ <navLabel><text>Table of Contents</text></navLabel>
+ <content src="_toc.html" />
+ </navPoint>
+ <-file-nav-points->
+ </navMap>
+ </ncx> XML> ;
+
+:: code>opf ( dir name files -- xml )
+ "Generating OPF manifest" print flush
+ name ".ncx" append :> ncx-name
+
+ files [
+ name>> file-html-name dup
+ [XML <item id=<-> href=<-> media-type="text/html" /> XML]
+ ] map :> html-manifest
+
+ files [ name>> file-html-name [XML <itemref idref=<-> /> XML] ] map :> html-spine
+
+ <XML <?xml version="1.0" encoding="UTF-8" ?>
+ <package
+ version="2.0"
+ xmlns="http://www.idpf.org/2007/opf"
+ unique-identifier=<-name->>
+ <metadata xmlns:dc="http://purl.org/dc/elements/1.1/">
+ <dc:title><-name-></dc:title>
+ <dc:language>en</dc:language>
+ <meta name="cover" content="my-cover-image" />
+ </metadata>
+ <manifest>
+ <item href="cover.jpg" id="my-cover-image" media-type="image/jpeg" />
+ <item id="html-toc" href="_toc.html" media-type="text/html" />
+ <-html-manifest->
+ <item id="toc" href=<-ncx-name-> media-type="application/x-dtbncx+xml" />
+ </manifest>
+ <spine toc="toc">
+ <itemref idref="html-toc" />
+ <-html-spine->
+ </spine>
+ <guide>
+ <reference type="toc" title="Table of Contents" href="_toc.html" />
+ </guide>
+ </package> XML> ;
+
+: write-dest-file ( xml dest-dir name ext -- )
+ append append-path utf8 [ write-xml ] with-file-writer ;
+
+SYMBOL: kindlegen-path
+kindlegen-path [ "kindlegen" ] initialize
+
+SYMBOL: codebook-output-path
+codebook-output-path [ "resource:codebooks" ] initialize
+
+: kindlegen ( path -- )
+ [ kindlegen-path get "-unicode" ] dip 3array try-process ;
+
+: kindle-path ( directory name extension -- path )
+ [ append-path ] dip append ;
+
+:: codebook ( src-dir -- )
+ codebook-output-path get normalize-path :> dest-dir
+
+ "Generating ebook for " write src-dir write " in " write dest-dir print flush
+
+ dest-dir make-directories
+ [
+ current-temporary-directory get :> temp-dir
+ src-dir file-name :> name
+ src-dir code-files :> files
+
+ src-dir name files code>opf
+ temp-dir name ".opf" write-dest-file
+
+ "vocab:codebook/cover.jpg" temp-dir copy-file-into
+
+ src-dir name files code>ncx
+ temp-dir name ".ncx" write-dest-file
+
+ src-dir name files code>toc-html
+ temp-dir "_toc.html" "" write-dest-file
+
+ files [| file |
+ src-dir file code>html
+ temp-dir file name>> file-html-name "" write-dest-file
+ ] each
+
+ temp-dir name ".opf" kindle-path kindlegen
+ temp-dir name ".mobi" kindle-path dest-dir copy-file-into
+
+ dest-dir name ".mobi" kindle-path :> mobi-path
+
+ "Job's finished: " write mobi-path print flush
+ ] cleanup-unique-working-directory ;
] float-array{ } make
mvp-matrix draw-debug-points
- "Frame: " world frame-number>> number>string append
+ "Frame: " world frame#>> number>string append
COLOR: purple { 5 5 } world dim>> draw-text
- world [ 1 + ] change-frame-number drop ;
+ world [ 1 + ] change-frame# drop ;
TUPLE: tests-world < wasd-world frame-number ;
M: tests-world draw-world* draw-debug-tests ;
USING: ui ui.gadgets sequences kernel arrays math colors
colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors
accessors fry ui.gadgets.packs game.input ui.gadgets.labels
-ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons
+ui.gadgets.borders timers calendar locals strings ui.gadgets.buttons
combinators math.parser assocs threads ;
IN: game.input.demos.joysticks
COLOR: red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ;
-TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
+TUPLE: joystick-demo-gadget < pack axis raxis controller buttons timer ;
: add-gadget-with-border ( parent child -- parent )
{ 2 2 } <border> COLOR: gray <solid> >>boundary add-gadget ;
: kill-update-axes ( gadget -- )
COLOR: gray <solid> >>interior
- [ [ stop-alarm ] when* f ] change-alarm
+ [ [ stop-timer ] when* f ] change-timer
relayout-1 ;
: (update-axes) ( gadget controller-state -- )
[ (update-axes) ] [ kill-update-axes ] if* ;
M: joystick-demo-gadget graft*
- dup '[ _ update-axes ] FREQUENCY every >>alarm
+ dup '[ _ update-axes ] FREQUENCY every >>timer
drop ;
M: joystick-demo-gadget ungraft*
- alarm>> [ stop-alarm ] when* ;
+ timer>> [ stop-timer ] when* ;
: joystick-window ( controller -- )
[ <joystick-demo-gadget> ] [ product-string ] bi
USING: game.input game.input.scancodes
kernel ui.gadgets ui.gadgets.buttons sequences accessors
-words arrays assocs math calendar fry alarms ui
+words arrays assocs math calendar fry timers ui
ui.gadgets.borders ui.gestures literals ;
IN: game.input.demos.key-caps
CONSTANT: KEYBOARD-SIZE { 230 65 }
CONSTANT: FREQUENCY $[ 1/30 seconds ]
-TUPLE: key-caps-gadget < gadget keys alarm ;
+TUPLE: key-caps-gadget < gadget keys timer ;
: make-key-gadget ( scancode dim array -- )
[
M: key-caps-gadget graft*
open-game-input
- dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm
+ dup '[ _ update-key-caps-state ] FREQUENCY every >>timer
drop ;
M: key-caps-gadget ungraft*
- alarm>> [ stop-alarm ] when*
+ timer>> [ stop-timer ] when*
close-game-input ;
M: key-caps-gadget handle-gesture
{ <game-loop> <game-loop*> } related-words
-HELP: benchmark-frames-per-second
-{ $values
- { "loop" game-loop }
- { "n" float }
-}
-{ $description "Returns the average number of times per second the game loop has called " { $link draw* } " on its delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ;
-
-HELP: benchmark-ticks-per-second
-{ $values
- { "loop" game-loop }
- { "n" float }
-}
-{ $description "Returns the average number of times per second the game loop has called " { $link tick* } " on its tick delegate since the game loop was started with " { $link start-loop } " or since the benchmark counters have been reset with " { $link reset-loop-benchmark } "." } ;
-
-{ reset-loop-benchmark benchmark-frames-per-second benchmark-ticks-per-second } related-words
-
HELP: draw*
{ $values
{ "tick-slice" float } { "delegate" "a " { $link "game.loop-delegates" } }
}
{ $description "If an uncaught error is thrown from inside a game loop delegate's " { $link tick* } " or " { $link draw* } ", the game loop will catch the error, stop the game loop, and rethrow an error of this class." } ;
-HELP: reset-loop-benchmark
-{ $values
- { "loop" game-loop }
-}
-{ $description "Resets the benchmark counters on a " { $link game-loop } ". Subsequent calls to " { $link benchmark-frames-per-second } " and " { $link benchmark-ticks-per-second } " will measure their values from the point " { $snippet "reset-loop-benchmark" } " was called." } ;
-
HELP: start-loop
{ $values
{ "loop" game-loop }
start-loop
stop-loop
}
-"The game loop maintains performance counters:"
-{ $subsections
- reset-loop-benchmark
- benchmark-frames-per-second
- benchmark-ticks-per-second
-}
"The game loop catches errors that occur in the delegate's methods during the course of the game loop:"
{ $subsections
game-loop-error
! (c)2009 Joe Groff bsd license
-USING: accessors alarms calendar continuations destructors fry
-kernel math math.order namespaces system ui ui.gadgets.worlds ;
+USING: accessors timers alien.c-types calendar classes.struct
+continuations destructors fry kernel math math.order memory
+namespaces sequences specialized-vectors system
+tools.memory ui ui.gadgets.worlds vm vocabs.loader arrays
+benchmark.struct locals ;
IN: game.loop
TUPLE: game-loop
{ tick-interval-nanos integer read-only }
tick-delegate
draw-delegate
- { last-tick integer }
{ running? boolean }
- { tick-number integer }
- { frame-number integer }
- { benchmark-time integer }
- { benchmark-tick-number integer }
- { benchmark-frame-number integer }
- alarm ;
+ { tick# integer }
+ { frame# integer }
+ tick-timer
+ draw-timer
+ benchmark-data ;
-GENERIC: tick* ( delegate -- )
-GENERIC: draw* ( tick-slice delegate -- )
-
-SYMBOL: game-loop
+STRUCT: game-loop-benchmark
+ { benchmark-data-pair benchmark-data-pair }
+ { tick# ulonglong }
+ { frame# ulonglong } ;
-: since-last-tick ( loop -- nanos )
- last-tick>> nano-count swap - ;
+SPECIALIZED-VECTOR: game-loop-benchmark
-: tick-slice ( loop -- slice )
- [ since-last-tick ] [ tick-interval-nanos>> ] bi /f 1.0 min ;
+: <game-loop-benchmark> ( benchmark-data-pair tick frame -- obj )
+ \ game-loop-benchmark <struct>
+ swap >>frame#
+ swap >>tick#
+ swap >>benchmark-data-pair ; inline
-CONSTANT: MAX-FRAMES-TO-SKIP 5
+GENERIC: tick* ( delegate -- )
+GENERIC: draw* ( tick-slice delegate -- )
DEFER: stop-loop
[ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
: fps ( fps -- nanos )
- 1,000,000,000 swap /i ; inline
+ [ 1,000,000,000 ] dip /i ; inline
<PRIVATE
+: record-benchmarking ( benchark-data-pair loop -- )
+ [ tick#>> ]
+ [ frame#>> <game-loop-benchmark> ]
+ [ benchmark-data>> ] tri push ;
+
+: last-tick-percent-offset ( loop -- float )
+ [ draw-timer>> iteration-start-nanos>> nano-count swap - ]
+ [ tick-interval-nanos>> ] bi /f 1.0 min ;
+
: redraw ( loop -- )
- [ 1 + ] change-frame-number
- [ tick-slice ] [ draw-delegate>> ] bi draw* ;
+ [ 1 + ] change-frame#
+ [
+ [ last-tick-percent-offset ] [ draw-delegate>> ] bi
+ [ draw* ] with-benchmarking
+ ] keep record-benchmarking ;
: tick ( loop -- )
- tick-delegate>> tick* ;
+ [
+ [ tick-delegate>> tick* ] with-benchmarking
+ ] keep record-benchmarking ;
: increment-tick ( loop -- )
- [ 1 + ] change-tick-number
- dup tick-interval-nanos>> [ + ] curry change-last-tick
+ [ 1 + ] change-tick#
drop ;
-: ?tick ( loop count -- )
- [ nano-count >>last-tick drop ] [
- over [ since-last-tick ] [ tick-interval-nanos>> ] bi >=
- [ [ drop increment-tick ] [ drop tick ] [ 1 - ?tick ] 2tri ]
- [ 2drop ] if
- ] if-zero ;
+PRIVATE>
-: benchmark-nanos ( loop -- nanos )
- nano-count swap benchmark-time>> - ;
+:: when-running ( loop quot -- )
+ [
+ loop
+ dup running?>> quot [ drop ] if
+ ] [
+ loop game-loop-error
+ ] recover ; inline
-PRIVATE>
+: tick-iteration ( loop -- )
+ [ [ tick ] [ increment-tick ] bi ] when-running ;
-: reset-loop-benchmark ( loop -- loop )
- nano-count >>benchmark-time
- dup tick-number>> >>benchmark-tick-number
- dup frame-number>> >>benchmark-frame-number ;
-
-: benchmark-ticks-per-second ( loop -- n )
- [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-nanos ] tri /f ;
-: benchmark-frames-per-second ( loop -- n )
- [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-nanos ] tri /f ;
-
-: (game-tick) ( loop -- )
- dup running?>>
- [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] bi ]
- [ drop ] if ;
-
-: game-tick ( loop -- )
- dup game-loop [
- [ (game-tick) ] [ game-loop-error ] recover
- ] with-variable ;
+: frame-iteration ( loop -- )
+ [ redraw ] when-running ;
: start-loop ( loop -- )
- nano-count >>last-tick
t >>running?
- reset-loop-benchmark
- [
- [ '[ _ game-tick ] f ]
- [ tick-interval-nanos>> nanoseconds ] bi
- <alarm>
- ] keep [ alarm<< ] [ drop start-alarm ] 2bi ;
+
+ dup
+ [ '[ _ tick-iteration ] f ]
+ [ tick-interval-nanos>> nanoseconds ] bi <timer> >>tick-timer
+
+ dup '[ _ frame-iteration ] f 1 milliseconds <timer> >>draw-timer
+
+ [ tick-timer>> ] [ draw-timer>> ] bi [ start-timer ] bi@ ;
: stop-loop ( loop -- )
f >>running?
- alarm>> stop-alarm ;
+ [ tick-timer>> ] [ draw-timer>> ] bi [ stop-timer ] bi@ ;
: <game-loop*> ( tick-interval-nanos tick-delegate draw-delegate -- loop )
- nano-count f 0 0 nano-count 0 0 f
+ f 0 0 f f
+ game-loop-benchmark-vector{ } clone
game-loop boa ;
: <game-loop> ( tick-interval-nanos delegate -- loop )
M: game-loop dispose
stop-loop ;
-USE: vocabs.loader
-
{ "game.loop" "prettyprint" } "game.loop.prettyprint" require-when
! (c)2009 Joe Groff bsd license
-USING: accessors combinators fry game.input game.loop generic kernel math
-parser sequences ui ui.gadgets ui.gadgets.worlds ui.gestures threads
-words audio.engine destructors ;
+USING: accessors audio.engine combinators concurrency.promises
+destructors fry game.input game.loop generic kernel math parser
+sequences threads ui ui.gadgets ui.gadgets.worlds ui.gestures
+words words.constant ;
IN: game.worlds
TUPLE: game-world < world
[ >>game-loop begin-game-world ] keep start-loop ;
M: game-world end-world
- [ [ stop-loop ] when* f ] change-game-loop
+ dup game-loop>> [ stop-loop ] when*
[ end-game-world ]
[ audio-engine>> [ dispose ] when* ]
[ use-game-input?>> [ close-game-input ] when ] tri ;
[ call-next-method ]
} cleave ;
+: start-game ( attributes -- game-world )
+ f swap open-window* ;
+
+: wait-game ( attributes -- game-world )
+ f swap open-window* dup promise>> ?promise drop ;
+
+: define-attributes-word ( word tuple -- )
+ [ name>> "-attributes" append create-in ] dip define-constant ;
+
SYNTAX: GAME:
CREATE
game-attributes parse-main-window-attributes
+ 2dup define-attributes-word
parse-definition
define-main-window ;
--- /dev/null
+Dmitry Shubin
--- /dev/null
+Dmitry Shubin
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax classes.struct
+combinators system ;
+IN: gdbm.ffi
+
+<< "libgdbm" {
+ { [ os macosx? ] [ "libgdbm.dylib" ] }
+ { [ os unix? ] [ "libgdbm.so" ] }
+ { [ os winnt? ] [ "gdbm.dll" ] }
+} cond cdecl add-library >>
+
+LIBRARY: libgdbm
+
+C-GLOBAL: c-string gdbm_version
+
+CONSTANT: GDBM_SYNC HEX: 20
+CONSTANT: GDBM_NOLOCK HEX: 40
+
+CONSTANT: GDBM_INSERT 0
+CONSTANT: GDBM_REPLACE 1
+
+CONSTANT: GDBM_CACHESIZE 1
+CONSTANT: GDBM_SYNCMODE 3
+CONSTANT: GDBM_CENTFREE 4
+CONSTANT: GDBM_COALESCEBLKS 5
+
+STRUCT: datum { dptr char* } { dsize int } ;
+
+C-TYPE: _GDBM_FILE
+TYPEDEF: _GDBM_FILE* GDBM_FILE
+
+CALLBACK: void fatal_func_cb ;
+FUNCTION: GDBM_FILE gdbm_open ( c-string name, int block_size, int read_write, int mode, fatal_func_cb fatal_func ) ;
+FUNCTION-ALIAS: gdbm-close void gdbm_close ( GDBM_FILE dbf ) ;
+FUNCTION: int gdbm_store ( GDBM_FILE dbf, datum key, datum content, int flag ) ;
+FUNCTION: datum gdbm_fetch ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: int gdbm_delete ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: datum gdbm_firstkey ( GDBM_FILE dbf ) ;
+FUNCTION: datum gdbm_nextkey ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: int gdbm_reorganize ( GDBM_FILE dbf ) ;
+FUNCTION: void gdbm_sync ( GDBM_FILE dbf ) ;
+FUNCTION: int gdbm_exists ( GDBM_FILE dbf, datum key ) ;
+FUNCTION: int gdbm_setopt ( GDBM_FILE dbf, int option, int* value, int size ) ;
+FUNCTION: int gdbm_fdesc ( GDBM_FILE dbf ) ;
+
+C-GLOBAL: int gdbm_errno
+
+FUNCTION: c-string gdbm_strerror ( int errno ) ;
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: gdbm.ffi gdbm.private help.markup help.syntax kernel math
+quotations strings ;
+IN: gdbm
+
+HELP: gdbm
+{ $class-description "Instance of this class is used as database configuration object. It has following slots:"
+
+ { $table
+ { { $slot "name" } "The file name of the database." }
+ { { $slot "block-size" } "The size of a single transfer from disk to memory. If the value is less than 512, the file system blocksize is used (this is default)." }
+ { { $slot "role" } "Determines what kind of access the user wants to obtain (see below)." }
+ { { $slot "sync" } { "Being set to " { $link t } " causes all database operations to be synchronized to the disk." } }
+ { { $slot "nolock" } { "Being set to " { $link t } " prevents gdbm from performing any locking on the database file." } }
+ { { $slot "mode" } "An integer representing standard UNIX access permissions." }
+ }
+ "The " { $slot "role" } " can be set to one of the folowing values:"
+ { $table
+ { { $snippet "reader" } "The user can only read from existing database." }
+ { { $snippet "writer" } "The user can access existing database as reader and writer." }
+ { { $snippet "wrcreat" } "Open the database for reading and writing if it exists and create new one otherwise." }
+ { { $snippet "newdb" } "Create empty database even if there is already one with the same name." }
+ }
+} ;
+
+HELP: <gdbm>
+{ $values { "gdbm" gdbm } }
+{ $description "Creates database configuration object with all slots set to their default values. See " { $link gdbm } " for complete slots description." } ;
+
+HELP: gdbm-info
+{ $values { "str" string } }
+{ $description "Returns version number and build date." } ;
+
+HELP: delete
+{ $values { "key" object } }
+{ $description "Removes the keyed item from the database." } ;
+
+HELP: gdbm-error-message
+{ $values { "error" gdbm-error } { "msg" string } }
+{ $description "Returns error message in human readable format." } ;
+
+HELP: exists?
+{ $values { "key" object } { "?" boolean } }
+{ $description "Searches for a particular key without retreiving it." } ;
+
+HELP: each-key
+{ $values { "quot" quotation } }
+{ $description "Applies the quotation to the each key in the database." } ;
+
+HELP: each-value
+{ $values { "quot" quotation } }
+{ $description "Applies the quotation to the each value in the database." } ;
+
+HELP: each-record
+{ $values { "quot" quotation } }
+{ $description "Applies the quotation to the each key-value pair in the database." } ;
+
+HELP: gdbm-file-descriptor
+{ $values { "desc" integer } }
+{ $description "Returns the file descriptor of the database. This is used for manual database locking if it was opened with " { $snippet "nolock" } " flag set to " { $link t } "." } ;
+
+HELP: fetch
+{ $values
+ { "key" object }
+ { "content/f" { "the value associated with " { $snippet "key" } " or " { $link f } " if there is no such key" } }
+}
+{ $description "Looks up a given key and returns value associated with it. This word makes no distinction between a missing value and a value set to " { $link f } "." } ;
+
+HELP: fetch*
+{ $values { "key" object } { "content" object } { "?" boolean } }
+{ $description "Looks up a given key and returns value associated with it. The boolean flag can decide between the case of a missing value, and a value of " { $link f } "." } ;
+
+HELP: first-key
+{ $values { "key/f" object } }
+{ $description "Returns first key in the database. This word makes no distinction between an empty database case and a case of a first value set to " { $link f } "." } ;
+
+HELP: first-key*
+{ $values { "key" object } { "?" boolean } }
+{ $description "Returns first key in the database. The boolean flag can decide between the case of an empty database and a case of a first value set to " { $link f } "." } ;
+
+HELP: insert
+{ $values { "key" object } { "content" object } }
+{ $description "Inserts record into the database. Throws an error if the key already exists." } ;
+
+HELP: next-key
+{ $values { "key" object } { "key/f" object } }
+{ $description "Given a key returns next key in the database. This word makes no distinction between reaching the end of the database case and a case of a next value set to " { $link f } "." } ;
+
+HELP: next-key*
+{ $values { "key" object } { "next-key" object } { "?" boolean } }
+{ $description "Given a key returns next key in the database. The boolean flag can decide between the case of reaching the end of the database and a case of a next value set to " { $link f } "." } ;
+
+HELP: reorganize
+{ $description "Reorganisation is a process of shinking the space used by gdbm. This requires creating a new file and moving all elements from old gdbm file to new one." } ;
+
+HELP: replace
+{ $values { "key" object } { "content" object } }
+{ $description "Inserts record into the database replacing old value with the new one if the key already exists." } ;
+
+HELP: set-block-merging
+{ $values { "?" boolean } }
+{ $description "If set, this option causes adjacent free blocks to be merged. The default is " { $link f } "." } ;
+
+HELP: set-block-pool
+{ $values { "?" boolean } }
+{ $description "If set, this option causes all subsequent free blocks to be placed in the global pool. The default is " { $link f } "." } ;
+
+HELP: set-cache-size
+{ $values { "size" integer } }
+{ $description "Sets the size of the internal bucket cache. The default value is 100. This option may only be set once." } ;
+
+HELP: set-sync-mode
+{ $values { "?" boolean } }
+{ $description "Turns on or off file system synchronization. The default is " { $link f } "." } ;
+
+HELP: synchronize
+{ $description "Performs database synchronization: make sure the disk version of the database has been completely updated." } ;
+
+HELP: with-gdbm
+{ $values
+ { "gdbm" "a database configuration object" } { "quot" quotation }
+}
+{ $description "Calls the quotation with a database bound to " { $link current-dbf } " symbol." } ;
+
+
+ARTICLE: "gdbm" "GNU Database Manager"
+"The " { $vocab-link "gdbm" } " vocabulary provides an interface to GNU DataBase Manager. This is a GNU implementation of the standard Unix dbm library, originally developed at Berkeley."
+
+$nl
+"This is a very brief manual. For a more detailed description consult the official gdbm documentation."
+
+{ $heading "Basics" }
+"All interaction with gdbm database should be realized using special combinator which automates all work for database initialisation and cleanup. All initialisation options are passed to combinator with a database configuration object."
+{ $subsections gdbm <gdbm> with-gdbm }
+"For actual record manipulation the following words are used:"
+{ $subsections insert exists? fetch delete }
+
+{ $heading "Sequential access" }
+"It is possible to iterate through all records in the database with"
+{ $subsections first-key next-key }
+"The following combinators, however, provide more convenient way to do that:"
+{ $subsections each-key each-value each-record }
+"The order in which records are accessed has nothing to do with the order in which records have been stored. Note that these words can only be used in read-only algorithms since delete operation re-arranges the hash table."
+;
+
+ABOUT: "gdbm"
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays continuations gdbm io.directories
+io.files.temp kernel sequences sets tools.test ;
+IN: gdbm.tests
+
+: db-path ( -- filename ) "test.db" temp-file ;
+
+: CLEANUP ( -- ) [ db-path delete-file ] ignore-errors ;
+
+: test.db ( -- gdbm ) <gdbm> db-path >>name ;
+
+: with-test.db ( quot -- ) test.db swap with-gdbm ; inline
+
+
+CLEANUP
+
+
+[
+ test.db reader >>role [ ] with-gdbm
+] [ gdbm-file-open-error = ] must-fail-with
+
+[ f ] [ [ "foo" exists? ] with-test.db ] unit-test
+
+[ ] [ [ "foo" 41 insert ] with-test.db ] unit-test
+
+[
+ db-path [ "foo" 42 insert ] with-gdbm-writer
+] [ gdbm-cannot-replace = ] must-fail-with
+
+[ ]
+[
+ [
+ "foo" 42 replace
+ "bar" 43 replace
+ "baz" 44 replace
+ ] with-test.db
+] unit-test
+
+[ 42 t ] [ db-path [ "foo" fetch* ] with-gdbm-reader ] unit-test
+
+[ f f ] [ [ "unknown" fetch* ] with-test.db ] unit-test
+
+[
+ [
+ 300 set-cache-size 300 set-cache-size
+ ] with-test.db
+] [ gdbm-option-already-set = ] must-fail-with
+
+[ t ]
+[
+ V{ } [ [ 2array append ] each-record ] with-test.db
+ V{ "foo" "bar" "baz" 42 43 44 } set=
+
+] unit-test
+
+[ f ]
+[
+ test.db newdb >>role [ "foo" exists? ] with-gdbm
+] unit-test
+
+
+CLEANUP
--- /dev/null
+! Copyright (C) 2010 Dmitry Shubin.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data alien.destructors
+alien.enums alien.syntax classes.struct combinators destructors
+gdbm.ffi io.backend kernel libc locals math namespaces sequences
+serialize strings ;
+IN: gdbm
+
+ENUM: gdbm-role reader writer wrcreat newdb ;
+
+TUPLE: gdbm
+ { name string }
+ { block-size integer }
+ { role initial: wrcreat }
+ { sync boolean }
+ { nolock boolean }
+ { mode integer initial: OCT: 644 } ;
+
+: <gdbm> ( -- gdbm ) gdbm new ;
+
+ENUM: gdbm-error
+ gdbm-no-error
+ gdbm-malloc-error
+ gdbm-block-size-error
+ gdbm-file-open-error
+ gdbm-file-write-error
+ gdbm-file-seek-error
+ gdbm-file-read-error
+ gdbm-bad-magic-number
+ gdbm-empty-database
+ gdbm-cant-be-reader
+ gdbm-cant-be-writer
+ gdbm-reader-cant-delete
+ gdbm-reader-cant-store
+ gdbm-reader-cant-reorganize
+ gdbm-unknown-update
+ gdbm-item-not-found
+ gdbm-reorganize-failed
+ gdbm-cannot-replace
+ gdbm-illegal-data
+ gdbm-option-already-set
+ gdbm-illegal-option ;
+
+
+<PRIVATE
+
+: gdbm-throw ( -- * ) gdbm_errno gdbm-error number>enum throw ;
+
+: check-error ( ret -- ) 0 = [ gdbm-throw ] unless ;
+
+SYMBOL: current-dbf
+
+: dbf ( -- dbf ) current-dbf get ;
+
+: get-flag ( gdbm -- n )
+ [ role>> enum>number ]
+ [ sync>> GDBM_SYNC 0 ? ]
+ [ nolock>> GDBM_NOLOCK 0 ? ]
+ tri bitor bitor ;
+
+: gdbm-open ( gdbm -- dbf )
+ {
+ [ name>> normalize-path ]
+ [ block-size>> ] [ get-flag ] [ mode>> ]
+ } cleave f gdbm_open [ gdbm-throw ] unless* ;
+
+DESTRUCTOR: gdbm-close
+
+: object>datum ( obj -- datum )
+ object>bytes [ malloc-byte-array &free ] [ length ] bi
+ datum <struct-boa> ;
+
+: datum>object* ( datum -- obj ? )
+ [ dptr>> ] [ dsize>> ] bi over
+ [ memory>byte-array bytes>object t ] [ drop f ] if ;
+
+: gdbm-store ( key content flag -- )
+ [
+ { [ dbf ] [ object>datum ] [ object>datum ] [ ] } spread
+ gdbm_store check-error
+ ] with-destructors ;
+
+:: (setopt) ( value option -- )
+ [
+ int heap-size dup malloc &free :> ( size ptr )
+ value ptr 0 int set-alien-value
+ dbf option ptr size gdbm_setopt check-error
+ ] with-destructors ;
+
+: setopt ( value option -- )
+ [ GDBM_CACHESIZE = [ >c-bool ] unless ] keep (setopt) ;
+
+PRIVATE>
+
+
+: gdbm-info ( -- str ) gdbm_version ;
+
+: gdbm-error-message ( error -- msg )
+ enum>number gdbm_strerror ;
+
+: replace ( key content -- ) GDBM_REPLACE gdbm-store ;
+: insert ( key content -- ) GDBM_INSERT gdbm-store ;
+
+: delete ( key -- )
+ [ dbf swap object>datum gdbm_delete check-error ]
+ with-destructors ;
+
+: fetch* ( key -- content ? )
+ [ dbf swap object>datum gdbm_fetch datum>object* ]
+ with-destructors ;
+
+: first-key* ( -- key ? )
+ [ dbf gdbm_firstkey datum>object* ] with-destructors ;
+
+: next-key* ( key -- next-key ? )
+ [ dbf swap object>datum gdbm_nextkey datum>object* ]
+ with-destructors ;
+
+: fetch ( key -- content/f ) fetch* drop ;
+: first-key ( -- key/f ) first-key* drop ;
+: next-key ( key -- key/f ) next-key* drop ;
+
+:: each-key ( ... quot: ( ... key -- ... ) -- ... )
+ first-key*
+ [ [ next-key* ] [ quot keep ] do while ] when drop ; inline
+
+: each-value ( ... quot: ( ... value -- ... ) -- ... )
+ [ fetch ] prepose each-key ; inline
+
+: each-record ( ... quot: ( ... key value -- ... ) -- ... )
+ [ dup fetch ] prepose each-key ; inline
+
+: reorganize ( -- ) dbf gdbm_reorganize check-error ;
+
+: synchronize ( -- ) dbf gdbm_sync ;
+
+: exists? ( key -- ? )
+ [ dbf swap object>datum gdbm_exists c-bool> ]
+ with-destructors ;
+
+: set-cache-size ( size -- ) GDBM_CACHESIZE setopt ;
+: set-sync-mode ( ? -- ) GDBM_SYNCMODE setopt ;
+: set-block-pool ( ? -- ) GDBM_CENTFREE setopt ;
+: set-block-merging ( ? -- ) GDBM_COALESCEBLKS setopt ;
+
+: gdbm-file-descriptor ( -- desc ) dbf gdbm_fdesc ;
+
+: with-gdbm ( gdbm quot -- )
+ [ gdbm-open &gdbm-close current-dbf set ] prepose curry
+ [ with-scope ] curry with-destructors ; inline
+
+:: with-gdbm-role ( name role quot -- )
+ <gdbm> name >>name role >>role quot with-gdbm ; inline
+
+: with-gdbm-reader ( name quot -- )
+ reader swap with-gdbm-role ; inline
+
+: with-gdbm-writer ( name quot -- )
+ writer swap with-gdbm-role ; inline
+
--- /dev/null
+GNU DataBase Manager
--- /dev/null
+bindings
+database
! Copyright (C) 2010 Anton Gorenko.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.enums alien.strings gobject.ffi gtk.ffi gdk.gl.ffi
-gtk.gl.ffi io.encodings.utf8 kernel locals math opengl.gl prettyprint ;
+USING: alien.strings gdk.gl.ffi gobject.ffi gtk.ffi gtk.gl.ffi
+io.encodings.utf8 kernel locals opengl.gl ;
IN: gir.samples.lowlevel.opengl
-! This sample based on
+! This sample is based on
! http://code.valaide.org/content/simple-opengl-sample-using-gtkglext
:: on-configure ( sender event user-data -- result )
[ 200 200 gtk_window_set_default_size ]
[ GTK_WIN_POS_CENTER gtk_window_set_position ] tri
- GDK_GL_MODE_RGBA enum>number
- gdk_gl_config_new_by_mode :> gl-config
+ GDK_GL_MODE_RGBA gdk_gl_config_new_by_mode :> gl-config
- window gl-config f t GDK_GL_RGBA_TYPE enum>number
+ window gl-config f t GDK_GL_RGBA_TYPE
gtk_widget_set_gl_capability drop
window "configure-event" utf8 string>alien
CONSTANT: fov 0.7
+: wasd-fov-vector ( world -- fov )
+ dim>> dup first2 min >float v/n fov v*n ; inline
+
:: generate-p-matrix ( world -- matrix )
world wasd-near-plane :> near-plane
world wasd-far-plane :> far-plane
- world dim>> dup first2 min >float v/n fov v*n near-plane v*n
+ world wasd-fov-vector near-plane v*n
near-plane far-plane frustum-matrix4 ;
+:: wasd-pixel-ray ( world loc -- direction )
+ loc world dim>> [ /f 0.5 - 2.0 * ] 2map
+ world wasd-fov-vector v*
+ first2 neg -1.0 0.0 4array
+ world wasd-mv-inv-matrix swap m.v ;
+
: set-wasd-view ( world location yaw pitch -- world )
[ >>location ] [ >>yaw ] [ >>pitch ] tri* ;
! Copyrigt (C) 2009 Doug Coleman, Keith Lazuka
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators compression.lzw
+USING: accessors arrays combinators compression.lzw
constructors destructors grouping images images.loader io
-io.binary io.buffers io.encodings.binary io.encodings.string
-io.encodings.utf8 io.files io.files.info io.ports
-io.streams.limited kernel make math math.bitwise math.functions
-multiline namespaces prettyprint sequences ;
+io.binary io.buffers io.encodings.string io.encodings.utf8
+io.ports kernel make math math.bitwise namespaces sequences ;
IN: images.gif
SINGLETON: gif-image
! See http://factorcode.org/license.txt for BSD license.
USING: fry irc.client irc.client.chats kernel namespaces
sequences threads io.launcher io splitting
-make mason.common mason.updates calendar math alarms
+make mason.common mason.updates calendar math timers
io.encodings.8-bit.latin1 debugger ;
IN: irc.gitbot
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms bit-arrays calendar game.input io
+USING: accessors timers bit-arrays calendar game.input io
io.binary io.encodings.binary io.files kernel literals math
namespaces system threads ;
IN: key-logger
] unless ;
: stop-key-logger ( -- )
- key-logger get-global [ stop-alarm ] when*
+ key-logger get-global [ stop-timer ] when*
f key-logger set-global
close-game-input ;
--- /dev/null
+Niklas Waern
--- /dev/null
+! Copyright (C) 2010 Niklas Waern.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.libraries alien.syntax
+fry kernel sequences unix.types ;
+IN: libudev
+
+<< "libudev" "libudev.so" cdecl add-library >>
+
+LIBRARY: libudev
+
+C-TYPE: udev
+
+FUNCTION: udev* udev_ref (
+ udev* udev ) ;
+
+
+
+FUNCTION: void udev_unref (
+ udev* udev ) ;
+
+
+
+FUNCTION: udev* udev_new ( ) ;
+
+
+
+CALLBACK: void udev_set_log_fn_callback (
+ udev* udev
+ int priority,
+ c-string file,
+ int line,
+ c-string fn,
+ c-string format ) ;
+ ! va_list args ) ;
+FUNCTION: void udev_set_log_fn (
+ udev* udev,
+ udev_set_log_fn_callback log_fn ) ;
+
+
+
+FUNCTION: int udev_get_log_priority (
+ udev* udev ) ;
+
+
+
+FUNCTION: void udev_set_log_priority (
+ udev* udev,
+ int priority ) ;
+
+
+
+FUNCTION: c-string udev_get_sys_path (
+ udev* udev ) ;
+
+
+
+FUNCTION: c-string udev_get_dev_path (
+ udev* udev ) ;
+
+
+
+FUNCTION: void* udev_get_userdata (
+ udev* udev ) ;
+
+
+
+FUNCTION: void udev_set_userdata (
+ udev* udev,
+ void* userdata ) ;
+
+
+
+C-TYPE: udev_list_entry
+
+FUNCTION: udev_list_entry* udev_list_entry_get_next (
+ udev_list_entry* list_entry ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_list_entry_get_by_name (
+ udev_list_entry* list_entry,
+ c-string name ) ;
+
+
+
+FUNCTION: c-string udev_list_entry_get_name (
+ udev_list_entry* list_entry ) ;
+
+
+
+FUNCTION: c-string udev_list_entry_get_value (
+ udev_list_entry* list_entry ) ;
+
+
+
+! Helper to iterate over all entries of a list.
+: udev_list_entry_foreach ( ... first_entry quot: ( ... x -- ... ) -- ... )
+ [ [ dup ] ] dip '[ [ @ ] keep udev_list_entry_get_next ]
+ while drop ; inline
+
+! Get all list entries _as_ a list
+: udev-list-entries ( first_entry -- seq )
+ [ ] collector [ udev_list_entry_foreach ] dip ;
+
+
+
+C-TYPE: udev_device
+
+FUNCTION: udev_device* udev_device_ref (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: void udev_device_unref (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev* udev_device_get_udev (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_device* udev_device_new_from_syspath (
+ udev* udev,
+ c-string syspath ) ;
+
+
+
+FUNCTION: udev_device* udev_device_new_from_devnum (
+ udev* udev,
+ char type,
+ dev_t devnum ) ;
+
+
+
+FUNCTION: udev_device* udev_device_new_from_subsystem_sysname (
+ udev* udev,
+ c-string subsystem,
+ c-string sysname ) ;
+
+
+
+FUNCTION: udev_device* udev_device_get_parent (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_device* udev_device_get_parent_with_subsystem_devtype (
+ udev_device* udev_device,
+ c-string subsystem,
+ c-string devtype ) ;
+
+
+
+FUNCTION: c-string udev_device_get_devpath (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_subsystem (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_devtype (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_syspath (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_sysname (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_sysnum (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_devnode (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_device_get_devlinks_list_entry (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_device_get_properties_list_entry (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_property_value (
+ udev_device* udev_device,
+ c-string key ) ;
+
+
+
+FUNCTION: c-string udev_device_get_driver (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: dev_t udev_device_get_devnum (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_action (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: ulonglong udev_device_get_seqnum (
+ udev_device* udev_device ) ;
+
+
+
+FUNCTION: c-string udev_device_get_sysattr_value (
+ udev_device* udev_device,
+ c-string sysattr ) ;
+
+
+
+C-TYPE: udev_monitor
+
+FUNCTION: udev_monitor* udev_monitor_ref (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: void udev_monitor_unref (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: udev* udev_monitor_get_udev (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: udev_monitor* udev_monitor_new_from_netlink (
+ udev* udev,
+ c-string name ) ;
+
+
+
+FUNCTION: udev_monitor* udev_monitor_new_from_socket (
+ udev* udev,
+ c-string socket_path ) ;
+
+
+
+FUNCTION: int udev_monitor_enable_receiving (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: int udev_monitor_set_receive_buffer_size (
+ udev_monitor* udev_monitor,
+ int size ) ;
+
+
+
+FUNCTION: int udev_monitor_get_fd (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: udev_device* udev_monitor_receive_device (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: int udev_monitor_filter_add_match_subsystem_devtype (
+ udev_monitor* udev_monitor,
+ c-string subsystem,
+ c-string devtype ) ;
+
+
+
+FUNCTION: int udev_monitor_filter_update (
+ udev_monitor* udev_monitor ) ;
+
+
+
+FUNCTION: int udev_monitor_filter_remove (
+ udev_monitor* udev_monitor ) ;
+
+
+
+C-TYPE: udev_enumerate
+
+FUNCTION: udev_enumerate* udev_enumerate_ref (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: void udev_enumerate_unref (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: udev* udev_enumerate_get_udev (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: udev_enumerate* udev_enumerate_new (
+ udev* udev ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_subsystem (
+ udev_enumerate* udev_enumerate,
+ c-string subsystem ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_nomatch_subsystem (
+ udev_enumerate* udev_enumerate,
+ c-string subsystem ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_sysattr (
+ udev_enumerate* udev_enumerate,
+ c-string sysattr,
+ c-string value ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_nomatch_sysattr (
+ udev_enumerate* udev_enumerate,
+ c-string sysattr,
+ c-string value ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_property (
+ udev_enumerate* udev_enumerate,
+ c-string property,
+ c-string value ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_match_sysname (
+ udev_enumerate* udev_enumerate,
+ c-string sysname ) ;
+
+
+
+FUNCTION: int udev_enumerate_add_syspath (
+ udev_enumerate* udev_enumerate,
+ c-string syspath ) ;
+
+
+
+FUNCTION: int udev_enumerate_scan_devices (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: int udev_enumerate_scan_subsystems (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_enumerate_get_list_entry (
+ udev_enumerate* udev_enumerate ) ;
+
+
+
+C-TYPE: udev_queue
+
+FUNCTION: udev_queue* udev_queue_ref (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: void udev_queue_unref (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: udev* udev_queue_get_udev (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: udev_queue* udev_queue_new (
+ udev* udev ) ;
+
+
+
+FUNCTION: ulonglong udev_queue_get_kernel_seqnum (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: ulonglong udev_queue_get_udev_seqnum (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: int udev_queue_get_udev_is_active (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: int udev_queue_get_queue_is_empty (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: int udev_queue_get_seqnum_is_finished (
+ udev_queue* udev_queue,
+ ulonglong seqnum ) ;
+
+
+
+FUNCTION: int udev_queue_get_seqnum_sequence_is_finished (
+ udev_queue* udev_queue,
+ ulonglong start,
+ ulonglong end ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_queue_get_queued_list_entry (
+ udev_queue* udev_queue ) ;
+
+
+
+FUNCTION: udev_list_entry* udev_queue_get_failed_list_entry (
+ udev_queue* udev_queue ) ;
+
+
+
--- /dev/null
+Bindings to libudev
IN: mason.common.tests
USING: prettyprint mason.common mason.config
-namespaces calendar tools.test io.files io.files.temp io.encodings.utf8 ;
+namespaces calendar tools.test io.files
+io.files.temp io.encodings.utf8 sequences ;
[ "00:01:02" ] [ 62,000,000,000 nanos>time ] unit-test
] with-scope
] unit-test
-[ "/home/bobby/builds/2008-09-11-12-23" ] [
+[ t ] [
[
"/home/bobby/builds" builds-dir set
T{ timestamp
} datestamp stamp set
build-dir
] with-scope
+ "/home/bobby/builds/2008-09-11-12-23" head?
] unit-test
[ ] [ "empty-test" temp-file utf8 [ ] with-file-writer ] unit-test
! Who receives build report e-mails.
SYMBOL: builder-recipients
-! (Optional) twitter credentials for status updates.
-SYMBOL: builder-twitter-username
-
-SYMBOL: builder-twitter-password
-
! (Optional) CPU architecture to build for.
SYMBOL: target-cpu
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: debugger fry kernel mason.config namespaces twitter ;
IN: mason.twitter
: mason-tweet ( message -- )
- builder-twitter-username get builder-twitter-password get and
- [
- [
- builder-twitter-username get twitter-username set
- builder-twitter-password get twitter-password set
- '[ _ tweet ] try
- ] with-scope
- ] [ drop ] if ;
\ No newline at end of file
+ twitter-access-token get [ '[ _ tweet ] try ] [ drop ] if ;
\ No newline at end of file
! Copyright (C) 2008, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.launcher bootstrap.image.download
-mason.common mason.platform ;
+USING: bootstrap.image.download io.directories io.launcher
+kernel mason.common mason.platform ;
IN: mason.updates
: git-pull-cmd ( -- cmd )
boot-image-name maybe-download-image ;
: new-code-available? ( -- ? )
- updates-available?
- new-image-available?
- or ;
\ No newline at end of file
+ updates-available? new-image-available? or ;
: remote-directory ( string -- string' )
[ upload-directory get ] dip "/" glue ;
+SLOT: os
+SLOT: cpu
+
: platform ( builder -- string )
[ os>> ] [ cpu>> ] bi (platform) ;
: make-source-release ( version git-id -- path )
"Creating source release..." print flush
- unique-directory
[
clone-factor prepare-source (make-source-release)
"Package created: " write absolute-path dup print
- ] with-directory ;
+ ] with-unique-directory drop ;
: upload-source-release ( package version -- )
"Uploading source release..." print flush
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: oauth oauth.private tools.test accessors kernel assocs
+strings namespaces ;
+IN: oauth.tests
+
+[ "%26&b" ] [ "&" "b" hmac-key ] unit-test
+[ "%26&" ] [ "&" f hmac-key ] unit-test
+
+[ "B&http%3A%2F%2Ftwitter.com&a%3Db" ] [
+ "http://twitter.com"
+ "B"
+ { { "a" "b" } }
+ signature-base-string
+] unit-test
+
+[ "Z5tUa83q43qiy6dGGCb92bN/4ik=" ] [
+ "ABC" "DEF" <token> consumer-token set
+
+ "http://twitter.com"
+ <request-token-params>
+ 12345 >>timestamp
+ 54321 >>nonce
+ <request-token-request>
+ post-data>>
+ "oauth_signature" swap at
+ >string
+] unit-test
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs base64 calendar checksums.hmac
+checksums.sha combinators fry http http.client kernel locals
+make math namespaces present random sequences sorting strings
+urls urls.encoding ;
+IN: oauth
+
+SYMBOL: consumer-token
+
+TUPLE: token key secret user-data ;
+
+: <token> ( key secret -- token )
+ token new
+ swap >>secret
+ swap >>key ;
+
+<PRIVATE
+
+TUPLE: token-params
+consumer-token
+timestamp
+nonce ;
+
+: new-token-params ( class -- params )
+ new
+ consumer-token get >>consumer-token
+ now timestamp>unix-time >integer >>timestamp
+ random-32 >>nonce ; inline
+
+:: signature-base-string ( url request-method params -- string )
+ [
+ request-method % "&" %
+ url present url-encode-full % "&" %
+ params assoc>query url-encode-full %
+ ] "" make ;
+
+: hmac-key ( consumer-secret token-secret -- key )
+ [ url-encode-full ] [ "" or url-encode-full ] bi* "&" glue ;
+
+: make-token-params ( params quot -- assoc )
+ '[
+ "1.0" "oauth_version" set
+ "HMAC-SHA1" "oauth_signature_method" set
+
+ _
+ [
+ [ consumer-token>> key>> "oauth_consumer_key" set ]
+ [ timestamp>> "oauth_timestamp" set ]
+ [ nonce>> "oauth_nonce" set ]
+ tri
+ ] bi
+ ] H{ } make-assoc ; inline
+
+:: sign-params ( url request-method consumer-token request-token params -- signed-params )
+ params >alist sort-keys :> params
+ url request-method params signature-base-string :> sbs
+ consumer-token secret>> request-token dup [ secret>> ] when hmac-key :> key
+ sbs key sha1 hmac-bytes >base64 >string :> signature
+ params { "oauth_signature" signature } prefix ;
+
+: extract-user-data ( assoc -- assoc' )
+ [
+ drop
+ { "oauth_token" "oauth_token_secret" } member? not
+ ] assoc-filter ;
+
+: parse-token ( response data -- token )
+ nip
+ query>assoc
+ [ [ "oauth_token" ] dip at ]
+ [ [ "oauth_token_secret" ] dip at ]
+ [ extract-user-data ]
+ tri
+ [ <token> ] dip >>user-data ;
+
+PRIVATE>
+
+TUPLE: request-token-params < token-params
+{ callback-url initial: "oob" } ;
+
+: <request-token-params> ( -- params )
+ request-token-params new-token-params ;
+
+<PRIVATE
+
+:: <token-request> ( url consumer-token request-token params -- request )
+ url "POST" consumer-token request-token params sign-params
+ url
+ <post-request> ;
+
+: make-request-token-params ( params -- assoc )
+ [ callback-url>> "oauth_callback" set ] make-token-params ;
+
+: <request-token-request> ( url params -- request )
+ [ consumer-token>> f ] [ make-request-token-params ] bi
+ <token-request> ;
+
+PRIVATE>
+
+: obtain-request-token ( url params -- token )
+ <request-token-request> http-request parse-token ;
+
+TUPLE: access-token-params < token-params request-token verifier ;
+
+: <access-token-params> ( -- params )
+ access-token-params new-token-params ;
+
+<PRIVATE
+
+: make-access-token-params ( params -- assoc )
+ [
+ [ request-token>> key>> "oauth_token" set ]
+ [ verifier>> "oauth_verifier" set ]
+ bi
+ ] make-token-params ;
+
+: <access-token-request> ( url params -- request )
+ [ consumer-token>> ]
+ [ request-token>> ]
+ [ make-access-token-params ] tri
+ <token-request> ;
+
+PRIVATE>
+
+: obtain-access-token ( url params -- token )
+ <access-token-request> http-request parse-token ;
+
+SYMBOL: access-token
+
+TUPLE: oauth-request-params < token-params access-token ;
+
+: <oauth-request-params> ( -- params )
+ oauth-request-params new-token-params
+ access-token get >>access-token ;
+
+<PRIVATE
+
+:: signed-oauth-request-params ( request params -- params )
+ request url>>
+ request method>>
+ params consumer-token>>
+ params access-token>>
+ params
+ [
+ access-token>> key>> "oauth_token" set
+ namespace request post-data>> assoc-union! drop
+ ] make-token-params
+ sign-params ;
+
+: build-auth-string ( params -- string )
+ [ [ present url-encode-full ] bi@ "\"" "\"" surround "=" glue ] { } assoc>map
+ ", " join "OAuth realm=\"\", " prepend ;
+
+PRIVATE>
+
+: set-oauth ( request params -- request )
+ dupd signed-oauth-request-params build-auth-string
+ "Authorization" set-header ;
! Copyright (C) 2005 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.libraries alien.syntax kernel
-sequences words system combinators opengl.gl ;
+sequences words system combinators opengl.gl alien.destructors ;
IN: opengl.glu
<<
! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
+DESTRUCTOR: gluDeleteNurbsRenderer
+DESTRUCTOR: gluDeleteQuadric
+DESTRUCTOR: gluDeleteTess
+
+CALLBACK: void GLUtessBeginCallback ( GLenum type ) ;
+CALLBACK: void GLUtessBeginDataCallback ( GLenum type, void* data ) ;
+CALLBACK: void GLUtessEdgeFlagCallback ( GLboolean flag ) ;
+CALLBACK: void GLUtessEdgeFlagDataCallback ( GLboolean flag, void* data ) ;
+CALLBACK: void GLUtessVertexCallback ( void* vertex_data ) ;
+CALLBACK: void GLUtessVertexDataCallback ( void* vertex_data, void* data ) ;
+CALLBACK: void GLUtessEndCallback ( ) ;
+CALLBACK: void GLUtessEndDataCallback ( void* data ) ;
+CALLBACK: void GLUtessCombineDataCallback ( GLdouble* coords, void** vertex_data, GLfloat* weight, void** out_data, void* data ) ;
+CALLBACK: void GLUtessErrorCallback ( GLenum errno ) ;
+CALLBACK: void GLUtessErrorDataCallback ( GLenum errno, void* data ) ;
+
: gl-look-at ( eye focus up -- )
[ first3 ] tri@ gluLookAt ;
! Copyright (C) 2009 Elie Chaftari.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.promises namespaces kernel pop3 pop3.server
-sequences tools.test accessors ;
+sequences tools.test accessors calendar ;
IN: pop3.tests
FROM: pop3 => count delete ;
[ ] [
<pop3-account>
"127.0.0.1" >>host
- "p1" get ?promise >>port
+ "p1" get 5 seconds ?promise-timeout >>port
connect
] unit-test
[ ] [ "username@host.com" >user ] unit-test
[ ] [
<pop3-account>
"127.0.0.1" >>host
- "p2" get ?promise >>port
+ "p2" get 5 seconds ?promise-timeout >>port
"username@host.com" >>user
"password" >>pwd
connect
HELP: role-slot-overlap
{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " or " { $link POSTPONE: ROLE: } " definition attempts to inherit a set of " { $link role } "s in which more than one attempts to define the same slot." } ;
+ARTICLE: "roles" "Roles"
+"The " { $vocab-link "roles" } " vocabulary provides a form of tuple interface that can be implemented by concrete tuple classes. A " { $link role } " definition is a mixin class that also prescribes a set of tuple slots. Roles are not tuple classes by themselves and cannot be instantiated by " { $link new } ". The vocabulary extends " { $link POSTPONE: TUPLE: } " syntax to allow concrete tuple types to declare membership to one or more roles, automatically including their prescribed slots." $nl
+"The role superclass:"
+{ $subsections role }
+"Syntax for making a new role:"
+{ $subsection POSTPONE: ROLE: }
+"Syntax for making tuples that use roles:"
+{ $subsection POSTPONE: TUPLE: }
+"Errors with roles:"
+{ $subsections multiple-inheritance-attempted role-slot-overlap } ;
+
+ABOUT: "roles"
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar combinators
+USING: accessors timers arrays calendar combinators
combinators.smart continuations debugger http.client fry
init io.streams.string kernel locals math math.parser db
namespaces sequences site-watcher.db site-watcher.email ;
] unless ;
: stop-site-watcher ( -- )
- running-site-watcher get [ stop-alarm ] when* ;
+ running-site-watcher get [ stop-timer ] when* ;
: sync-frame ( micros -- micros )
#! Sleep until the time for the next frame arrives.
- 1000 60 / >fixnum + system:system-micros - dup 0 >
- [ milliseconds threads:sleep ] [ drop threads:yield ] if system:system-micros ;
+ 1000 60 / >fixnum + gmt timestamp>micros - dup 0 >
+ [ milliseconds threads:sleep ] [ drop threads:yield ] if gmt timestamp>micros ;
: invaders-process ( micros gadget -- )
#! Run a space invaders gadget inside a
M: invaders-gadget graft* ( gadget -- )
dup cpu>> init-sounds
f over quit?<<
- [ system:system-micros swap invaders-process ] curry
+ [ gmt timestamp>micros swap invaders-process ] curry
"Space invaders" threads:spawn drop ;
M: invaders-gadget ungraft* ( gadget -- )
--- /dev/null
+! Copyright (C) 2009, 2010 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel locals accessors compiler.tree.propagation.info
+sequences kernel.private assocs fry parser math quotations
+effects arrays definitions compiler.units namespaces
+compiler.tree.debugger generalizations stack-checker ;
+IN: specialized
+
+: in-compilation-unit? ( -- ? )
+ changed-definitions get >boolean ;
+
+: define-temp-in-unit ( quot effect -- word )
+ in-compilation-unit?
+ [ [ define-temp ] with-nested-compilation-unit ]
+ [ [ define-temp ] with-compilation-unit ]
+ if ;
+
+: final-info-quot ( word -- quot )
+ [ stack-effect in>> length '[ _ ndrop ] ]
+ [ def>> [ final-info ] with-scope >quotation ] bi
+ compose ;
+
+ERROR: bad-outputs word quot ;
+
+: define-outputs ( word quot -- )
+ 2dup [ stack-effect ] [ infer ] bi* effect<=
+ [ "outputs" set-word-prop ] [ bad-outputs ] if ;
+
+: record-final-info ( word -- )
+ dup final-info-quot define-outputs ;
+
+:: lookup-specialized ( #call word n -- special-word/f )
+ #call in-d>> n tail* >array [ value-info class>> ] map
+ dup [ object = ] all? [ drop f ] [
+ word "specialized-defs" word-prop [
+ [ declare ] curry word def>> compose
+ word stack-effect define-temp-in-unit
+ dup record-final-info
+ 1quotation
+ ] cache
+ ] if ;
+
+: specialized-quot ( word n -- quot )
+ '[ _ _ lookup-specialized ] ;
+
+: make-specialized ( word n -- )
+ [ drop H{ } clone "specialized-defs" set-word-prop ]
+ [ dupd specialized-quot "custom-inlining" set-word-prop ] 2bi ;
+
+SYNTAX: specialized
+ word dup stack-effect in>> length make-specialized ;
+
+PREDICATE: specialized-word < word
+ "specialized-defs" word-prop >boolean ;
+
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
: sky-gradient ( world -- t )
- game-loop>> tick-number>> SKY-PERIOD mod SKY-PERIOD /f ;
+ game-loop>> tick#>> SKY-PERIOD mod SKY-PERIOD /f ;
: sky-theta ( world -- theta )
- game-loop>> tick-number>> SKY-SPEED * ;
+ game-loop>> tick#>> SKY-SPEED * ;
M: terrain-world begin-game-world
"2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
rows>> 1 + 10 / ceiling ;
: update-interval ( tetris -- interval )
- level>> 1 - 60 * 1000000 swap - ;
+ level>> 1 - 60 * 1,000,000,000 swap - ;
: add-block ( tetris block -- )
over [ board>> ] 2dip current-piece tetromino>> colour>> set-block ;
dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
: update ( tetris -- )
- system-micros over last-update>> -
+ nano-count over last-update>> -
over update-interval > [
dup move-down
- system-micros >>last-update
+ nano-count >>last-update
] when drop ;
: ?update ( tetris -- )
! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar kernel make math math.rectangles math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ;
+USING: accessors timers arrays calendar kernel make math math.rectangles
+math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets
+ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures
+ui.render ui ;
FROM: tetris.game => level>> ;
IN: tetris
-TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ;
+TUPLE: tetris-gadget < gadget { tetris tetris } { timer } ;
: <tetris-gadget> ( tetris -- gadget )
tetris-gadget new swap >>tetris ;
[ tetris>> ?update ] [ relayout-1 ] bi ;
M: tetris-gadget graft* ( gadget -- )
- [ [ tick ] curry 100 milliseconds every ] keep alarm<< ;
+ [ [ tick ] curry 100 milliseconds every ] keep timer<< ;
M: tetris-gadget ungraft* ( gadget -- )
- [ stop-alarm f ] change-alarm drop ;
+ [ stop-timer f ] change-timer drop ;
: tetris-window ( -- )
[
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.data calendar calendar.unix classes.struct
+io.files.info.unix.private kernel system time unix unix.time ;
+IN: time.macosx
+
+M: macosx adjust-time-monotonic
+ timestamp>timeval
+ \ timeval <struct>
+ [ adjtime io-error ] keep dup binary-zero? [
+ drop instant
+ ] [
+ timeval>duration since-1970 now time-
+ ] if ;
+
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel system vocabs.loader ;
+IN: time
+
+HOOK: set-time os ( timestamp -- )
+HOOK: adjust-time-monotonic os ( timestamp -- seconds )
+
+os {
+ { [ dup macosx? ] [ drop "time.macosx" require ] }
+ { [ dup windows? ] [ drop "time.windows" require ] }
+ { [ dup unix? ] [ drop "time.unix" require ] }
+ [ drop ]
+} cond
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar classes.struct kernel math system time
+unix unix.time ;
+IN: time.unix
+
+: timestamp>timezone ( timestamp -- timezone )
+ gmt-offset>> duration>minutes 1 \ timezone <struct-boa> ; inline
+
+M: unix set-time
+ [ unix-1970 time- duration>microseconds >integer make-timeval ]
+ [ timestamp>timezone ] bi
+ settimeofday io-error ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar.windows system time windows.errors
+windows.kernel32 kernel classes.struct calendar ;
+IN: time.windows
+
+M: windows set-time
+ >gmt
+ timestamp>SYSTEMTIME SetSystemTime win32-error=0/f ;
--- /dev/null
+Joe Groff
+Slava Pestov
--- /dev/null
+USING: accessors continuations fry http.client images.loader
+images.loader.private images.viewer io io.styles kernel memoize
+prettyprint sequences twitter ;
+IN: twitter.prettyprint
+
+MEMO: load-http-image ( url -- image/f )
+ '[ _
+ [ http-get [ check-response drop ] dip ]
+ [ image-class ] bi load-image*
+ ] [ drop f ] recover ;
+
+: user-image ( user -- image/f )
+ profile-image-url>> load-http-image ;
+
+CONSTANT: tweet-table-style
+ H{ { table-gap { 5 5 } } }
+
+CONSTANT: tweet-username-style
+ H{
+ { font-style bold }
+ }
+
+CONSTANT: tweet-text-style
+ H{
+ { font-name "sans-serif" }
+ { font-size 16 }
+ { wrap-margin 500 }
+ }
+
+CONSTANT: tweet-metadata-style
+ H{
+ { font-size 10 }
+ }
+
+: tweet. ( status -- )
+ tweet-table-style [
+ [
+ [ dup user>> user-image [ image. ] when* ] with-cell
+ [
+ H{ { wrap-margin 600 } } [
+ tweet-text-style [
+ tweet-username-style [
+ dup user>> screen-name>> write
+ ] with-style
+ " " write dup text>> print
+
+ tweet-metadata-style [
+ dup created-at>> write
+ " via " write
+ dup source>> write
+ ] with-style
+ ] with-style
+ ] with-nesting
+ ] with-cell
+ ] with-row
+ ] tabular-output nl
+ drop ;
+
+: friends-timeline. ( -- ) friends-timeline [ tweet. ] each ;
+: public-timeline. ( -- ) public-timeline [ tweet. ] each ;
+: user-timeline. ( user -- ) user-timeline [ tweet. ] each ;
-! Copyright (C) 2009 Joe Groff.
+! Copyright (C) 2009, 2010 Joe Groff, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators hashtables http
http.client json.reader kernel macros namespaces sequences
-urls.secure fry ;
+urls.secure fry oauth urls ;
IN: twitter
! Configuration
-SYMBOLS: twitter-username twitter-password twitter-source ;
+SYMBOLS: twitter-source twitter-consumer-token twitter-access-token ;
twitter-source [ "factor" ] initialize
-: set-twitter-credentials ( username password -- )
- [ twitter-username set ] [ twitter-password set ] bi* ;
+<PRIVATE
+
+: with-twitter-oauth ( quot -- )
+ [
+ twitter-consumer-token get consumer-token set
+ twitter-access-token get access-token set
+ call
+ ] with-scope ; inline
+
+PRIVATE>
+
+! obtain-twitter-request-token and obtain-twitter-access-token
+! should use https: URLs but Twitter sends a 301 Redirect back
+! to the same URL. Twitter bug?
+
+: obtain-twitter-request-token ( -- request-token )
+ [
+ "https://twitter.com/oauth/request_token"
+ <request-token-params>
+ obtain-request-token
+ ] with-twitter-oauth ;
+
+: twitter-authorize-url ( token -- url )
+ "https://twitter.com/oauth/authorize" >url
+ swap key>> "oauth_token" set-query-param ;
+
+: obtain-twitter-access-token ( request-token verifier -- access-token )
+ [
+ [ "https://twitter.com/oauth/access_token" ] 2dip
+ <access-token-params>
+ swap >>verifier
+ swap >>request-token
+ obtain-access-token
+ ] with-twitter-oauth ;
<PRIVATE
[ [ '[ _ swap at ] ] map ] dip '[ _ cleave _ boa ] ;
! Twitter requests
-
: twitter-url ( string -- url )
"https://twitter.com/statuses/" ".json" surround ;
: set-request-twitter-auth ( request -- request )
- twitter-username get twitter-password get set-basic-auth ;
+ [ <oauth-request-params> set-oauth ] with-twitter-oauth ;
: twitter-request ( request -- data )
set-request-twitter-auth
in-reply-to-user-id
favorited?
user ;
+
TUPLE: twitter-user
id
name
.
.
; """ }
-{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
+{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined as a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
{ $examples { $code """
USING: kernel variants ;
IN: scratchpad
;
""" } } ;
+HELP: VARIANT-MEMBER:
+{ $description "Defines a new member of a variant class without restricting such definitions to a single statement or source file. The variant class should be listed first, and the class member should follow." }
+{ $examples { $code """
+USING: kernel variants ;
+IN: scratchpad
+
+VARIANT: list ;
+
+VARIANT-MEMBER: list nil
+VARIANT-MEMBER: list cons: { { first object } { rest list } }
+""" } } ;
+
HELP: match
{ $values { "branches" array } }
{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
"The " { $vocab-link "variants" } " vocabulary provides syntax and combinators for defining and manipulating algebraic data types."
{ $subsections
POSTPONE: VARIANT:
+ POSTPONE: VARIANT-MEMBER:
variant-class
match
} ;
[ 4 ]
[ 5 6 7 8 nil <cons> <cons> <cons> <cons> list-length ] unit-test
+
+
+VARIANT: list2 ;
+VARIANT-MEMBER: list2 nil2
+VARIANT-MEMBER: list2 cons2: { { first object } { rest list2 } }
+
+[ t ] [ nil2 list2? ] unit-test
+[ t ] [ 1 nil2 <cons2> list2? ] unit-test
+[ f ] [ 1 list2? ] unit-test
+
+: list2-length ( list2 -- length )
+ {
+ { nil2 [ 0 ] }
+ { cons2 [ nip list2-length 1 + ] }
+ } match ;
+
+[ 4 ]
+[ 5 6 7 8 nil2 <cons2> <cons2> <cons2> <cons2> list2-length ] unit-test
: define-variant-member ( member -- class )
dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
-: define-variant-class ( class members -- )
- [ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
- [ define-variant-member swap add-mixin-instance ] with each ;
+: define-variant-class ( class -- )
+ [ define-mixin-class ] [ t "variant" set-word-prop ] bi ;
+
+: define-variant-class-member ( class member -- )
+ define-variant-member swap add-mixin-instance ;
+
+: define-variant-class-members ( class members -- )
+ [ dup define-variant-class ] dip
+ [ define-variant-class-member ] with each ;
: parse-variant-tuple-member ( name -- member )
create-class-in tuple
SYNTAX: VARIANT:
CREATE-CLASS
parse-variant-members
- define-variant-class ;
+ define-variant-class-members ;
+
+SYNTAX: VARIANT-MEMBER:
+ scan-word
+ scan parse-variant-member
+ define-variant-class-member ;
MACRO: unboa ( class -- )
<wrapper> \ boa [ ] 2sequence [undo] ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting math math.order
-calendar alarms logging concurrency.combinators namespaces
+calendar timers logging concurrency.combinators namespaces
db.types db.tuples db fry locals hashtables
syndication urls xml.writer validators
html.forms
(ratio constant "ratios")
(declaration keyword "declaration words")
(ebnf-form constant "EBNF: ... ;EBNF form")
+ (error-form warning "ERROR: ... ; form")
(parsing-word keyword "parsing words")
(postpone-body comment "postponed form")
(setter-word function-name "setter words (>>foo)")
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
(,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
+ (,fuel-syntax--alien-function-alias-regex (1 'factor-font-lock-word)
+ (2 'factor-font-lock-type-name)
+ (3 'factor-font-lock-word))
(,fuel-syntax--alien-callback-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-type-name)
(3 'factor-font-lock-invalid-syntax nil t))
+ (,fuel-syntax--c-global-regex (1 'factor-font-lock-type-name)
+ (2 'factor-font-lock-word)
+ (3 'factor-font-lock-invalid-syntax nil t))
+ (,fuel-syntax--c-type-regex (1 'factor-font-lock-type-name)
+ (2 'factor-font-lock-invalid-syntax nil t))
(,fuel-syntax--rename-regex (1 'factor-font-lock-word)
(2 'factor-font-lock-vocabulary-name)
(3 'factor-font-lock-word)
(,fuel-syntax--float-regex . 'factor-font-lock-number)
(,fuel-syntax--ratio-regex . 'factor-font-lock-ratio)
(,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
+ (,fuel-syntax--error-regex 2 'factor-font-lock-error-form)
(,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--before-definition-regex (1 'factor-font-lock-type-name)
'(":" "::" ";" "&:" "<<" "<PRIVATE" ">>"\r
"ABOUT:" "AFTER:" "ALIAS:" "ALIEN:" "ARTICLE:"\r
"B" "BEFORE:" "BIN:"\r
- "C:" "CALLBACK:" "ENUM:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"\r
- "DEFER:"\r
- "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"\r
- "f" "FORGET:" "FROM:" "FUNCTION:"\r
+ "C:" "CALLBACK:" "C-GLOBAL:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"\r
+ "DEFER:" "DESTRUCTOR:"\r
+ "EBNF:" ";EBNF" "ENUM:" "ERROR:" "EXCLUDE:"\r
+ "f" "FORGET:" "FROM:" "FUNCTION:" "FUNCTION-ALIAS:"\r
"GAME:" "GENERIC#" "GENERIC:"\r
"GLSL-SHADER:" "GLSL-PROGRAM:"\r
"HELP:" "HEX:" "HOOK:"\r
(fuel-syntax--second-word-regex\r
'("C-STRUCT:" "C-UNION:" "COM-INTERFACE:" "MIXIN:" "TUPLE:" "SINGLETON:" "SPECIALIZED-ARRAY:" "STRUCT:" "UNION:" "UNION-STRUCT:")))\r
\r
+(defconst fuel-syntax--error-regex\r
+ (fuel-syntax--second-word-regex '("ERROR:")))\r
+\r
(defconst fuel-syntax--tuple-decl-regex\r
"^TUPLE: +\\([^ \n]+\\) +< +\\([^ \n]+\\)\\_>")\r
\r
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")\r
\r
(defconst fuel-syntax--alien-function-regex\r
- "\\_<FUNCTION: \\(\\w+\\) \\(\\w+\\)")\r
+ "\\_<FUNCTION: +\\(\\w+\\)[\n ]+\\(\\w+\\)")\r
+\r
+(defconst fuel-syntax--alien-function-alias-regex\r
+ "\\_<FUNCTION-ALIAS: +\\(\\w+\\)[\n ]+\\(\\w+\\)[\n ]+\\(\\w+\\)")\r
\r
(defconst fuel-syntax--alien-callback-regex\r
- "\\_<CALLBACK: \\(\\w+\\) \\(\\w+\\)")\r
+ "\\_<CALLBACK: +\\(\\w+\\) +\\(\\w+\\)")\r
\r
(defconst fuel-syntax--indent-def-starts '("" ":"\r
"AFTER" "BEFORE"\r
- "ENUM" "COM-INTERFACE" "CONSULT"\r
- "FROM" "FUNCTION:"\r
+ "COM-INTERFACE" "CONSULT"\r
+ "ENUM" "ERROR"\r
+ "FROM" "FUNCTION:" "FUNCTION-ALIAS:"\r
"INTERSECTION:"\r
"M" "M:" "MACRO" "MACRO:"\r
"MEMO" "MEMO:" "METHOD"\r
(defconst fuel-syntax--single-liner-regex\r
(regexp-opt '("ABOUT:"\r
"ALIAS:"\r
- "CONSTANT:" "C:" "C-TYPE:"\r
- "DEFER:"\r
+ "CONSTANT:" "C:" "C-GLOBAL:" "C-TYPE:"\r
+ "DEFER:" "DESTRUCTOR:"\r
"FORGET:"\r
- "GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:" \r
+ "GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:"\r
"HEX:" "HOOK:"\r
"IN:" "INSTANCE:"\r
"LIBRARY:"\r
(defconst fuel-syntax--typedef-regex\r
"\\_<TYPEDEF: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")\r
\r
+(defconst fuel-syntax--c-global-regex\r
+ "\\_<C-GLOBAL: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")\r
+\r
+(defconst fuel-syntax--c-type-regex\r
+ "\\_<C-TYPE: +\\(\\w+\\)\\( .*\\)?$")\r
+\r
(defconst fuel-syntax--rename-regex\r
"\\_<RENAME: +\\(\\w+\\) +\\(\\w+\\) +=> +\\(\\w+\\)\\( .*\\)?$")\r
\r
return array;
}
-VM_C_API cell allot_byte_array(cell size, factor_vm *parent)
-{
- return tag<byte_array>(parent->allot_byte_array(size));
-}
-
void factor_vm::primitive_byte_array()
{
cell size = unbox_array_size();
return data;
}
-VM_C_API cell allot_byte_array(cell size, factor_vm *parent);
-
}
return (stack_frame *)((cell)frame - frame->size);
}
-/* Allocates memory */
+cell factor_vm::frame_offset(stack_frame *frame)
+{
+ char *entry_point = (char *)frame_code(frame)->entry_point();
+ char *return_address = (char *)FRAME_RETURN_ADDRESS(frame,this);
+ if(return_address)
+ return return_address - entry_point;
+ else
+ return (cell)-1;
+}
+
+void factor_vm::set_frame_offset(stack_frame *frame, cell offset)
+{
+ char *entry_point = (char *)frame_code(frame)->entry_point();
+ if(offset == (cell)-1)
+ FRAME_RETURN_ADDRESS(frame,this) = NULL;
+ else
+ FRAME_RETURN_ADDRESS(frame,this) = entry_point + offset;
+}
+
cell factor_vm::frame_scan(stack_frame *frame)
{
switch(frame_type(frame))
obj = obj.as<word>()->def;
if(obj.type_p(QUOTATION_TYPE))
- {
- char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame,this);
- char *quot_entry_point = (char *)frame_code(frame)->entry_point();
-
- return tag_fixnum(quot_code_offset_to_scan(
- obj.value(),(cell)(return_addr - quot_entry_point)));
- }
+ return tag_fixnum(quot_code_offset_to_scan(obj.value(),frame_offset(frame)));
else
return false_object;
}
}
}
-cell factor_vm::frame_offset(stack_frame *frame)
-{
- return (cell)FRAME_RETURN_ADDRESS(frame,this) - (cell)frame_code(frame)->entry_point();
-}
-
struct stack_frame_accumulator {
factor_vm *parent;
growable_array frames;
jit_compile_quot(quot.value(),true);
stack_frame *inner = innermost_stack_frame(callstack.untagged());
- cell offset = (char *)FRAME_RETURN_ADDRESS(inner,this) - (char *)inner->entry_point;
+ cell offset = frame_offset(inner);
inner->entry_point = quot->entry_point;
- FRAME_RETURN_ADDRESS(inner,this) = (char *)quot->entry_point + offset;
+ set_frame_offset(inner,offset);
}
void factor_vm::primitive_callstack_bounds()
void operator()(stack_frame *frame)
{
- code_block *old_block = parent->frame_code(frame);
- cell offset = (char *)FRAME_RETURN_ADDRESS(frame,parent) - (char *)old_block;
-
- const code_block *new_block = fixup.fixup_code(old_block);
- frame->entry_point = new_block->entry_point();
-
- FRAME_RETURN_ADDRESS(frame,parent) = (char *)new_block + offset;
+ cell offset = parent->frame_offset(frame);
+ code_block *compiled = fixup.fixup_code(parent->frame_code(frame));
+ frame->entry_point = compiled->entry_point();
+ parent->set_frame_offset(frame,offset);
}
};
object *fixup_data(object *obj)
{
+ parent->check_data_pointer(obj);
+
if(!policy.should_copy_p(obj))
{
policy.visited_object(obj);
{
cell base = info->scrub_d_base(index);
- for(cell loc = 0; loc < info->scrub_d_count; loc++)
+ for(int loc = 0; loc < info->scrub_d_count; loc++)
{
if(bitmap_p(bitmap,base + loc))
- ((cell *)datastack)[-loc] = 0;
+ {
+#ifdef DEBUG_GC_MAPS
+ std::cout << "scrubbing datastack location " << loc << std::endl;
+#endif
+ *((cell *)datastack - loc) = 0;
+ }
}
}
{
cell base = info->scrub_r_base(index);
- for(cell loc = 0; loc < info->scrub_r_count; loc++)
+ for(int loc = 0; loc < info->scrub_r_count; loc++)
{
if(bitmap_p(bitmap,base + loc))
- ((cell *)retainstack)[-loc] = 0;
+ {
+#ifdef DEBUG_GC_MAPS
+ std::cout << "scrubbing retainstack location " << loc << std::endl;
+#endif
+ *((cell *)retainstack - loc) = 0;
+ }
}
}
}
if(p->image_path == NULL)
p->image_path = default_image_path();
- srand((unsigned int)system_micros());
+ srand((unsigned int)nano_count());
init_ffi();
init_contexts(p->datastack_size,p->retainstack_size,p->callstack_size);
init_callbacks(p->callback_size);
{
if(this->state->marked_p(block))
{
- *finger = block;
+ *finger = (Block *)((char *)block + size);
memmove((Block *)address,block,size);
iter(block,(Block *)address,size);
address += size;
void operator()(stack_frame *frame)
{
- const code_block *compiled = parent->frame_code(frame);
+ cell return_address = parent->frame_offset(frame);
+ if(return_address == (cell)-1)
+ return;
+
+ code_block *compiled = parent->frame_code(frame);
gc_info *info = compiled->block_gc_info();
- cell return_address = parent->frame_offset(frame);
assert(return_address < compiled->size());
int index = info->return_address_index(return_address);
-
if(index != -1)
ctx->scrub_stacks(info,index);
}
{
u32 *return_address_array = return_addresses();
- for(cell i = 0; i < return_address_count; i++)
+ for(int i = 0; i < return_address_count; i++)
{
if(return_address == return_address_array[i])
return i;
{
struct gc_info {
- u32 scrub_d_count;
- u32 scrub_r_count;
- u32 gc_root_count;
- u32 return_address_count;
+ int scrub_d_count;
+ int scrub_r_count;
+ int gc_root_count;
+ int return_address_count;
cell total_bitmap_size()
{
}
}
-VM_C_API void to_signed_8(cell obj, s64 *out, factor_vm *parent)
+VM_C_API s64 to_signed_8(cell obj, factor_vm *parent)
{
- *out = parent->to_signed_8(obj);
+ return parent->to_signed_8(obj);
}
cell factor_vm::from_unsigned_8(u64 n)
}
}
-VM_C_API void to_unsigned_8(cell obj, u64 *out, factor_vm *parent)
+VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent)
{
- *out = parent->to_unsigned_8(obj);
+ return parent->to_unsigned_8(obj);
}
VM_C_API cell from_float(float flo, factor_vm *parent)
VM_C_API cell from_signed_8(s64 n, factor_vm *vm);
VM_C_API cell from_unsigned_8(u64 n, factor_vm *vm);
-VM_C_API void to_signed_8(cell obj, s64 *out, factor_vm *parent);
-VM_C_API void to_unsigned_8(cell obj, u64 *out, factor_vm *parent);
+VM_C_API s64 to_signed_8(cell obj, factor_vm *parent);
+VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent);
VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm);
VM_C_API cell to_cell(cell tagged, factor_vm *vm);
OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */
OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */
- OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */
-
OBJ_STARTUP_QUOT = 20, /* startup quotation */
OBJ_GLOBAL, /* global namespace */
OBJ_SHUTDOWN_QUOT, /* shutdown quotation */
void factor_vm::c_to_factor_toplevel(cell quot)
{
- for(;;)
- {
-NS_DURING
- c_to_factor(quot);
- NS_VOIDRETURN;
-NS_HANDLER
- ctx->push(allot_alien(false_object,(cell)localException));
- quot = special_objects[OBJ_COCOA_EXCEPTION];
- if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
- {
- /* No Cocoa exception handler was registered, so
- basis/cocoa/ is not loaded. So we pass the exception
- along. */
- [localException raise];
- }
-NS_ENDHANDLER
- }
+ c_to_factor(quot);
}
void early_init(void)
static void *null_dll;
-u64 system_micros()
-{
- struct timeval t;
- gettimeofday(&t,NULL);
- return (u64)t.tv_sec * 1000000 + t.tv_usec;
-}
-
void sleep_nanos(u64 nsec)
{
timespec ts;
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
-u64 system_micros();
u64 nano_count();
void sleep_nanos(u64 nsec);
void open_console();
namespace factor
{
-u64 system_micros()
-{
- SYSTEMTIME st;
- FILETIME ft;
- GetSystemTime(&st);
- SystemTimeToFileTime(&st, &ft);
- return (((s64)ft.dwLowDateTime
- | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10;
-}
-
char *strerror(int err)
{
/* strerror() is not defined on WinCE */
#define snprintf _snprintf
#define snwprintf _snwprintf
-u64 system_micros();
void c_to_factor_toplevel(cell quot);
void open_console();
return (void *)CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0);
}
-u64 system_micros()
-{
- FILETIME t;
- GetSystemTimeAsFileTime(&t);
- return (((u64)t.dwLowDateTime | (u64)t.dwHighDateTime<<32)
- - EPOCH_OFFSET) / 10;
-}
-
u64 nano_count()
{
static double scale_factor;
inline static void early_init() {}
-u64 system_micros();
u64 nano_count();
void sleep_nanos(u64 nsec);
long getpagesize();
_(special_object) \
_(string) \
_(strip_stack_traces) \
- _(system_micros) \
_(tuple) \
_(tuple_boa) \
_(unimplemented) \
exit((int)to_fixnum(ctx->pop()));
}
-void factor_vm::primitive_system_micros()
-{
- ctx->push(from_unsigned_8(system_micros()));
-}
-
void factor_vm::primitive_nano_count()
{
u64 nanos = nano_count();
.386\r
.model flat\r
-exception_handler proto\r
+exception_handler proto c\r
.safeseh exception_handler\r
end\r
*/
void operator()(stack_frame *frame)
{
- const code_block *compiled = visitor->fixup.translate_code(parent->frame_code(frame));
- gc_info *info = compiled->block_gc_info();
cell return_address = parent->frame_offset(frame);
+ if(return_address == (cell)-1)
+ return;
+
+ code_block *compiled = visitor->fixup.translate_code(parent->frame_code(frame));
+ gc_info *info = compiled->block_gc_info();
+
assert(return_address < compiled->size());
int index = info->return_address_index(return_address);
+ if(index == -1)
+ return;
- if(index != -1)
- {
- u8 *bitmap = info->gc_info_bitmap();
- cell base = info->spill_slot_base(index);
- cell *stack_pointer = (cell *)(parent->frame_successor(frame) + 1);
+#ifdef DEBUG_GC_MAPS
+ std::cout << "call frame code block " << compiled << " with offset " << return_address << std::endl;
+#endif
+ u8 *bitmap = info->gc_info_bitmap();
+ cell base = info->spill_slot_base(index);
+ cell *stack_pointer = (cell *)(parent->frame_successor(frame) + 1);
- for(cell spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++)
+ for(int spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++)
+ {
+ if(bitmap_p(bitmap,base + spill_slot))
{
- if(bitmap_p(bitmap,base + spill_slot))
- visitor->visit_handle(&stack_pointer[spill_slot]);
+#ifdef DEBUG_GC_MAPS
+ std::cout << "visiting spill slot " << spill_slot << std::endl;
+#endif
+ visitor->visit_handle(stack_pointer + spill_slot);
}
}
}
// run
void primitive_exit();
- void primitive_system_micros();
void primitive_nano_count();
void primitive_sleep();
void primitive_set_slot();
stack_frame *frame_successor(stack_frame *frame);
cell frame_scan(stack_frame *frame);
cell frame_offset(stack_frame *frame);
+ void set_frame_offset(stack_frame *frame, cell offset);
void primitive_callstack_to_array();
stack_frame *innermost_stack_frame(callstack *stack);
void primitive_innermost_stack_frame_executing();
projects / factor.git / commitdiff
