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

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

db4
Anton Gorenko 2010-06-07 23:12:23 +06:00
parent 33996ca1d6 90537038ea
commit e174b7a070
100 changed files with 17248 additions and 1134 deletions
basis
alarms
alien/prettyprint
bootstrap/image/download
calendar/model
command-line
compiler
cfg
instructions
intrinsics/simd
codegen
cpu
images/png
io/thread
json/reader
libc
math/vectors/simd/intrinsics
nibble-arrays
sequences/unrolled
tools
deploy/macosx
errors/model
ui
unix/ffi
vocabs/refresh/monitor
x11
xmode/catalog
extra
benchmark
bson
cuda
game/input/demos
gpu/buffers
key-logger
mason/updates
mongodb
nehe

19
Nmakefile
View File

@ -1,3 +1,7 @@
!IF !DEFINED(BOOTIMAGE_VERSION)
BOOTIMAGE_VERSION = latest
!ENDIF
!IF DEFINED(PLATFORM)
LINK_FLAGS = /nologo shell32.lib
@ -102,18 +106,19 @@ default:
@exit 1
x86-32:
nmake PLATFORM=x86-32 /f Nmakefile all
nmake /nologo PLATFORM=x86-32 /f Nmakefile all
x86-64:
nmake PLATFORM=x86-64 /f Nmakefile all
nmake /nologo PLATFORM=x86-64 /f Nmakefile all
clean:
del vm\*.obj
del factor.lib
del factor.com
del factor.exe
del factor.dll
del factor.dll.lib
if exist factor.lib del factor.lib
if exist factor.res del factor.res
if exist factor.com del factor.com
if exist factor.exe del factor.exe
if exist factor.dll del factor.dll
if exist factor.dll.lib del factor.dll.lib
.PHONY: all default x86-32 x86-64 clean

6
basis/alarms/alarms-docs.factor
View File

@ -8,6 +8,10 @@ HELP: start-alarm
{ $values { "alarm" alarm } }
{ $description "Starts an alarm." } ;
HELP: restart-alarm
{ $values { "alarm" alarm } }
{ $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." } ;
HELP: stop-alarm
{ $values { "alarm" alarm } }
{ $description "Prevents an alarm from calling its quotation again. Has no effect on alarms that are not currently running." } ;
@ -56,7 +60,7 @@ ARTICLE: "alarms" "Alarms"
"Create an alarm before starting it:"
{ $subsections <alarm> }
"Starting an alarm:"
{ $subsections start-alarm }
{ $subsections start-alarm restart-alarm }
"Stopping an alarm:"
{ $subsections stop-alarm }

21
basis/alarms/alarms-tests.factor
View File

@ -44,3 +44,24 @@ IN: alarms.tests
2 seconds sleep stop-alarm
1/2 seconds sleep
] unit-test
[ { 0 } ] [
{ 0 }
dup '[ 1 _ set-first ] 300 milliseconds later
150 milliseconds sleep
[ restart-alarm ] [ 200 milliseconds sleep stop-alarm ] bi
] unit-test
[ { 1 } ] [
{ 0 }
dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later
100 milliseconds sleep restart-alarm 300 milliseconds sleep
] unit-test
[ { 4 } ] [
{ 0 }
dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds
<alarm> dup start-alarm
700 milliseconds sleep dup restart-alarm
700 milliseconds sleep stop-alarm 500 milliseconds sleep
] unit-test

30
basis/alarms/alarms.factor
View File

@ -12,6 +12,7 @@ TUPLE: alarm
interval-nanos
iteration-start-nanos
quotation-running?
restart?
thread ;
<PRIVATE
@ -33,7 +34,7 @@ M: duration >nanoseconds duration>nanoseconds >integer ;
>>iteration-start-nanos ;
: stop-alarm? ( alarm -- ? )
thread>> self eq? not ;
{ [ thread>> self eq? not ] [ restart?>> ] } 1|| ;
DEFER: call-alarm-loop
@ -60,6 +61,19 @@ DEFER: call-alarm-loop
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 )
@ -70,11 +84,7 @@ PRIVATE>
: start-alarm ( alarm -- )
[
'[
_ nano-count >>start-nanos
[ delay-nanos>> [ sleep ] when* ]
[ nano-count >>iteration-start-nanos call-alarm-loop ] bi
] "Alarm execution" spawn
'[ _ alarm-loop ] "Alarm execution" spawn
] keep thread<< ;
: stop-alarm ( alarm -- )
@ -84,6 +94,14 @@ PRIVATE>
[ [ 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 )

55
basis/alien/prettyprint/prettyprint-tests.factor Normal file
View File

@ -0,0 +1,55 @@
USING: alien.c-types alien.prettyprint alien.syntax
io.streams.string see tools.test prettyprint ;
IN: alien.prettyprint.tests
CONSTANT: FOO 10
FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w ) ;
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
FUNCTION: int function_test
( float x, int[4][FOO] y, char* z, ushort* w ) ;
" ] [
[ \ function_test see ] with-string-writer
] unit-test
FUNCTION-ALIAS: function-test int function_test
( float x, int[4][FOO] y, char* z, ushort *w ) ;
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
FUNCTION-ALIAS: function-test int function_test
( float x, int[4][FOO] y, char* z, ushort* w ) ;
" ] [
[ \ function-test see ] with-string-writer
] unit-test
C-TYPE: opaque-c-type
[ "USING: alien.syntax ;
IN: alien.prettyprint.tests
C-TYPE: opaque-c-type
" ] [
[ \ opaque-c-type see ] with-string-writer
] unit-test
TYPEDEF: pointer: int pint
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
TYPEDEF: int* pint
" ] [
[ \ pint see ] with-string-writer
] unit-test
[ "pointer: int" ] [ pointer: int unparse ] unit-test
CALLBACK: void callback-test ( int x, float[4] y ) ;
[ "USING: alien.c-types alien.syntax ;
IN: alien.prettyprint.tests
CALLBACK: void callback-test ( int x, float[4] y ) ;
" ] [
[ \ callback-test see ] with-string-writer
] unit-test

39
basis/alien/prettyprint/prettyprint.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators alien alien.enums
alien.strings alien.c-types alien.parser alien.syntax arrays
assocs effects math.parser prettyprint.backend prettyprint.custom
prettyprint.sections definitions see see.private sequences
strings words ;
assocs effects math.parser prettyprint prettyprint.backend
prettyprint.custom prettyprint.sections definitions see
see.private sequences strings words ;
IN: alien.prettyprint
M: alien pprint*
@ -23,21 +23,26 @@ M: c-type-word declarations. drop ;
<PRIVATE
GENERIC: pointer-string ( pointer -- string/f )
M: object pointer-string drop f ;
M: word pointer-string name>> ;
M: word pointer-string [ record-vocab ] [ name>> ] bi ;
M: pointer pointer-string to>> pointer-string [ CHAR: * suffix ] [ f ] if* ;
GENERIC: c-type-string ( c-type -- string )
M: word c-type-string [ record-vocab ] [ name>> ] bi ;
M: pointer c-type-string dup pointer-string [ ] [ unparse ] ?if ;
M: wrapper c-type-string wrapped>> c-type-string ;
M: array c-type-string
unclip
[ [ unparse "[" "]" surround ] map ]
[ c-type-string ] bi*
prefix "" join ;
PRIVATE>
GENERIC: pprint-c-type ( c-type -- )
M: word pprint-c-type pprint-word ;
M: pointer pprint-c-type
dup pointer-string
[ swap present-text ]
[ pprint* ] if* ;
M: wrapper pprint-c-type wrapped>> pprint-word ;
M: string pprint-c-type text ;
M: array pprint-c-type pprint* ;
: pprint-c-type ( c-type -- )
[ c-type-string ] keep present-text ;
M: pointer pprint* \ pointer: pprint-word to>> pprint-c-type ;
M: pointer pprint*
<flow \ pointer: pprint-word to>> pprint* block> ;
M: typedef-word definer drop \ TYPEDEF: f ;
@ -102,11 +107,11 @@ M: alien-callback-type-word synopsis*
[ seeing-word ]
[ "callback-library" word-prop pprint-library ]
[ definer. ]
[ def>> first pprint-c-type ]
[ def>> first first pprint-c-type ]
[ pprint-word ]
[
<block "(" text
[ def>> second ] [ "callback-effect" word-prop in>> ] bi
[ def>> first second ] [ "callback-effect" word-prop in>> ] bi
pprint-function-args
")" text block>
]

25
basis/bootstrap/image/download/download.factor
View File

@ -18,20 +18,19 @@ CONSTANT: url URL" http://factorcode.org/images/latest/"
bi = not
] [ drop t ] if ;
: download-image ( arch -- )
url swap boot-image-name >url derive-url download ;
: verify-image ( image -- )
need-new-image? [ "Boot image corrupt" throw ] when ;
: maybe-download-image ( arch -- )
dup boot-image-name need-new-image? [
dup download-image
need-new-image? [
"Boot image corrupt, or checksums.txt on server out of date" throw
] when
] [
"Boot image up to date" print
drop
] if ;
: download-image ( image -- )
[ url swap >url derive-url download ]
[ verify-image ]
bi ;
: download-my-image ( -- ) my-arch maybe-download-image ;
: maybe-download-image ( image -- ? )
dup need-new-image?
[ download-image t ] [ drop f ] if ;
: download-my-image ( -- )
my-arch boot-image-name maybe-download-image drop ;
MAIN: download-my-image

8
basis/calendar/model/model.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov
! Copyright (C) 2008, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: calendar namespaces models threads kernel init ;
IN: calendar.model
@ -15,5 +15,7 @@ SYMBOL: time
(time-thread)
] "Time model update" spawn drop ;
f <model> time set-global
[ time-thread ] "calendar.model" add-startup-hook
[
f <model> time set-global
time-thread
] "calendar.model" add-startup-hook

2
basis/command-line/command-line.factor
View File

@ -28,7 +28,7 @@ SYMBOL: command-line
: load-vocab-roots ( -- )
"user-init" get [
"factor-roots" rc-path dup exists? [
utf8 file-lines [ add-vocab-root ] each
utf8 file-lines harvest [ add-vocab-root ] each
] [ drop ] if
] when ;

5
basis/compiler/cfg/instructions/instructions.factor
View File

@ -345,6 +345,11 @@ def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##float-pack-vector
def: dst
use: src
literal: rep ;
PURE-INSN: ##signed-pack-vector
def: dst
use: src1 src2

1
basis/compiler/cfg/intrinsics/simd/backend/backend.factor
View File

@ -28,6 +28,7 @@ M: ##shuffle-vector-imm insn-available? rep>> %shuffle-vector-imm-reps member? ;
M: ##shuffle-vector-halves-imm insn-available? rep>> %shuffle-vector-halves-imm-reps member? ;
M: ##merge-vector-head insn-available? rep>> %merge-vector-reps member? ;
M: ##merge-vector-tail insn-available? rep>> %merge-vector-reps member? ;
M: ##float-pack-vector insn-available? rep>> %float-pack-vector-reps member? ;
M: ##signed-pack-vector insn-available? rep>> %signed-pack-vector-reps member? ;
M: ##unsigned-pack-vector insn-available? rep>> %unsigned-pack-vector-reps member? ;
M: ##unpack-vector-head insn-available? rep>> %unpack-vector-head-reps member? ;

7
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -570,7 +570,12 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
: emit-simd-vpack-signed ( node -- )
{
[ ^^signed-pack-vector ]
{ double-2-rep [| src1 src2 rep |
src1 double-2-rep ^^float-pack-vector :> dst-head
src2 double-2-rep ^^float-pack-vector :> dst-tail
dst-head dst-tail { 0 1 0 1 } float-4-rep ^^shuffle-vector-halves-imm
] }
{ int-vector-rep [ ^^signed-pack-vector ] }
} emit-vv-vector-op ;
: emit-simd-vpack-unsigned ( node -- )

1
basis/compiler/codegen/codegen.factor
View File

@ -191,6 +191,7 @@ CODEGEN: ##shuffle-vector %shuffle-vector
CODEGEN: ##tail>head-vector %tail>head-vector
CODEGEN: ##merge-vector-head %merge-vector-head
CODEGEN: ##merge-vector-tail %merge-vector-tail
CODEGEN: ##float-pack-vector %float-pack-vector
CODEGEN: ##signed-pack-vector %signed-pack-vector
CODEGEN: ##unsigned-pack-vector %unsigned-pack-vector
CODEGEN: ##unpack-vector-head %unpack-vector-head

3
basis/cpu/architecture/architecture.factor
View File

@ -314,6 +314,7 @@ HOOK: %shuffle-vector-halves-imm cpu ( dst src1 src2 shuffle rep -- )
HOOK: %tail>head-vector cpu ( dst src rep -- )
HOOK: %merge-vector-head cpu ( dst src1 src2 rep -- )
HOOK: %merge-vector-tail cpu ( dst src1 src2 rep -- )
HOOK: %float-pack-vector cpu ( dst src rep -- )
HOOK: %signed-pack-vector cpu ( dst src1 src2 rep -- )
HOOK: %unsigned-pack-vector cpu ( dst src1 src2 rep -- )
HOOK: %unpack-vector-head cpu ( dst src rep -- )
@ -371,6 +372,7 @@ HOOK: %shuffle-vector-reps cpu ( -- reps )
HOOK: %shuffle-vector-imm-reps cpu ( -- reps )
HOOK: %shuffle-vector-halves-imm-reps cpu ( -- reps )
HOOK: %merge-vector-reps cpu ( -- reps )
HOOK: %float-pack-vector-reps cpu ( -- reps )
HOOK: %signed-pack-vector-reps cpu ( -- reps )
HOOK: %unsigned-pack-vector-reps cpu ( -- reps )
HOOK: %unpack-vector-head-reps cpu ( -- reps )
@ -423,6 +425,7 @@ M: object %shuffle-vector-reps { } ;
M: object %shuffle-vector-imm-reps { } ;
M: object %shuffle-vector-halves-imm-reps { } ;
M: object %merge-vector-reps { } ;
M: object %float-pack-vector-reps { } ;
M: object %signed-pack-vector-reps { } ;
M: object %unsigned-pack-vector-reps { } ;
M: object %unpack-vector-head-reps { } ;

8
basis/cpu/x86/sse/sse.factor
View File

@ -298,6 +298,14 @@ M: x86 %merge-vector-reps
{ sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
M: x86 %float-pack-vector
drop CVTPD2PS ;
M: x86 %float-pack-vector-reps
{
{ sse2? { double-2-rep } }
} available-reps ;
M: x86 %signed-pack-vector
[ two-operand ] keep
{

10
basis/images/png/png.factor
View File

@ -290,14 +290,6 @@ ERROR: invalid-color-type/bit-depth loading-png ;
: validate-truecolor-alpha ( loading-png -- loading-png )
{ 8 16 } validate-bit-depth ;
: pad-bitmap ( image -- image )
dup dim>> second 4 divisor? [
dup [ bytes-per-pixel ]
[ dim>> first * ]
[ dim>> first 4 mod ] tri
'[ _ group [ _ 0 <array> append ] map B{ } concat-as ] change-bitmap
] unless ;
: loading-png>bitmap ( loading-png -- bytes component-order )
dup color-type>> {
{ greyscale [
@ -323,7 +315,7 @@ ERROR: invalid-color-type/bit-depth loading-png ;
[ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
[ png-component >>component-type ]
} cleave pad-bitmap ;
} cleave ;
: load-png ( stream -- loading-png )
[

3
basis/io/thread/thread.factor
View File

@ -14,6 +14,9 @@ SYMBOL: io-thread-running?
[ [ io-thread-running? get-global ] [ io-thread ] while ]
"I/O wait" spawn drop ;
: stop-io-thread ( -- )
f io-thread-running? set-global ;
[
t io-thread-running? set-global
start-io-thread

8
basis/json/reader/reader-docs.factor
View File

@ -1,14 +1,18 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax ;
USING: help.markup help.syntax kernel ;
IN: json.reader
HELP: json>
{ $values { "string" "a string in JSON format" } { "object" "a deserialized object" } }
{ $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
HELP: read-jsons
{ $values { "objects" "a vector of deserialized objects" } }
{ $description "Reads JSON formatted strings into a vector of Factor object until the end of the stream is reached. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
ARTICLE: "json.reader" "JSON reader"
"The " { $vocab-link "json.reader" } " vocabulary defines a word for parsing strings in JSON format."
{ $subsections json> } ;
{ $subsections json> read-jsons } ;
ABOUT: "json.reader"

5
basis/json/reader/reader-tests.factor
View File

@ -1,5 +1,5 @@
USING: assocs arrays json.reader kernel strings tools.test
hashtables json ;
hashtables json io.streams.string ;
IN: json.reader.tests
{ f } [ "false" json> ] unit-test
@ -59,5 +59,8 @@ IN: json.reader.tests
{ 0 } [ "0 " json> ] unit-test
{ 0 } [ " 0 " json> ] unit-test
{ V{ H{ { "a" "b" } } H{ { "c" "d" } } } }
[ """{"a": "b"} {"c": "d"}""" [ read-jsons ] with-string-reader ] unit-test
! empty objects are allowed as values in objects
{ H{ { "foo" H{ } } } } [ "{ \"foo\" : {}}" json> ] unit-test

10
basis/json/reader/reader.factor
View File

@ -78,7 +78,7 @@ DEFER: j-string
{ CHAR: { [ 2 [ V{ } clone over push ] times ] }
{ CHAR: : [ v-pick-push ] }
{ CHAR: } [ (close-hash) ] }
{ CHAR: \u000020 [ ] }
{ CHAR: \s [ ] }
{ CHAR: \t [ ] }
{ CHAR: \r [ ] }
{ CHAR: \n [ ] }
@ -89,10 +89,10 @@ DEFER: j-string
} case
] when* ;
: (json-parser>) ( string -- object )
[ V{ } clone [ read1 dup ] [ scan ] while drop first ] with-string-reader ;
PRIVATE>
: read-jsons ( -- objects )
V{ } clone [ read1 dup ] [ scan ] while drop ;
: json> ( string -- object )
(json-parser>) ;
[ read-jsons first ] with-string-reader ;

2
basis/libc/libc.factor
View File

@ -100,5 +100,7 @@ FUNCTION: int memcmp ( void* a, void* b, ulong size ) ;
FUNCTION: size_t strlen ( c-string alien ) ;
FUNCTION: int system ( c-string command ) ;
DESTRUCTOR: free
DESTRUCTOR: (free)

232
basis/math/vectors/simd/intrinsics/intrinsics.factor
View File

@ -1,9 +1,10 @@
! (c)2009 Slava Pestov, Joe Groff bsd license
USING: accessors alien alien.c-types alien.data combinators
USING: accessors alien alien.data combinators
sequences.cords cpu.architecture fry generalizations grouping
kernel libc locals math math.libm math.order math.ranges
math.vectors sequences sequences.generalizations
sequences.private specialized-arrays vocabs.loader ;
kernel libc locals macros math math.libm math.order
math.ranges math.vectors sequences sequences.generalizations
sequences.private sequences.unrolled sequences.unrolled.private
specialized-arrays vocabs.loader words effects.parser locals.parser ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAYS:
c:char c:short c:int c:longlong
@ -11,6 +12,20 @@ SPECIALIZED-ARRAYS:
c:float c:double ;
IN: math.vectors.simd.intrinsics
<<
: simd-intrinsic-body ( def effect -- def' )
'[ _ _ call-effect ] ;
: define-simd-intrinsic ( word def effect -- )
[ simd-intrinsic-body ] keep define-declared ;
SYNTAX: SIMD-INTRINSIC:
(:) define-declared ;
SYNTAX: SIMD-INTRINSIC::
(::) define-declared ;
>>
: assert-positive ( x -- y ) ;
<PRIVATE
@ -45,16 +60,16 @@ IN: math.vectors.simd.intrinsics
: [byte>rep-array] ( rep -- class )
{
{ char-16-rep [ [ char-array-cast ] ] }
{ uchar-16-rep [ [ uchar-array-cast ] ] }
{ short-8-rep [ [ short-array-cast ] ] }
{ ushort-8-rep [ [ ushort-array-cast ] ] }
{ int-4-rep [ [ int-array-cast ] ] }
{ uint-4-rep [ [ uint-array-cast ] ] }
{ longlong-2-rep [ [ longlong-array-cast ] ] }
{ ulonglong-2-rep [ [ ulonglong-array-cast ] ] }
{ float-4-rep [ [ float-array-cast ] ] }
{ double-2-rep [ [ double-array-cast ] ] }
{ char-16-rep [ [ 16 <direct-char-array> ] ] }
{ uchar-16-rep [ [ 16 <direct-uchar-array> ] ] }
{ short-8-rep [ [ 8 <direct-short-array> ] ] }
{ ushort-8-rep [ [ 8 <direct-ushort-array> ] ] }
{ int-4-rep [ [ 4 <direct-int-array> ] ] }
{ uint-4-rep [ [ 4 <direct-uint-array> ] ] }
{ longlong-2-rep [ [ 2 <direct-longlong-array> ] ] }
{ ulonglong-2-rep [ [ 2 <direct-ulonglong-array> ] ] }
{ float-4-rep [ [ 4 <direct-float-array> ] ] }
{ double-2-rep [ [ 2 <direct-double-array> ] ] }
} case ; foldable
: [>rep-array] ( rep -- class )
@ -96,27 +111,31 @@ IN: math.vectors.simd.intrinsics
[<rep-array>] call( -- a' ) ; inline
: components-map ( a rep quot -- c )
[ >rep-array ] dip map underlying>> ; inline
[ [ >rep-array ] [ rep-length ] bi ] dip unrolled-map-unsafe underlying>> ; inline
: components-2map ( a b rep quot -- c )
[ 2>rep-array ] dip 2map underlying>> ; inline
[ [ 2>rep-array ] [ rep-length ] bi ] dip unrolled-2map-unsafe underlying>> ; inline
! XXX
: components-reduce ( a rep quot -- x )
[ >rep-array [ ] ] dip map-reduce ; inline
: bitwise-components-map ( a rep quot -- c )
[ >bitwise-vector-rep >rep-array ] dip map underlying>> ; inline
[ >bitwise-vector-rep [ >rep-array ] [ rep-length ] bi ] dip
unrolled-map-unsafe underlying>> ; inline
: bitwise-components-2map ( a b rep quot -- c )
[ >bitwise-vector-rep 2>rep-array ] dip 2map underlying>> ; inline
[ >bitwise-vector-rep [ 2>rep-array ] [ rep-length ] bi ] dip
unrolled-2map-unsafe underlying>> ; inline
! XXX
: bitwise-components-reduce ( a rep quot -- x )
[ >bitwise-vector-rep >rep-array [ ] ] dip map-reduce ; inline
:: (vshuffle) ( a elts rep -- c )
a rep >rep-array :> a'
rep <rep-array> :> c'
elts [| from to |
elts rep rep-length [| from to |
from rep rep-length 1 - bitand
a' nth-unsafe
to c' set-nth-unsafe
] each-index
] unrolled-each-index-unsafe
c' underlying>> ; inline
:: (vshuffle2) ( a b elts rep -- c )
@ -124,39 +143,44 @@ IN: math.vectors.simd.intrinsics
b rep >rep-array :> b'
a' b' cord-append :> ab'
rep <rep-array> :> c'
elts [| from to |
elts rep rep-length [| from to |
from rep rep-length dup + 1 - bitand
ab' nth-unsafe
to c' set-nth-unsafe
] each-index
] unrolled-each-index-unsafe
c' underlying>> ; inline
GENERIC: native/ ( x y -- x/y )
M: integer native/ /i ; inline
M: float native/ /f ; inline
PRIVATE>
: (simd-v+) ( a b rep -- c ) [ + ] components-2map ;
: (simd-v-) ( a b rep -- c ) [ - ] components-2map ;
: (simd-vneg) ( a rep -- c ) [ neg ] components-map ;
:: (simd-v+-) ( a b rep -- c )
SIMD-INTRINSIC: (simd-v+) ( a b rep -- c ) [ + ] components-2map ;
SIMD-INTRINSIC: (simd-v-) ( a b rep -- c ) [ - ] components-2map ;
SIMD-INTRINSIC: (simd-vneg) ( a rep -- c ) [ neg ] components-map ;
SIMD-INTRINSIC:: (simd-v+-) ( a b rep -- c )
a b rep 2>rep-array :> ( a' b' )
rep <rep-array> :> c'
0 rep rep-length 1 - 2 <range> [| n |
0 rep rep-length [ 1 - 2 <range> ] [ 2 /i ] bi [| n |
n a' nth-unsafe n b' nth-unsafe -
n c' set-nth-unsafe
n 1 + a' nth-unsafe n 1 + b' nth-unsafe +
n 1 + c' set-nth-unsafe
] each
] unrolled-each-unsafe
c' underlying>> ;
: (simd-vs+) ( a b rep -- c )
dup rep-component-type '[ + _ c-type-clamp ] components-2map ;
: (simd-vs-) ( a b rep -- c )
dup rep-component-type '[ - _ c-type-clamp ] components-2map ;
: (simd-vs*) ( a b rep -- c )
dup rep-component-type '[ * _ c-type-clamp ] components-2map ;
: (simd-v*) ( a b rep -- c ) [ * ] components-2map ;
: (simd-v*high) ( a b rep -- c )
dup rep-component-type heap-size -8 * '[ * _ shift ] components-2map ;
:: (simd-v*hs+) ( a b rep -- c )
SIMD-INTRINSIC: (simd-vs+) ( a b rep -- c )
dup rep-component-type '[ + _ c:c-type-clamp ] components-2map ;
SIMD-INTRINSIC: (simd-vs-) ( a b rep -- c )
dup rep-component-type '[ - _ c:c-type-clamp ] components-2map ;
SIMD-INTRINSIC: (simd-vs*) ( a b rep -- c )
dup rep-component-type '[ * _ c:c-type-clamp ] components-2map ;
SIMD-INTRINSIC: (simd-v*) ( a b rep -- c ) [ * ] components-2map ;
SIMD-INTRINSIC: (simd-v*high) ( a b rep -- c )
dup rep-component-type c:heap-size -8 * '[ * _ shift ] components-2map ;
SIMD-INTRINSIC:: (simd-v*hs+) ( a b rep -- c )
rep { char-16-rep uchar-16-rep } member-eq?
[ uchar-16-rep char-16-rep ]
[ rep rep ] if :> ( a-rep b-rep )
@ -164,102 +188,110 @@ PRIVATE>
wide-rep rep-component-type :> wide-type
a a-rep >rep-array 2 <groups> :> a'
b b-rep >rep-array 2 <groups> :> b'
a' b' [
a' b' rep rep-length 2 /i [
[ [ first ] bi@ * ]
[ [ second ] bi@ * ] 2bi +
wide-type c-type-clamp
] wide-rep <rep-array> 2map-as underlying>> ;
: (simd-v/) ( a b rep -- c ) [ / ] components-2map ;
: (simd-vavg) ( a b rep -- c )
wide-type c:c-type-clamp
] wide-rep <rep-array> unrolled-2map-as-unsafe underlying>> ;
SIMD-INTRINSIC: (simd-v/) ( a b rep -- c ) [ native/ ] components-2map ;
SIMD-INTRINSIC: (simd-vavg) ( a b rep -- c )
[ + dup integer? [ 1 + -1 shift ] [ 0.5 * ] if ] components-2map ;
: (simd-vmin) ( a b rep -- c ) [ min ] components-2map ;
: (simd-vmax) ( a b rep -- c ) [ max ] components-2map ;
: (simd-v.) ( a b rep -- n )
SIMD-INTRINSIC: (simd-vmin) ( a b rep -- c ) [ min ] components-2map ;
SIMD-INTRINSIC: (simd-vmax) ( a b rep -- c ) [ max ] components-2map ;
! XXX
SIMD-INTRINSIC: (simd-v.) ( a b rep -- n )
[ 2>rep-array [ [ first ] bi@ * ] 2keep ] keep
1 swap rep-length [a,b) [ '[ _ swap nth-unsafe ] bi@ * + ] with with each ;
: (simd-vsqrt) ( a rep -- c ) [ fsqrt ] components-map ;
: (simd-vsad) ( a b rep -- c ) 2>rep-array [ - abs ] [ + ] 2map-reduce ;
: (simd-sum) ( a rep -- n ) [ + ] components-reduce ;
: (simd-vabs) ( a rep -- c ) [ abs ] components-map ;
: (simd-vbitand) ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
: (simd-vbitandn) ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
: (simd-vbitor) ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
: (simd-vbitxor) ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
: (simd-vbitnot) ( a rep -- c ) [ bitnot ] bitwise-components-map ;
: (simd-vand) ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
: (simd-vandn) ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
: (simd-vor) ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
: (simd-vxor) ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
: (simd-vnot) ( a rep -- c ) [ bitnot ] bitwise-components-map ;
: (simd-vlshift) ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
: (simd-vrshift) ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
: (simd-hlshift) ( a n rep -- c )
SIMD-INTRINSIC: (simd-vsqrt) ( a rep -- c ) [ fsqrt ] components-map ;
SIMD-INTRINSIC: (simd-vsad) ( a b rep -- c ) 2>rep-array [ - abs ] [ + ] 2map-reduce ;
SIMD-INTRINSIC: (simd-sum) ( a rep -- n ) [ + ] components-reduce ;
SIMD-INTRINSIC: (simd-vabs) ( a rep -- c ) [ abs ] components-map ;
SIMD-INTRINSIC: (simd-vbitand) ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
SIMD-INTRINSIC: (simd-vbitandn) ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
SIMD-INTRINSIC: (simd-vbitor) ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
SIMD-INTRINSIC: (simd-vbitxor) ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
SIMD-INTRINSIC: (simd-vbitnot) ( a rep -- c ) [ bitnot ] bitwise-components-map ;
SIMD-INTRINSIC: (simd-vand) ( a b rep -- c ) [ bitand ] bitwise-components-2map ;
SIMD-INTRINSIC: (simd-vandn) ( a b rep -- c ) [ [ bitnot ] dip bitand ] bitwise-components-2map ;
SIMD-INTRINSIC: (simd-vor) ( a b rep -- c ) [ bitor ] bitwise-components-2map ;
SIMD-INTRINSIC: (simd-vxor) ( a b rep -- c ) [ bitxor ] bitwise-components-2map ;
SIMD-INTRINSIC: (simd-vnot) ( a rep -- c ) [ bitnot ] bitwise-components-map ;
SIMD-INTRINSIC: (simd-vlshift) ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
SIMD-INTRINSIC: (simd-vrshift) ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
! XXX
SIMD-INTRINSIC: (simd-hlshift) ( a n rep -- c )
drop head-slice* 16 0 pad-head ;
: (simd-hrshift) ( a n rep -- c )
! XXX
SIMD-INTRINSIC: (simd-hrshift) ( a n rep -- c )
drop tail-slice 16 0 pad-tail ;
: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
: (simd-vshuffle2-elements) ( a b n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle2) ;
: (simd-vshuffle-bytes) ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
:: (simd-vmerge-head) ( a b rep -- c )
SIMD-INTRINSIC: (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
SIMD-INTRINSIC: (simd-vshuffle2-elements) ( a b n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle2) ;
SIMD-INTRINSIC: (simd-vshuffle-bytes) ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
SIMD-INTRINSIC:: (simd-vmerge-head) ( a b rep -- c )
a b rep 2>rep-array :> ( a' b' )
rep <rep-array> :> c'
rep rep-length 2 /i iota [| n |
rep rep-length 2 /i [| n |
n a' nth-unsafe n 2 * c' set-nth-unsafe
n b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
] each
] unrolled-each-integer
c' underlying>> ;
:: (simd-vmerge-tail) ( a b rep -- c )
SIMD-INTRINSIC:: (simd-vmerge-tail) ( a b rep -- c )
a b rep 2>rep-array :> ( a' b' )
rep <rep-array> :> c'
rep rep-length 2 /i :> len
len iota [| n |
len [| n |
n len + a' nth-unsafe n 2 * c' set-nth-unsafe
n len + b' nth-unsafe n 2 * 1 + c' set-nth-unsafe
] each
] unrolled-each-integer
c' underlying>> ;
: (simd-v<=) ( a b rep -- c )
SIMD-INTRINSIC: (simd-v<=) ( a b rep -- c )
dup rep-tf-values '[ <= _ _ ? ] components-2map ;
: (simd-v<) ( a b rep -- c )
SIMD-INTRINSIC: (simd-v<) ( a b rep -- c )
dup rep-tf-values '[ < _ _ ? ] components-2map ;
: (simd-v=) ( a b rep -- c )
SIMD-INTRINSIC: (simd-v=) ( a b rep -- c )
dup rep-tf-values '[ = _ _ ? ] components-2map ;
: (simd-v>) ( a b rep -- c )
SIMD-INTRINSIC: (simd-v>) ( a b rep -- c )
dup rep-tf-values '[ > _ _ ? ] components-2map ;
: (simd-v>=) ( a b rep -- c )
SIMD-INTRINSIC: (simd-v>=) ( a b rep -- c )
dup rep-tf-values '[ >= _ _ ? ] components-2map ;
: (simd-vunordered?) ( a b rep -- c )
SIMD-INTRINSIC: (simd-vunordered?) ( a b rep -- c )
dup rep-tf-values '[ unordered? _ _ ? ] components-2map ;
: (simd-vany?) ( a rep -- ? ) [ bitor ] bitwise-components-reduce zero? not ;
: (simd-vall?) ( a rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
: (simd-vnone?) ( a rep -- ? ) [ bitor ] bitwise-components-reduce zero? ;
: (simd-v>float) ( a rep -- c )
[ >rep-array [ >float ] ] [ >float-vector-rep <rep-array> ] bi map-as underlying>> ;
: (simd-v>integer) ( a rep -- c )
[ >rep-array [ >integer ] ] [ >int-vector-rep <rep-array> ] bi map-as underlying>> ;
: (simd-vpack-signed) ( a b rep -- c )
[ 2>rep-array cord-append ]
SIMD-INTRINSIC: (simd-vany?) ( a rep -- ? ) [ bitor ] bitwise-components-reduce zero? not ;
SIMD-INTRINSIC: (simd-vall?) ( a rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
SIMD-INTRINSIC: (simd-vnone?) ( a rep -- ? ) [ bitor ] bitwise-components-reduce zero? ;
SIMD-INTRINSIC: (simd-v>float) ( a rep -- c )
[ [ >rep-array ] [ rep-length ] bi [ >float ] ]
[ >float-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
SIMD-INTRINSIC: (simd-v>integer) ( a rep -- c )
[ [ >rep-array ] [ rep-length ] bi [ >integer ] ]
[ >int-vector-rep <rep-array> ] bi unrolled-map-as-unsafe underlying>> ;
SIMD-INTRINSIC: (simd-vpack-signed) ( a b rep -- c )
[ [ 2>rep-array cord-append ] [ rep-length 2 * ] bi ]
[ narrow-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
'[ _ c-type-clamp ] swap map-as underlying>> ;
: (simd-vpack-unsigned) ( a b rep -- c )
[ 2>rep-array cord-append ]
'[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
SIMD-INTRINSIC: (simd-vpack-unsigned) ( a b rep -- c )
[ [ 2>rep-array cord-append ] [ rep-length 2 * ] bi ]
[ narrow-vector-rep >uint-vector-rep [ <rep-array> ] [ rep-component-type ] bi ] bi
'[ _ c-type-clamp ] swap map-as underlying>> ;
: (simd-vunpack-head) ( a rep -- c )
'[ _ c:c-type-clamp ] swap unrolled-map-as-unsafe underlying>> ;
! XXX
SIMD-INTRINSIC: (simd-vunpack-head) ( a rep -- c )
[ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
[ head-slice ] dip call( a' -- c' ) underlying>> ;
: (simd-vunpack-tail) ( a rep -- c )
! XXX
SIMD-INTRINSIC: (simd-vunpack-tail) ( a rep -- c )
[ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
[ tail-slice ] dip call( a' -- c' ) underlying>> ;
: (simd-with) ( n rep -- v )
! XXX
SIMD-INTRINSIC: (simd-with) ( n rep -- v )
[ rep-length swap '[ _ ] ] [ <rep-array> ] bi replicate-as
underlying>> ;
: (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn ] keep underlying>> ;
: (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ;
: (simd-select) ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ;
SIMD-INTRINSIC: (simd-gather-2) ( m n rep -- v ) <rep-array> [ 2 set-firstn-unsafe ] keep underlying>> ;
SIMD-INTRINSIC: (simd-gather-4) ( m n o p rep -- v ) <rep-array> [ 4 set-firstn-unsafe ] keep underlying>> ;
SIMD-INTRINSIC: (simd-select) ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ;
: alien-vector ( c-ptr n rep -- value )
SIMD-INTRINSIC: alien-vector ( c-ptr n rep -- value )
[ swap <displaced-alien> ] dip rep-size memory>byte-array ;
: set-alien-vector ( value c-ptr n rep -- )
SIMD-INTRINSIC: set-alien-vector ( value c-ptr n rep -- )
[ swap <displaced-alien> swap ] dip rep-size memcpy ;
"compiler.cfg.intrinsics.simd" require

10
basis/nibble-arrays/nibble-arrays.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sequences.private byte-arrays
alien prettyprint.custom parser accessors ;
alien prettyprint.custom parser accessors locals ;
IN: nibble-arrays
TUPLE: nibble-array
@ -20,8 +20,10 @@ CONSTANT: nibble BIN: 1111
: get-nibble ( n byte -- nibble )
swap neg shift nibble bitand ; inline
: set-nibble ( value n byte -- byte' )
nibble pick shift bitnot bitand -rot shift bitor ; inline
:: set-nibble ( value n byte -- byte' )
byte nibble n shift bitnot bitand
value n shift
bitor ; inline
: nibble@ ( n nibble-array -- shift n' byte-array )
[ >fixnum byte/nibble ] [ underlying>> ] bi* ; inline

22
basis/sequences/unrolled/unrolled-docs.factor
View File

@ -5,70 +5,70 @@ IN: sequences.unrolled
HELP: unrolled-collect
{ $values
{ "n" integer } { "quot" { $quotation "( ... n -- ... value )" } } { "into" sequence }
{ "n" integer } { "quot" { $quotation "( n -- value )" } } { "into" sequence }
}
{ $description "Unrolled version of " { $link collect } ". " { $snippet "n" } " must be a compile-time constant." } ;
HELP: unrolled-each
{ $values
{ "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... )" } }
{ "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- )" } }
}
{ $description "Unrolled version of " { $link each } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
HELP: unrolled-2each
{ $values
{ "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... )" } }
{ "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- )" } }
}
{ $description "Unrolled version of " { $link 2each } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
HELP: unrolled-each-index
{ $values
{ "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x i -- ... )" } }
{ "seq" sequence } { "len" integer } { "quot" { $quotation "( x i -- )" } }
}
{ $description "Unrolled version of " { $link each-index } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
HELP: unrolled-each-integer
{ $values
{ "n" integer } { "quot" { $quotation "( ... i -- ... )" } }
{ "n" integer } { "quot" { $quotation "( i -- )" } }
}
{ $description "Unrolled version of " { $link each-integer } ". " { $snippet "n" } " must be a compile-time constant." } ;
HELP: unrolled-map
{ $values
{ "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... newx )" } }
{ "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- newx )" } }
{ "newseq" sequence }
}
{ $description "Unrolled version of " { $link map } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
HELP: unrolled-map-as
{ $values
{ "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x -- ... newx )" } } { "exemplar" sequence }
{ "seq" sequence } { "len" integer } { "quot" { $quotation "( x -- newx )" } } { "exemplar" sequence }
{ "newseq" sequence }
}
{ $description "Unrolled version of " { $link map-as } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
HELP: unrolled-2map
{ $values
{ "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... newx )" } } { "newseq" sequence }
{ "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- newx )" } } { "newseq" sequence }
}
{ $description "Unrolled version of " { $link 2map } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
HELP: unrolled-2map-as
{ $values
{ "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( ... x y -- ... newx )" } } { "exemplar" sequence } { "newseq" sequence }
{ "xseq" sequence } { "yseq" sequence } { "len" integer } { "quot" { $quotation "( x y -- newx )" } } { "exemplar" sequence } { "newseq" sequence }
}
{ $description "Unrolled version of " { $link 2map-as } " that iterates over the first " { $snippet "len" } " elements of " { $snippet "xseq" } " and " { $snippet "yseq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
HELP: unrolled-map-index
{ $values
{ "seq" sequence } { "len" integer } { "quot" { $quotation "( ... x i -- ... newx )" } }
{ "seq" sequence } { "len" integer } { "quot" { $quotation "( x i -- newx )" } }
{ "newseq" sequence }
}
{ $description "Unrolled version of " { $link map-index } " that maps over the first " { $snippet "len" } " elements of " { $snippet "seq" } ". " { $snippet "len" } " must be a compile-time constant. If " { $snippet "seq" } " has fewer than " { $snippet "len" } " elements, raises an " { $link unrolled-bounds-error } "." } ;
HELP: unrolled-map-integers
{ $values
{ "n" integer } { "quot" { $quotation "( ... n -- ... value )" } } { "exemplar" sequence } { "newseq" sequence }
{ "n" integer } { "quot" { $quotation "( n -- value )" } } { "exemplar" sequence } { "newseq" sequence }
}
{ $description "Unrolled version of " { $link map-integers } ". " { $snippet "n" } " must be a compile-time constant." } ;

32
basis/sequences/unrolled/unrolled-tests.factor
View File

@ -1,5 +1,5 @@
! (c)2010 Joe Groff bsd license
USING: compiler.test make math.parser sequences
USING: compiler.test compiler.tree.debugger kernel make math.parser sequences
sequences.unrolled tools.test ;
IN: sequences.unrolled.tests
@ -7,18 +7,46 @@ IN: sequences.unrolled.tests
[ { "0" "1" "2" } ] [ { 0 1 2 } [ 3 [ number>string ] unrolled-map ] compile-call ] unit-test
[ { "0" "1" "2" } ] [ [ { 0 1 2 } 3 [ number>string , ] unrolled-each ] { } make ] unit-test
[ { "0" "1" "2" } ] [ [ { 0 1 2 } [ 3 [ number>string , ] unrolled-each ] compile-call ] { } make ] unit-test
[ { "a0" "b1" "c2" } ]
[ [ { "a" "b" "c" } 3 [ number>string append , ] unrolled-each-index ] { } make ] unit-test
[ { "a0" "b1" "c2" } ]
[ [ { "a" "b" "c" } [ 3 [ number>string append , ] unrolled-each-index ] compile-call ] { } make ] unit-test
[ { "aI" "bII" "cIII" } ]
[ [ { "a" "b" "c" } { "I" "II" "III" } 3 [ append , ] unrolled-2each ] { } make ] unit-test
[ [ { "a" "b" "c" } { "I" "II" "III" } [ 3 [ append , ] unrolled-2each ] compile-call ] { } make ] unit-test
[ { "aI" "bII" "cIII" } ]
[ { "a" "b" "c" } { "I" "II" "III" } 3 [ append ] unrolled-2map ] unit-test
[ { "aI" "bII" "cIII" } ]
[ { "a" "b" "c" } { "I" "II" "III" } [ 3 [ append ] unrolled-2map ] compile-call ] unit-test
[ { "a0" "b1" "c2" } ]
[ { "a" "b" "c" } 3 [ number>string append ] unrolled-map-index ] unit-test
[ { "a0" "b1" "c2" } ]
[ { "a" "b" "c" } [ 3 [ number>string append ] unrolled-map-index ] compile-call ] unit-test
[ { 0 1 2 } 4 [ number>string ] unrolled-map ] [ unrolled-bounds-error? ] must-fail-with
[ { 0 1 2 3 } { 0 1 2 } 4 [ number>string append ] unrolled-2map ] [ unrolled-2bounds-error? ] must-fail-with
[ t ]
[ [ 3 [ number>string ] unrolled-map ] { call } inlined? ] unit-test
[ t ]
[ [ 3 [ number>string , ] unrolled-each ] { call } inlined? ] unit-test
[ t ]
[ [ 3 [ number>string append , ] unrolled-each-index ] { call } inlined? ] unit-test
[ t ]
[ [ 3 [ append , ] unrolled-2each ] { call } inlined? ] unit-test
[ t ]
[ [ 3 [ append ] unrolled-2map ] { call } inlined? ] unit-test
[ t ]
[ [ 3 [ number>string append ] unrolled-map-index ] { call } inlined? ] unit-test

62
basis/sequences/unrolled/unrolled.factor
View File

@ -1,21 +1,29 @@
! (c)2010 Joe Groff bsd license
USING: combinators.short-circuit fry generalizations kernel
locals macros math quotations sequences ;
FROM: sequences.private => (each) (each-index) (collect) (2each) ;
USING: combinators combinators.short-circuit fry generalizations kernel
locals macros math quotations sequences compiler.tree.propagation.transforms ;
FROM: sequences.private => (each) (each-index) (2each) nth-unsafe set-nth-unsafe ;
IN: sequences.unrolled
<PRIVATE
MACRO: (unrolled-each-integer) ( n -- )
[ iota >quotation ] keep '[ _ dip _ napply ] ;
: (unrolled-each-integer) ( quot n -- )
swap '[ _ call( i -- ) ] each-integer ;
<< \ (unrolled-each-integer) [
iota [ '[ _ swap call( i -- ) ] ] [ ] map-as '[ _ cleave ]
] 1 define-partial-eval >>
: (unrolled-collect) ( quot into -- quot' )
'[ dup @ swap _ set-nth-unsafe ] ; inline
PRIVATE>
: unrolled-each-integer ( ... n quot: ( ... i -- ... ) -- ... )
: unrolled-each-integer ( n quot: ( i -- ) -- )
swap (unrolled-each-integer) ; inline
: unrolled-collect ( ... n quot: ( ... n -- ... value ) into -- ... )
(collect) unrolled-each-integer ; inline
: unrolled-collect ( n quot: ( n -- value ) into -- )
(unrolled-collect) unrolled-each-integer ; inline
: unrolled-map-integers ( ... n quot: ( ... n -- ... value ) exemplar -- ... newseq )
: unrolled-map-integers ( n quot: ( n -- value ) exemplar -- newseq )
[ over ] dip [ [ unrolled-collect ] keep ] new-like ; inline
ERROR: unrolled-bounds-error
@ -34,52 +42,58 @@ ERROR: unrolled-2bounds-error
[ xseq yseq len quot ] if ; inline
: (unrolled-each) ( seq len quot -- len quot )
swapd (each) nip ; inline
swapd '[ _ nth-unsafe @ ] ; inline
: (unrolled-each-index) ( seq len quot -- len quot )
swapd (each-index) nip ; inline
swapd '[ dup _ nth-unsafe swap @ ] ; inline
: (unrolled-2each) ( xseq yseq len quot -- len quot )
[ '[ _ ] 2dip ] dip (2each) nip ; inline
: unrolled-each-unsafe ( ... seq len quot: ( ... x -- ... ) -- ... )
: unrolled-each-unsafe ( seq len quot: ( x -- ) -- )
(unrolled-each) unrolled-each-integer ; inline
: unrolled-2each-unsafe ( ... xseq yseq len quot: ( ... x y -- ... ) -- ... )
: unrolled-2each-unsafe ( xseq yseq len quot: ( x y -- ) -- )
(unrolled-2each) unrolled-each-integer ; inline
: unrolled-each-index-unsafe ( ... seq len quot: ( ... x -- ... ) -- ... )
: unrolled-each-index-unsafe ( seq len quot: ( x -- ) -- )
(unrolled-each-index) unrolled-each-integer ; inline
: unrolled-map-as-unsafe ( ... seq len quot: ( ... x -- ... newx ) exemplar -- ... newseq )
: unrolled-map-as-unsafe ( seq len quot: ( x -- newx ) exemplar -- newseq )
[ (unrolled-each) ] dip unrolled-map-integers ; inline
: unrolled-2map-as-unsafe ( ... xseq yseq len quot: ( ... x y -- ... newx ) exemplar -- ... newseq )
: unrolled-2map-as-unsafe ( xseq yseq len quot: ( x y -- newx ) exemplar -- newseq )
[ (unrolled-2each) ] dip unrolled-map-integers ; inline
: unrolled-map-unsafe ( seq len quot: ( x -- newx ) -- newseq )
pick unrolled-map-as-unsafe ; inline
: unrolled-2map-unsafe ( xseq yseq len quot: ( x y -- newx ) -- newseq )
4 npick unrolled-2map-as-unsafe ; inline
PRIVATE>
: unrolled-each ( ... seq len quot: ( ... x -- ... ) -- ... )
: unrolled-each ( seq len quot: ( x -- ) -- )
unrolled-bounds-check unrolled-each-unsafe ; inline
: unrolled-2each ( ... xseq yseq len quot: ( ... x y -- ... ) -- ... )
: unrolled-2each ( xseq yseq len quot: ( x y -- ) -- )
unrolled-2bounds-check unrolled-2each-unsafe ; inline
: unrolled-each-index ( ... seq len quot: ( ... x i -- ... ) -- ... )
: unrolled-each-index ( seq len quot: ( x i -- ) -- )
unrolled-bounds-check unrolled-each-index-unsafe ; inline
: unrolled-map-as ( ... seq len quot: ( ... x -- ... newx ) exemplar -- ... newseq )
: unrolled-map-as ( seq len quot: ( x -- newx ) exemplar -- newseq )
[ unrolled-bounds-check ] dip unrolled-map-as-unsafe ; inline
: unrolled-2map-as ( ... xseq yseq len quot: ( ... x y -- ... newx ) exemplar -- ... newseq )
: unrolled-2map-as ( xseq yseq len quot: ( x y -- newx ) exemplar -- newseq )
[ unrolled-2bounds-check ] dip unrolled-2map-as-unsafe ; inline
: unrolled-map ( ... seq len quot: ( ... x -- ... newx ) -- ... newseq )
: unrolled-map ( seq len quot: ( x -- newx ) -- newseq )
pick unrolled-map-as ; inline
: unrolled-2map ( ... xseq yseq len quot: ( ... x y -- ... newx ) -- ... newseq )
: unrolled-2map ( xseq yseq len quot: ( x y -- newx ) -- newseq )
4 npick unrolled-2map-as ; inline
: unrolled-map-index ( ... seq len quot: ( ... x i -- ... newx ) -- ... newseq )
: unrolled-map-index ( seq len quot: ( x i -- newx ) -- newseq )
[ dup length iota ] 2dip unrolled-2map ; inline

8
basis/tools/deploy/macosx/macosx.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.files io.files.info.unix io.pathnames
io.directories io.directories.hierarchy kernel namespaces make
@ -10,7 +10,10 @@ combinators vocabs.metadata vocabs.loader ;
IN: tools.deploy.macosx
: bundle-dir ( -- dir )
vm parent-directory parent-directory ;
running.app?
[ vm parent-directory parent-directory ]
[ "resource:Factor.app" ]
if ;
: copy-bundle-dir ( bundle-name dir -- )
[ bundle-dir prepend-path swap ] keep
@ -70,7 +73,6 @@ IN: tools.deploy.macosx
-> selectFile:inFileViewerRootedAtPath: drop ;
M: macosx deploy* ( vocab -- )
".app deploy tool" assert.app
"resource:" [
dup deploy-config [
bundle-name dup exists? [ delete-tree ] [ drop ] if

15
basis/tools/errors/model/model.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: models source-files.errors namespaces models.delay init
kernel calendar ;
@ -6,13 +6,14 @@ IN: tools.errors.model
SYMBOLS: (error-list-model) error-list-model ;
(error-list-model) [ f <model> ] initialize
error-list-model [ (error-list-model) get-global 100 milliseconds <delay> ] initialize
SINGLETON: updater
M: updater errors-changed drop f (error-list-model) get-global set-model ;
M: updater errors-changed
drop f (error-list-model) get-global set-model ;
[ updater add-error-observer ] "ui.tools.error-list" add-startup-hook
[
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

2
basis/ui/backend/cocoa/cocoa.factor
View File

@ -252,7 +252,7 @@ M: cocoa-ui-backend (with-ui)
init-clipboard
cocoa-startup-hook get call( -- )
start-ui
f io-thread-running? set-global
stop-io-thread
init-thread-timer
reset-run-loop
NSApp -> run

15
basis/ui/backend/windows/windows.factor
View File

@ -248,7 +248,7 @@ CONSTANT: window-control>ex-style
{ minimize-button 0 }
{ maximize-button 0 }
{ resize-handles $ WS_EX_WINDOWEDGE }
{ small-title-bar $ WS_EX_TOOLWINDOW }
{ small-title-bar $[ WS_EX_TOOLWINDOW WS_EX_TOPMOST bitor ] }
{ normal-title-bar $ WS_EX_APPWINDOW }
}
@ -832,24 +832,25 @@ CONSTANT: fullscreen-flags flags{ WS_CAPTION WS_BORDER WS_THICKFRAME }
} cleave ;
: exit-fullscreen ( world -- )
dup handle>> hWnd>>
[ handle>> hWnd>> ] [ world>style ] bi
{
[ GWL_STYLE rot world>style SetWindowLong win32-error=0/f ]
[ [ GWL_STYLE ] dip SetWindowLong win32-error=0/f ]
[
drop
f
over hwnd>RECT get-RECT-dimensions
flags{ SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED }
SetWindowPos win32-error=0/f
]
[ SW_RESTORE ShowWindow win32-error=0/f ]
} cleave ;
[ drop SW_RESTORE ShowWindow win32-error=0/f ]
} 2cleave ;
M: windows-ui-backend (set-fullscreen) ( ? world -- )
[ enter-fullscreen ] [ exit-fullscreen ] if ;
M: windows-ui-backend (fullscreen?) ( world -- ? )
[ handle>> hWnd>> hwnd>RECT ]
[ handle>> hWnd>> fullscreen-RECT ] bi
handle>> hWnd>>
[ hwnd>RECT ] [ fullscreen-RECT ] bi
[ get-RECT-dimensions 2array 2nip ] bi@ = ;
windows-ui-backend ui-backend set-global

123
basis/ui/backend/x11/x11.factor
View File

@ -1,20 +1,52 @@
! Copyright (C) 2005, 2010 Eduardo Cavazos and Slava Pestov
! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data ascii assocs classes.struct
combinators combinators.short-circuit command-line environment
io.encodings.ascii io.encodings.string io.encodings.utf8 kernel
literals locals math namespaces sequences specialized-arrays
strings ui ui.backend ui.clipboards ui.event-loop ui.gadgets
ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
ui.pixel-formats.private ui.private x11 x11.clipboard x11.constants
x11.events x11.glx x11.io x11.windows x11.xim x11.xlib ;
FROM: unix.ffi => system ;
SPECIALIZED-ARRAY: uchar
USING: accessors arrays alien.c-types alien.data alien.syntax ascii
assocs classes.struct combinators combinators.short-circuit
command-line environment io.encodings.ascii io.encodings.string
io.encodings.utf8 kernel literals locals math namespaces
sequences specialized-arrays strings ui ui.backend ui.clipboards
ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
ui.gestures ui.pixel-formats ui.pixel-formats.private ui.private
x11 x11.clipboard x11.constants x11.events x11.glx x11.io
x11.windows x11.xim x11.xlib ;
FROM: libc => system ;
SPECIALIZED-ARRAYS: uchar ulong ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
: XA_NET_SUPPORTED ( -- atom ) "_NET_SUPPORTED" x-atom ;
: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
: XA_NET_WM_STATE ( -- atom ) "_NET_WM_STATE" x-atom ;
: XA_NET_WM_STATE_FULLSCREEN ( -- atom ) "_NET_WM_STATE_FULLSCREEN" x-atom ;
: XA_NET_ACTIVE_WINDOW ( -- atom ) "_NET_ACTIVE_WINDOW" x-atom ;
: supported-net-wm-hints ( -- seq )
{ Atom int ulong ulong pointer: Atom }
[| type format n-atoms bytes-after atoms |
dpy get
root get
XA_NET_SUPPORTED
0
ulong c-type-interval nip
0
XA_ATOM
type
format
n-atoms
bytes-after
atoms
XGetWindowProperty
Success assert=
]
[| type format n-atoms bytes-after atoms |
atoms n-atoms <direct-ulong-array> >array
atoms XFree
]
with-out-parameters ;
: net-wm-hint-supported? ( atom -- ? )
supported-net-wm-hints member? ;
TUPLE: x11-handle-base glx ;
TUPLE: x11-handle < x11-handle-base window xic ;
@ -30,7 +62,7 @@ M: world configure-event
! In case dimensions didn't change
relayout-1 ;
PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_RGBA } H{
{ double-buffered { $ GLX_DOUBLEBUFFER } }
{ stereo { $ GLX_STEREO } }
{ color-bits { $ GLX_BUFFER_SIZE } }
@ -172,8 +204,7 @@ M: world selection-notify-event
user-input ;
: supported-type? ( atom -- ? )
{ "UTF8_STRING" "STRING" "TEXT" }
[ x-atom = ] with any? ;
XA_UTF8_STRING XA_STRING XA_TEXT 3array member? ;
: clipboard-for-atom ( atom -- clipboard )
{
@ -196,8 +227,8 @@ M: world selection-notify-event
M: world selection-request-event
drop dup target>> {
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
{ [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
{ [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
{ [ dup XA_TARGETS = ] [ drop dup set-targets-prop send-notify-success ] }
{ [ dup XA_TIMESTAMP = ] [ drop dup set-timestamp-prop send-notify-success ] }
[ drop send-notify-failure ]
} cond ;
@ -258,31 +289,57 @@ M: x11-ui-backend set-title ( string world -- )
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
: make-fullscreen-msg ( world ? -- msg )
: make-fullscreen-msg ( window ? -- msg )
XClientMessageEvent <struct>
ClientMessage >>type
dpy get >>display
"_NET_WM_STATE" x-atom >>message_type
swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
swap handle>> window>> >>window
32 >>format
"_NET_WM_STATE_FULLSCREEN" x-atom >>data1 ;
ClientMessage >>type
dpy get >>display
XA_NET_WM_STATE >>message_type
swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
swap >>window
32 >>format
XA_NET_WM_STATE_FULLSCREEN >>data1 ;
: send-event ( event -- )
[
dpy get
root get
0
SubstructureNotifyMask SubstructureRedirectMask bitor
] dip XSendEvent drop ;
M: x11-ui-backend (set-fullscreen) ( world ? -- )
[ dpy get root get 0 SubstructureNotifyMask ] 2dip
make-fullscreen-msg XSendEvent drop ;
[ handle>> window>> ] dip make-fullscreen-msg send-event ;
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
handle>> window>>
[ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
dup gadget-window handle>> window>>
[ set-closable ]
[ [ dpy get ] dip set-class ]
[ map-window ]
tri ;
: make-raise-window-msg ( window -- msg )
XClientMessageEvent <struct>
ClientMessage >>type
1 >>send_event
dpy get >>display
swap >>window
XA_NET_ACTIVE_WINDOW >>message_type
32 >>format ;
: raise-window-new ( window -- )
make-raise-window-msg send-event ;
: raise-window-old ( window -- )
[ dpy get ] dip
[ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
[ XRaiseWindow drop ]
2bi ;
M: x11-ui-backend raise-window* ( world -- )
handle>> [
dpy get swap window>>
[ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
[ XRaiseWindow drop ]
2bi
window>>
XA_NET_ACTIVE_WINDOW net-wm-hint-supported?
[ raise-window-new ] [ raise-window-old ] if
] when* ;
M: x11-handle select-gl-context ( handle -- )

18
basis/ui/gadgets/editors/editors.factor
View File

@ -60,14 +60,11 @@ SYMBOL: blink-interval
750 milliseconds blink-interval set-global
: stop-blinking ( editor -- )
[ [ stop-alarm ] when* f ] change-blink-alarm drop ;
blink-alarm>> [ stop-alarm ] when* ;
: start-blinking ( editor -- )
[ stop-blinking ] [
t >>blink
dup '[ _ blink-caret ] blink-interval get delayed-every
>>blink-alarm drop
] bi ;
t >>blink
blink-alarm>> [ restart-alarm ] when* ;
: restart-blinking ( editor -- )
dup focused?>> [
@ -80,10 +77,15 @@ PRIVATE>
M: editor graft*
[ dup caret>> activate-editor-model ]
[ dup mark>> activate-editor-model ] bi ;
[ dup mark>> activate-editor-model ]
[
[
'[ _ blink-caret ] blink-interval get dup <alarm>
] keep blink-alarm<<
] tri ;
M: editor ungraft*
[ stop-blinking ]
[ [ stop-blinking ] [ f >>blink-alarm drop ] bi ]
[ dup caret>> deactivate-editor-model ]
[ dup mark>> deactivate-editor-model ] tri ;

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

@ -20,7 +20,6 @@ CONSTANT: default-world-pixel-format-attributes
{
windowed
double-buffered
T{ depth-bits { value 16 } }
}
CONSTANT: default-world-window-controls

2
basis/ui/render/render.factor
View File

@ -35,6 +35,8 @@ SLOT: background-color
GL_BLEND glEnable
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
GL_VERTEX_ARRAY glEnableClientState
GL_PACK_ALIGNMENT 1 glPixelStorei
GL_UNPACK_ALIGNMENT 1 glPixelStorei
init-matrices
[ init-clip ]
[

1
basis/ui/tools/listener/listener.factor
View File

@ -195,6 +195,7 @@ TUPLE: listener-gadget < tool error-summary output scroller input ;
H{ { table-gap { 3 3 } } } [
[ [ [ icon>> write-image ] with-cell ] each ] with-row
] tabular-output
last-element off
{ "Press " { $command tool "common" show-error-list } " to view errors." }
print-element
] unless-empty ;

5
basis/ui/tools/tools.factor
View File

@ -5,10 +5,7 @@ ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list
ui.tools.walker ui.commands ui.gestures ui ui.private ;
IN: ui.tools
: main ( -- )
restore-windows? [ restore-windows ] [ listener-window ] if ;
MAIN: main
MAIN: listener-window
\ refresh-all H{ { +nullary+ t } { +listener+ t } } define-command

63
basis/ui/ui.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs 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: 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 ;
IN: ui
<PRIVATE
@ -82,12 +83,7 @@ M: world graft*
[ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
] bi ;
: reset-world ( world -- )
#! This is used when a window is being closed, but also
#! when restoring saved worlds on image startup.
f >>handle unfocus-world ;
: (ungraft-world) ( world -- )
M: world ungraft*
{
[ set-gl-context ]
[ text-handle>> [ dispose ] when* ]
@ -96,38 +92,21 @@ M: world graft*
[ hand-gadget close-global ]
[ end-world ]
[ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
[ [ (close-window) f ] change-handle drop ]
[ unfocus-world ]
} cleave ;
M: world ungraft*
[ (ungraft-world) ]
[ handle>> (close-window) ]
[ reset-world ] tri ;
: init-ui ( -- )
<box> drag-timer set-global
f hand-gadget set-global
f hand-clicked set-global
f hand-world set-global
f world set-global
<dlist> \ graft-queue set-global
<dlist> \ layout-queue set-global
<dlist> \ gesture-queue set-global
V{ } clone windows set-global ;
: restore-gadget-later ( gadget -- )
dup graft-state>> {
{ { f f } [ ] }
{ { f t } [ ] }
{ { t t } [ { f f } >>graft-state ] }
{ { t f } [ dup unqueue-graft { f f } >>graft-state ] }
} case graft-later ;
: restore-gadget ( gadget -- )
dup restore-gadget-later
children>> [ restore-gadget ] each ;
: restore-world ( world -- )
{
[ reset-world ]
[ f >>text-handle f >>images drop ]
[ restore-gadget ]
} cleave ;
: update-hand ( world -- )
dup hand-world get-global eq?
[ hand-loc get-global swap move-hand ] [ drop ] if ;
@ -188,16 +167,6 @@ PRIVATE>
: start-ui ( quot -- )
call( -- ) notify-ui-thread start-ui-thread ;
: restore-windows ( -- )
[
windows get [ values ] [ delete-all ] bi
[ restore-world ] each
forget-rollover
] (with-ui) ;
: restore-windows? ( -- ? )
windows get empty? not ;
: ?attributes ( gadget title/attributes -- attributes )
dup string? [ world-attributes new swap >>title ] [ clone ] if
swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;

1
basis/unix/ffi/ffi.factor
View File

@ -151,7 +151,6 @@ FUNCTION: int setuid ( uid_t uid ) ;
FUNCTION: int socket ( int domain, int type, int protocol ) ;
FUNCTION: int symlink ( c-string path1, c-string path2 ) ;
FUNCTION: int link ( c-string path1, c-string path2 ) ;
FUNCTION: int system ( c-string command ) ;
FUNCTION: int unlink ( c-string path ) ;
FUNCTION: int utimes ( c-string path, timeval[2] times ) ;
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;

117
basis/vocabs/refresh/monitor/monitor.factor
View File

@ -1,59 +1,58 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs command-line concurrency.messaging
continuations init io.backend io.files io.monitors io.pathnames
kernel namespaces sequences sets splitting threads
tr vocabs vocabs.loader vocabs.refresh vocabs.cache ;
IN: vocabs.refresh.monitor
TR: convert-separators "/\\" ".." ;
: vocab-dir>vocab-name ( path -- vocab )
trim-head-separators
trim-tail-separators
convert-separators ;
: path>vocab-name ( path -- vocab )
dup ".factor" tail? [ parent-directory ] when ;
: chop-vocab-root ( path -- path' )
"resource:" prepend-path normalize-path
dup vocab-roots get
[ normalize-path ] map
[ head? ] with find nip
?head drop ;
: path>vocab ( path -- vocab )
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
: monitor-loop ( -- )
#! On OS X, monitors give us the full path, so we chop it
#! off if its there.
receive path>> path>vocab changed-vocab
reset-cache
monitor-loop ;
: add-monitor-for-path ( path -- )
dup exists? [ t my-mailbox (monitor) ] when drop ;
: monitor-thread ( -- )
[
[
vocab-roots get [ add-monitor-for-path ] each
H{ } clone changed-vocabs set-global
vocabs [ changed-vocab ] each
monitor-loop
] with-monitors
] ignore-errors ;
: start-monitor-thread ( -- )
#! Silently ignore errors during monitor creation since
#! monitors are not supported on all platforms.
[ monitor-thread ] "Vocabulary monitor" spawn drop ;
[
"-no-monitors" (command-line) member?
[ start-monitor-thread ] unless
] "vocabs.refresh.monitor" add-startup-hook
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs command-line concurrency.messaging
continuations init io.backend io.files io.monitors io.pathnames
kernel namespaces sequences sets splitting threads fry
tr vocabs vocabs.loader vocabs.refresh vocabs.cache ;
IN: vocabs.refresh.monitor
TR: convert-separators "/\\" ".." ;
: vocab-dir>vocab-name ( path -- vocab )
trim-head-separators
trim-tail-separators
convert-separators ;
: path>vocab-name ( path -- vocab )
dup ".factor" tail? [ parent-directory ] when ;
: chop-vocab-root ( path -- path' )
"resource:" prepend-path normalize-path
dup vocab-roots get
[ normalize-path ] map
[ head? ] with find nip
?head drop ;
: path>vocab ( path -- vocab )
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
: monitor-loop ( monitor -- )
#! On OS X, monitors give us the full path, so we chop it
#! off if its there.
[ next-change path>> path>vocab changed-vocab reset-cache ]
[ monitor-loop ]
bi ;
: (start-vocab-monitor) ( vocab-root -- )
dup exists?
[ [ t <monitor> monitor-loop ] with-monitors ] [ drop ] if ;
: start-vocab-monitor ( vocab-root -- )
[ '[ [ _ (start-vocab-monitor) ] ignore-errors ] ]
[ "Root monitor: " prepend ]
bi spawn drop ;
: init-vocab-monitor ( -- )
H{ } clone changed-vocabs set-global
vocabs [ changed-vocab ] each ;
[
"-no-monitors" (command-line) member? [
[ drop ] add-vocab-root-hook set-global
f changed-vocabs set-global
] [
init-vocab-monitor
vocab-roots get [ start-vocab-monitor ] each
[ start-vocab-monitor ] add-vocab-root-hook set-global
] if
] "vocabs.refresh.monitor" add-startup-hook

14
basis/x11/clipboard/clipboard.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov
! Copyright (C) 2006, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings classes.struct
io.encodings.utf8 kernel namespaces sequences
@ -10,8 +10,10 @@ IN: x11.clipboard
! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp.
: XA_CLIPBOARD ( -- atom ) "CLIPBOARD" x-atom ;
: XA_UTF8_STRING ( -- atom ) "UTF8_STRING" x-atom ;
: XA_TARGETS ( -- atom ) "TARGETS" x-atom ;
: XA_TIMESTAMP ( -- atom ) "TIMESTAMP" x-atom ;
: XA_TEXT ( -- atom ) "TEXT" x-atom ;
TUPLE: x-clipboard atom contents ;
@ -43,16 +45,14 @@ TUPLE: x-clipboard atom contents ;
: set-targets-prop ( evt -- )
[ dpy get ] dip [ requestor>> ] [ property>> ] bi
"TARGETS" x-atom 32 PropModeReplace
{
"UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
} [ x-atom ] int-array{ } map-as
XA_TARGETS 32 PropModeReplace
XA_UTF8_STRING XA_STRING XA_TARGETS XA_TIMESTAMP int-array{ } 4sequence
4 XChangeProperty drop ;
: set-timestamp-prop ( evt -- )
[ dpy get ] dip
[ requestor>> ]
[ property>> "TIMESTAMP" x-atom 32 PropModeReplace ]
[ property>> XA_TIMESTAMP 32 PropModeReplace ]
[ time>> <int> ] tri
1 XChangeProperty drop ;

17
basis/x11/events/events.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.struct combinators kernel
math.order namespaces x11 x11.xlib ;
USING: accessors arrays classes.struct combinators
combinators.short-circuit kernel math.order namespaces
x11 x11.xlib ;
IN: x11.events
GENERIC: expose-event ( event window -- )
@ -75,7 +76,11 @@ GENERIC: client-event ( event window -- )
: event-dim ( event -- dim )
[ width>> ] [ height>> ] bi 2array ;
: XA_WM_PROTOCOLS ( -- atom ) "WM_PROTOCOLS" x-atom ;
: XA_WM_DELETE_WINDOW ( -- atom ) "WM_DELETE_WINDOW" x-atom ;
: close-box? ( event -- ? )
[ message_type>> "WM_PROTOCOLS" x-atom = ]
[ data0>> "WM_DELETE_WINDOW" x-atom = ]
bi and ;
{
[ message_type>> XA_WM_PROTOCOLS = ]
[ data0>> XA_WM_DELETE_WINDOW = ]
} 1&& ;

1
basis/x11/windows/platforms.txt
View File

@ -1 +0,0 @@
unix

9
basis/x11/windows/windows.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.bitwise math.vectors
namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
fry classes.struct literals ;
namespaces sequences arrays fry classes.struct literals
x11 x11.xlib x11.constants x11.events
x11.glx ;
IN: x11.windows
CONSTANT: create-window-mask
@ -78,7 +79,7 @@ CONSTANT: event-mask
dpy get swap XDestroyWindow drop ;
: set-closable ( win -- )
dpy get swap "WM_DELETE_WINDOW" x-atom <Atom> 1
dpy get swap XA_WM_DELETE_WINDOW <Atom> 1
XSetWMProtocols drop ;
: map-window ( win -- ) dpy get swap XMapWindow drop ;

23
basis/xmode/catalog/catalog.factor
View File

@ -1,7 +1,8 @@
USING: xmode.loader xmode.utilities xmode.rules namespaces
strings splitting assocs sequences kernel io.files xml memoize
words globs combinators io.encodings.utf8 sorting accessors xml.data
xml.traversal xml.syntax ;
words globs combinators io.encodings.utf8 io.pathnames sorting
accessors regexp unicode.case xml.data xml.traversal
xml.syntax ;
IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ;
@ -15,6 +16,8 @@ TAG: MODE parse-mode-tag
{ "FILE_NAME_GLOB" f file-name-glob<< }
{ "FIRST_LINE_GLOB" f first-line-glob<< }
} init-from-tag
[ [ >case-fold <glob> ] [ f ] if* ] change-file-name-glob
[ [ >case-fold <glob> ] [ f ] if* ] change-first-line-glob
] dip
rot set-at ;
@ -106,14 +109,18 @@ ERROR: mutually-recursive-rulesets ruleset ;
: reset-modes ( -- )
\ (load-mode) reset-memoized ;
: ?glob-matches ( string glob/f -- ? )
dup [ glob-matches? ] [ 2drop f ] if ;
: ?matches ( string glob/f -- ? )
[ >case-fold ] dip dup [ matches? ] [ 2drop f ] if ;
: suitable-mode? ( file-name first-line mode -- ? )
[ nip ] 2keep first-line-glob>> ?glob-matches
[ 2drop t ] [ file-name-glob>> ?glob-matches ] if ;
[ nip ] 2keep first-line-glob>> ?matches
[ 2drop t ] [ file-name-glob>> ?matches ] if ;
: find-mode ( file-name first-line -- mode )
: ?find-mode ( file-name first-line -- mode/f )
[ file-name ] dip
modes
[ nip [ 2dup ] dip suitable-mode? ] assoc-find
2drop [ 2drop ] dip [ "text" ] unless* ;
2drop [ 2drop ] dip ;
: find-mode ( file-name first-line -- mode )
?find-mode "text" or ; inline

87
build-support/factor.cmd Normal file
View File

@ -0,0 +1,87 @@
@echo off
setlocal
if "%1"=="/?" (
goto usage
) else if "%1"=="" (
set _bootimage_version=latest
) else if "%1"=="latest" (
set _bootimage_version=latest
) else if "%1"=="clean" (
set _bootimage_version=clean
) else goto usage
if not exist Nmakefile goto wrongdir
call cl 2>&1 | find "x86" >nul
if not errorlevel 1 (
echo x86-32 cl.exe detected.
set _target=x86-32
set _bootimage=boot.winnt-x86.32.image
) else (
call cl 2>&1 | find "x64" >nul
if not errorlevel 1 (
echo x86-64 cl.exe detected.
set _target=x86-64
set _bootimage=boot.winnt-x86.64.image
) else goto nocl
)
if %_bootimage_version%==clean (
set _git_branch=clean-winnt-%_target%
set _bootimage_path=clean/winnt-%_target%
) else (
set _git_branch=master
set _bootimage_path=latest
)
echo Updating working copy from %_git_branch%...
call git pull http://factorcode.org/git/factor.git %_git_branch%
if errorlevel 1 goto fail
echo Building vm...
nmake /nologo /f Nmakefile clean
if errorlevel 1 goto fail
nmake /nologo /f Nmakefile %_target%
if errorlevel 1 goto fail
echo Fetching %_bootimage_version% boot image...
cscript /nologo build-support\http-get.vbs http://factorcode.org/images/%_bootimage_path%/%_bootimage% %_bootimage%
if errorlevel 1 goto fail
echo Bootstrapping...
.\factor.com -i=%_bootimage%
if errorlevel 1 goto fail
echo Copying fresh factor.image to factor.image.fresh.
copy factor.image factor.image.fresh
if errorlevel 1 goto fail
echo Build complete.
goto :EOF
:fail
echo Build failed.
goto :EOF
:wrongdir
echo build-support\factor.cmd must be run from the root of the Factor source tree.
goto :EOF
:nocl
echo Unable to detect cl.exe target platform.
echo Make sure you're running within the Visual Studio or Windows SDK environment.
goto :EOF
:usage
echo Usage: build-support\factor.cmd [latest/clean]
echo Updates the working copy, cleans and builds the vm using nmake,
echo fetches a boot image, and bootstraps factor.
echo If latest is specified, then the working copy is updated to the
echo upstream "master" branch and the boot image corresponding to the
echo most recent factor build is downloaded. This is the default.
echo If clean is specified, then the working copy is updated to the
echo upstream "clean-winnt-*" branch corresponding to the current
echo platform and the corresponding boot image is downloaded.
goto :EOF

41
build-support/http-get.vbs Normal file
View File

@ -0,0 +1,41 @@
on error resume next
if WScript.Arguments.Count < 2 then
WScript.Echo "usage: http-get.vbs source-url dest-file"
WScript.Quit 1
else
source_url = WScript.Arguments.Item(0)
dest_filename = WScript.Arguments.Item(1)
dim http, source_data
set http = CreateObject("WinHttp.WinHttpRequest.5.1")
Err.Clear
http.Open "GET", source_url, false
http.Send
if Err.Number = 0 then
if http.Status = 200 then
dim dest_stream
set dest_stream = CreateObject("ADODB.Stream")
Err.Clear
dest_stream.Type = 1 ' adTypeBinary
dest_stream.Open
dest_stream.Write http.ResponseBody
dest_stream.SaveToFile dest_filename, 2 ' adSaveCreateOverWrite
if Err.Number <> 0 then
WScript.Echo "Error " + CStr(Err.Number) + " when writing " + dest_filename + ":"
WScript.Echo Err.Description
WScript.Quit 1
end if
else
WScript.Echo CStr(http.Status) + " " + http.StatusText + " when fetching " + source_url
WScript.Quit 1
end if
else
WScript.Echo "Error " + CStr(Err.Number) + " when fetching " + source_url + ":"
WScript.Echo Err.Description
WScript.Quit 1
end if
end if

4
core/combinators/combinators-docs.factor
View File

@ -65,9 +65,9 @@ ARTICLE: "apply-combinators" "Apply combinators"
"All of the apply combinators are equivalent to using the corresponding " { $link "spread-combinators" } " with the same quotation supplied for every value." ;
ARTICLE: "dip-keep-combinators" "Preserving combinators"
"Sometimes it is necessary to temporarily hide values on the datastack. The " { $snippet "dip" } " combinators invoke the quotation at the top of the stack, hiding some number of values underneath:"
"Sometimes it is necessary to temporarily hide values on the datastack. The " { $snippet "dip" } " combinators invoke the quotation at the top of the stack, hiding some number of values:"
{ $subsections dip 2dip 3dip 4dip }
"The " { $snippet "keep" } " combinators invoke a quotation and restore some number of values to the top of the stack when it completes:"
"The " { $snippet "keep" } " combinators invoke a quotation and restore some number of values to the top of the stack:"
{ $subsections keep 2keep 3keep } ;
ARTICLE: "curried-dataflow" "Curried dataflow combinators"

2
core/sets/sets-docs.factor
View File

@ -15,7 +15,7 @@ ABOUT: "sets"
ARTICLE: "set-operations" "Operations on sets"
"To test if an object is a member of a set:"
{ $subsections member? }
{ $subsections in? }
"All sets can be represented as a sequence, without duplicates, of their members:"
{ $subsections members }
"Sets can have members added or removed destructively:"

21
core/vocabs/loader/loader.factor
View File

@ -8,15 +8,22 @@ IN: vocabs.loader
SYMBOL: vocab-roots
V{
"resource:core"
"resource:basis"
"resource:extra"
"resource:work"
} clone vocab-roots set-global
SYMBOL: add-vocab-root-hook
[
V{
"resource:core"
"resource:basis"
"resource:extra"
"resource:work"
} clone vocab-roots set-global
[ drop ] add-vocab-root-hook set-global
] "vocabs.loader" add-startup-hook
: add-vocab-root ( root -- )
vocab-roots get adjoin ;
[ vocab-roots get adjoin ]
[ add-vocab-root-hook get-global call( root -- ) ] bi ;
SYMBOL: root-cache

20
extra/benchmark/binary-trees/binary-trees.factor
View File

@ -1,5 +1,7 @@
USING: kernel math accessors prettyprint io locals sequences
math.ranges math.order ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.ranges math.order math.parser
io locals sequences ;
IN: benchmark.binary-trees
TUPLE: tree-node item left right ;
@ -27,8 +29,8 @@ CONSTANT: min-depth 4
: stretch-tree ( max-depth -- )
1 + 0 over bottom-up-tree item-check
[ "stretch tree of depth " write pprint ]
[ "\t check: " write . ] bi* ; inline
[ "stretch tree of depth " write number>string write ]
[ "\t check: " write number>string print ] bi* ; inline
:: long-lived-tree ( max-depth -- )
0 max-depth bottom-up-tree
@ -40,13 +42,13 @@ CONSTANT: min-depth 4
[ depth bottom-up-tree item-check + ] bi@
] reduce
]
[ 2 * ] bi
pprint "\t trees of depth " write depth pprint
"\t check: " write .
[ 2 * number>string write ] bi
"\t trees of depth " write depth number>string write
"\t check: " write number>string print
] each
"long lived tree of depth " write max-depth pprint
"\t check: " write item-check . ; inline
"long lived tree of depth " write max-depth number>string write
"\t check: " write item-check number>string print ; inline
: binary-trees ( n -- )
min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ; inline

15
extra/benchmark/binary-trees/deploy.factor Normal file
View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-ui? f }
{ deploy-word-defs? f }
{ deploy-threads? t }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
{ deploy-console? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-name "benchmark.binary-trees" }
}

15
extra/benchmark/fasta/deploy.factor Normal file
View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-name "benchmark.fasta" }
{ deploy-ui? f }
{ deploy-c-types? f }
{ deploy-console? t }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
{ deploy-io 3 }
{ deploy-reflection 1 }
{ deploy-word-props? f }
{ deploy-math? t }
{ deploy-threads? t }
{ deploy-word-defs? f }
}

15
extra/benchmark/knucleotide/deploy.factor Normal file
View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-ui? f }
{ deploy-word-defs? f }
{ deploy-threads? t }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
{ deploy-console? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-name "benchmark.knucleotide" }
}

15004
extra/benchmark/knucleotide/knucleotide-input.txt
View File

File diff suppressed because it is too large Load Diff

10
extra/benchmark/knucleotide/knucleotide.factor
View File

@ -1,9 +1,13 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ascii kernel io io.files splitting strings
io.encodings.ascii hashtables sequences assocs math
math.statistics namespaces prettyprint math.parser combinators
arrays sorting formatting grouping fry ;
math.statistics namespaces math.parser combinators arrays
sorting formatting grouping fry ;
IN: benchmark.knucleotide
CONSTANT: knucleotide-in "vocab:benchmark/knucleotide/knucleotide-input.txt"
: discard-lines ( -- )
readln
[ ">THREE" head? [ discard-lines ] unless ] when* ;
@ -34,7 +38,7 @@ IN: benchmark.knucleotide
tri ;
: knucleotide ( -- )
"resource:extra/benchmark/knucleotide/knucleotide-input.txt"
knucleotide-in
ascii [ read-input ] with-file-reader
process-input ;

15
extra/benchmark/nbody-simd/deploy.factor Normal file
View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-ui? f }
{ deploy-word-defs? f }
{ deploy-threads? t }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
{ deploy-console? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-name "benchmark.nbody-simd" }
}

10
extra/benchmark/nbody-simd/nbody-simd.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types fry kernel locals math
math.constants math.functions math.vectors math.vectors.simd
math.vectors.simd.cords prettyprint combinators.smart sequences
hints classes.struct specialized-arrays ;
math.vectors.simd.cords math.parser combinators.smart sequences
hints classes.struct specialized-arrays io ;
IN: benchmark.nbody-simd
: solar-mass ( -- x ) 4 pi sq * ; inline
@ -94,7 +94,9 @@ SPECIALIZED-ARRAY: body
: nbody ( n -- )
>fixnum
<nbody-system>
[ energy . ] [ '[ _ 0.01 advance ] times ] [ energy . ] tri ;
[ energy number>string print ]
[ '[ _ 0.01 advance ] times ]
[ energy number>string print ] tri ;
: nbody-main ( -- ) 1000000 nbody ;

17
extra/benchmark/regex-dna/deploy.factor
View File

@ -1,14 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-math? f }
{ deploy-ui? f }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
{ deploy-word-defs? f }
{ deploy-threads? t }
{ deploy-math? t }
{ deploy-io 3 }
{ deploy-reflection 1 }
{ deploy-name "benchmark.regex-dna" }
{ deploy-io 2 }
{ deploy-threads? f }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
{ deploy-console? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-name "benchmark.regex-dna" }
}

4
extra/benchmark/regex-dna/regex-dna.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io io.encodings.ascii io.files kernel sequences
assocs math.parser namespaces regexp ;
assocs math.parser namespaces regexp benchmark.knucleotide ;
IN: benchmark.regex-dna
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=regexdna&lang=ruby&id=1
@ -55,6 +55,6 @@ SYMBOL: clen
length number>string print ;
: regex-dna-main ( -- )
"resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" regex-dna ;
knucleotide-in regex-dna ;
MAIN: regex-dna-main

15
extra/benchmark/reverse-complement/deploy.factor Normal file
View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-ui? f }
{ deploy-word-defs? f }
{ deploy-threads? t }
{ deploy-math? t }
{ deploy-io 3 }
{ deploy-reflection 1 }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
{ deploy-console? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-name "benchmark.reverse-complement" }
}

1
extra/benchmark/spectral-norm-simd/authors.txt Normal file
View File

@ -0,0 +1 @@
Marc Fauconneau

68
extra/benchmark/spectral-norm-simd/spectral-norm-simd.factor Normal file
View File

@ -0,0 +1,68 @@
! Copyright (C) 2010 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types specialized-arrays kernel math
math.functions math.vectors sequences sequences.private
prettyprint words typed locals math.vectors.simd
math.vectors.simd.cords ;
SPECIALIZED-ARRAYS: double double-4 ;
IN: benchmark.spectral-norm-simd
:: inner-loop ( u n quot -- seq )
n 4 /i iota [| i |
n iota [| j | u i j quot call ] [ v+ ] map-reduce
] double-4-array{ } map-as ; inline
: eval-A ( i j -- n )
[ >float ] bi@
[ drop ] [ + [ ] [ 1 + ] bi * 0.5 * ] 2bi
+ 1 + ; inline
: vrecip ( u -- v ) double-4{ 1.0 1.0 1.0 1.0 } swap v/ ; inline
:: eval4-A ( i j -- n )
i 4 * 0 + j eval-A
i 4 * 1 + j eval-A
i 4 * 2 + j eval-A
i 4 * 3 + j eval-A
double-4-boa vrecip ; inline
: (eval-A-times-u) ( u i j -- x )
[ swap nth-unsafe ] [ eval4-A ] bi-curry bi* n*v ; inline
: eval-A-times-u ( n u -- seq )
[ (eval-A-times-u) ] inner-loop ; inline
:: eval4-A' ( i j -- n )
j i 4 * 0 + eval-A
j i 4 * 1 + eval-A
j i 4 * 2 + eval-A
j i 4 * 3 + eval-A
double-4-boa vrecip ; inline
: (eval-At-times-u) ( u i j -- x )
[ swap nth-unsafe ] [ eval4-A' ] bi-curry bi* n*v ; inline
: eval-At-times-u ( u n -- seq )
[ double-array-cast ] dip [ (eval-At-times-u) ] inner-loop ; inline
: eval-AtA-times-u ( u n -- seq )
[ double-array-cast ] dip [ eval-A-times-u ] [ eval-At-times-u ] bi ; inline
: ones ( n -- seq )
4 /i [ double-4{ 1.0 1.0 1.0 1.0 } ] double-4-array{ } replicate-as ; inline
:: u/v ( n -- u v )
n ones dup
10 [
drop
n eval-AtA-times-u
[ n eval-AtA-times-u ] keep
] times ; inline
TYPED: spectral-norm ( n: fixnum -- norm )
u/v [ double-array-cast ] bi@ [ v. ] [ norm-sq ] bi /f sqrt ;
: spectral-norm-main ( -- )
2000 spectral-norm . ;
MAIN: spectral-norm-main

15
extra/benchmark/spectral-norm/deploy.factor Normal file
View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-ui? f }
{ deploy-word-defs? f }
{ deploy-threads? t }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
{ deploy-console? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-name "benchmark.spectral-norm" }
}

11
extra/benchmark/spectral-norm/spectral-norm.factor
View File

@ -1,8 +1,11 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
!
! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
USING: alien.c-types specialized-arrays kernel math
math.functions math.vectors sequences sequences.private
prettyprint words typed locals ;
USING: alien.c-types io kernel math math.functions math.parser
math.vectors sequences sequences.private specialized-arrays
typed locals ;
SPECIALIZED-ARRAY: double
IN: benchmark.spectral-norm
@ -47,6 +50,6 @@ TYPED: spectral-norm ( n: fixnum -- norm )
u/v [ v. ] [ norm-sq ] bi /f sqrt ;
: spectral-norm-main ( -- )
2000 spectral-norm . ;
2000 spectral-norm number>string print ;
MAIN: spectral-norm-main

9
extra/bson/bson-tests.factor
View File

@ -1,10 +1,10 @@
USING: bson.reader bson.writer byte-arrays io.encodings.binary
USING: bson.reader bson.writer bson.constants byte-arrays io.encodings.binary
io.streams.byte-array tools.test literals calendar kernel math ;
IN: bson.tests
: turnaround ( value -- value )
assoc>bv >byte-array binary [ H{ } stream>assoc ] with-byte-reader ;
assoc>bv >byte-array binary [ H{ } clone stream>assoc ] with-byte-reader ;
[ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
@ -17,6 +17,9 @@ IN: bson.tests
[ H{ { "a quotation" [ 1 2 + ] } } ]
[ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test
[ H{ { "ref" T{ dbref f "a" "b" "c" } } } ]
[ H{ { "ref" T{ dbref f "a" "b" "c" } } } turnaround ] unit-test
[ H{ { "a date" T{ timestamp { year 2009 }
{ month 7 }
{ day 11 }
@ -34,10 +37,12 @@ IN: bson.tests
] unit-test
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
{ "ref" T{ dbref f "a" "b" "c" } }
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } }
]
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
{ "ref" T{ dbref f "a" "b" "c" } }
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } } turnaround ] unit-test

2
extra/bson/bson.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2010 Sascha Matzke.
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs.loader ;
IN: bson

35
extra/bson/constants/constants.factor
View File

@ -1,5 +1,8 @@
USING: accessors constructors kernel strings uuid ;
! Copyright (C) 2010 Sascha Matzke.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs calendar combinators
combinators.short-circuit constructors kernel linked-assocs
math math.bitwise random strings uuid ;
IN: bson.constants
: <objid> ( -- objid )
@ -7,9 +10,33 @@ IN: bson.constants
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
TUPLE: objref ns objid ;
: <oid> ( -- oid )
oid new
now timestamp>micros >>a
8 random-bits 16 shift HEX: FF0000 mask
16 random-bits HEX: FFFF mask
bitor >>b ;
CONSTRUCTOR: objref ( ns objid -- objref ) ;
TUPLE: dbref ref id db ;
CONSTRUCTOR: dbref ( ref id -- dbref ) ;
: dbref>assoc ( dbref -- assoc )
[ <linked-hash> ] dip over
{
[ [ ref>> "$ref" ] [ set-at ] bi* ]
[ [ id>> "$id" ] [ set-at ] bi* ]
[ over db>> [
[ db>> "$db" ] [ set-at ] bi*
] [ 2drop ] if ]
} 2cleave ; inline
: assoc>dbref ( assoc -- dbref )
[ "$ref" swap at ] [ "$id" swap at ] [ "$db" swap at ] tri
dbref boa ; inline
: dbref-assoc? ( assoc -- ? )
{ [ "$ref" swap key? ] [ "$id" swap key? ] } 1&& ; inline
TUPLE: mdbregexp { regexp string } { options string } ;

274
extra/bson/reader/reader.factor
View File

@ -1,185 +1,161 @@
USING: accessors assocs bson.constants calendar fry io io.binary
io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
sequences serialize locals ;
! Copyright (C) 2010 Sascha Matzke.
! 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
namespaces sequences serialize strings vectors byte-arrays ;
FROM: kernel.private => declare ;
FROM: io.encodings.private => (read-until) ;
FROM: io.encodings.binary => binary ;
FROM: io.streams.byte-array => with-byte-reader ;
FROM: typed => TYPED: ;
IN: bson.reader
<PRIVATE
TUPLE: element { type integer } name ;
TUPLE: state
{ size initial: -1 } exemplar
result scope element ;
{ size initial: -1 }
{ exemplar assoc }
result
{ scope vector }
{ elements vector } ;
TYPED: (prepare-elements) ( -- elements-vector: vector )
V{ } clone [ T_Object "" element boa swap push ] [ ] bi ; inline
: <state> ( exemplar -- state )
[ state new ] dip
[ clone >>exemplar ] keep
clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
V{ } clone [ T_Object "" element boa swap push ] keep >>element ;
{
[ clone >>exemplar ]
[ clone >>result ]
[ V{ } clone [ push ] keep >>scope ]
} cleave
(prepare-elements) >>elements ;
PREDICATE: bson-not-eoo < integer T_EOO > ;
PREDICATE: bson-eoo < integer T_EOO = ;
PREDICATE: bson-string < integer T_String = ;
PREDICATE: bson-object < integer T_Object = ;
PREDICATE: bson-oid < integer T_OID = ;
PREDICATE: bson-array < integer T_Array = ;
PREDICATE: bson-integer < integer T_Integer = ;
PREDICATE: bson-double < integer T_Double = ;
PREDICATE: bson-date < integer T_Date = ;
PREDICATE: bson-binary < integer T_Binary = ;
PREDICATE: bson-boolean < integer T_Boolean = ;
PREDICATE: bson-regexp < integer T_Regexp = ;
PREDICATE: bson-null < integer T_NULL = ;
PREDICATE: bson-ref < integer T_DBRef = ;
PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ;
PREDICATE: bson-binary-function < integer T_Binary_Function = ;
PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
GENERIC: element-read ( type -- cont? )
GENERIC: element-data-read ( type -- object )
GENERIC: element-binary-read ( length type -- object )
: get-state ( -- state )
TYPED: get-state ( -- state: state )
state get ; inline
: read-int32 ( -- int32 )
TYPED: read-int32 ( -- int32: integer )
4 read signed-le> ; inline
: read-longlong ( -- longlong )
TYPED: read-longlong ( -- longlong: integer )
8 read signed-le> ; inline
: read-double ( -- double )
TYPED: read-double ( -- double: float )
8 read le> bits>double ; inline
: read-byte-raw ( -- byte-raw )
TYPED: read-byte-raw ( -- byte-raw: byte-array )
1 read ; inline
: read-byte ( -- byte )
TYPED: read-byte ( -- byte: integer )
read-byte-raw first ; inline
: read-cstring ( -- string )
"\0" read-until drop "" like ; inline
TYPED: read-cstring ( -- string: string )
"\0" read-until drop >string ; inline
: read-sized-string ( length -- string )
read 1 head-slice* "" like ; inline
TYPED: read-sized-string ( length: integer -- string: string )
read 1 head-slice* >string ; inline
: read-element-type ( -- type )
read-byte ; inline
TYPED: push-element ( type: integer name: string state: state -- )
[ element boa ] dip elements>> push ; inline
: push-element ( type name -- )
element boa get-state element>> push ; inline
TYPED: pop-element ( state: state -- element: element )
elements>> pop ; inline
: pop-element ( -- element )
get-state element>> pop ; inline
TYPED: peek-scope ( state: state -- ht )
scope>> last ; inline
: peek-scope ( -- ht )
get-state scope>> last ; inline
: bson-object-data-read ( -- object )
read-int32 drop get-state
[ exemplar>> clone dup ] [ scope>> ] bi push ; inline
: bson-binary-read ( -- binary )
read-int32 read-byte
{
{ T_Binary_Bytes [ read ] }
{ T_Binary_Custom [ read bytes>object ] }
{ T_Binary_Function [ read ] }
[ drop read >string ]
} case ; inline
TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp )
mdbregexp new
read-cstring >>regexp read-cstring >>options ; inline
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 )
{
{ 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
TYPED: (element-read) ( type: integer -- cont?: boolean )
dup T_EOO >
[ bson-not-eoo-element-read ]
[ drop bson-eoo-element-read ] if ; inline
: read-elements ( -- )
read-element-type
element-read
read-byte (element-read)
[ read-elements ] when ; inline recursive
GENERIC: fix-result ( assoc type -- result )
M: bson-object fix-result ( assoc type -- result )
drop ;
M: bson-array fix-result ( assoc type -- result )
drop values ;
GENERIC: end-element ( type -- )
M: bson-object end-element ( type -- )
drop ;
M: bson-array end-element ( type -- )
drop ;
M: object end-element ( type -- )
pop-element 2drop ;
M:: bson-eoo element-read ( type -- cont? )
pop-element :> element
get-state scope>>
[ pop element type>> fix-result ] [ empty? ] bi
[ [ get-state ] dip >>result drop f ]
[ element name>> peek-scope set-at t ] if ;
M:: bson-not-eoo element-read ( type -- cont? )
peek-scope :> scope
type read-cstring [ push-element ] 2keep
[ [ element-data-read ] [ end-element ] bi ]
[ scope set-at t ] bi* ;
: [scope-changer] ( state -- state quot )
dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
: (object-data-read) ( type -- object )
drop
read-int32 drop
get-state
[scope-changer] change-scope
scope>> last ; inline
M: bson-object element-data-read ( type -- object )
(object-data-read) ;
M: bson-string element-data-read ( type -- object )
drop
read-int32 read-sized-string ;
M: bson-array element-data-read ( type -- object )
(object-data-read) ;
M: bson-integer element-data-read ( type -- object )
drop
read-int32 ;
M: bson-double element-data-read ( type -- double )
drop
read-double ;
M: bson-boolean element-data-read ( type -- boolean )
drop
read-byte 1 = ;
M: bson-date element-data-read ( type -- timestamp )
drop
read-longlong millis>timestamp ;
M: bson-binary element-data-read ( type -- binary )
drop
read-int32 read-byte element-binary-read ;
M: bson-regexp element-data-read ( type -- mdbregexp )
drop mdbregexp new
read-cstring >>regexp read-cstring >>options ;
M: bson-null element-data-read ( type -- bf )
drop f ;
M: bson-oid element-data-read ( type -- oid )
drop
read-longlong
read-int32 oid boa ;
M: bson-binary-bytes element-binary-read ( size type -- bytes )
drop read ;
M: bson-binary-custom element-binary-read ( size type -- quot )
drop read bytes>object ;
PRIVATE>
USE: tools.continuations
: stream>assoc ( exemplar -- assoc )
<state> dup state
[ read-int32 >>size read-elements ] with-variable
result>> ;
<state> read-int32 >>size
[ state [ read-elements ] with-variable ]
[ result>> ] bi ;

2
extra/bson/summary.txt
View File

@ -1 +1 @@
BSON reader and writer
BSON (http://en.wikipedia.org/wiki/BSON) reader and writer

241
extra/bson/writer/writer.factor
View File

@ -1,155 +1,160 @@
! Copyright (C) 2008 Sascha Matzke.
! Copyright (C) 2010 Sascha Matzke.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs bson.constants byte-arrays byte-vectors
calendar fry io io.binary io.encodings io.encodings.binary
io.encodings.utf8 io.streams.byte-array kernel math math.parser
namespaces quotations sequences sequences.private serialize strings
words combinators.short-circuit literals ;
FROM: io.encodings.utf8.private => char>utf8 ;
FROM: kernel.private => declare ;
USING: accessors arrays assocs bson.constants byte-arrays
calendar combinators.short-circuit fry hashtables io io.binary
kernel linked-assocs literals math math.parser namespaces byte-vectors
quotations sequences serialize strings vectors dlists alien.accessors ;
FROM: words => word? word ;
FROM: typed => TYPED: ;
FROM: combinators => cond ;
IN: bson.writer
<PRIVATE
SYMBOL: shared-buffer
CONSTANT: INT32-SIZE { 0 1 2 3 }
CONSTANT: INT64-SIZE { 0 1 2 3 4 5 6 7 }
CONSTANT: CHAR-SIZE 1
CONSTANT: INT32-SIZE 4
CONSTANT: INT64-SIZE 8
: (buffer) ( -- buffer )
shared-buffer get
[ BV{ } clone [ shared-buffer set ] keep ] unless*
{ byte-vector } declare ; inline
PRIVATE>
: reset-buffer ( buffer -- )
0 >>length drop ; inline
TYPED: get-output ( -- stream: byte-vector )
output-stream get ; inline
: ensure-buffer ( -- )
(buffer) drop ; inline
: with-buffer ( ..a quot: ( ..a -- ..b ) -- ..b byte-vector )
[ (buffer) [ reset-buffer ] keep dup ] dip
with-output-stream* ; inline
: with-length ( ..a quot: ( ..a -- ..b ) -- ..b bytes-written start-index )
[ (buffer) [ length ] keep ] dip
TYPED: with-length ( quot -- bytes-written: integer start-index: integer )
[ get-output [ length ] [ ] bi ] dip
call length swap [ - ] keep ; inline
: (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b )
: (with-length-prefix) ( quot: ( .. -- .. ) length-quot: ( bytes-written -- length ) -- )
[ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
[ call ] dip (buffer) copy ; inline
[ call( written -- length ) get-output underlying>> ] dip set-alien-unsigned-4 ; inline
: with-length-prefix ( ..a quot: ( ..a -- ..b ) -- ..b )
[ INT32-SIZE >le ] (with-length-prefix) ; inline
: with-length-prefix ( quot: ( .. -- .. ) -- )
[ ] (with-length-prefix) ; inline
: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b )
[ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
: with-length-prefix-excl ( quot: ( .. -- .. ) -- )
[ 4 - ] (with-length-prefix) ; inline
: (>le) ( x n -- )
[ nth-byte write1 ] with each ; inline
<PRIVATE
GENERIC: bson-type? ( obj -- type )
GENERIC: bson-write ( obj -- )
TYPED: write-int32 ( int: integer -- ) INT32-SIZE (>le) ; inline
M: t bson-type? ( boolean -- type ) drop T_Boolean ;
M: f bson-type? ( boolean -- type ) drop T_Boolean ;
TYPED: write-double ( real: float -- ) double>bits INT64-SIZE (>le) ; inline
M: string bson-type? ( string -- type ) drop T_String ;
M: integer bson-type? ( integer -- type ) drop T_Integer ;
M: assoc bson-type? ( assoc -- type ) drop T_Object ;
M: real bson-type? ( real -- type ) drop T_Double ;
M: tuple bson-type? ( tuple -- type ) drop T_Object ;
M: sequence bson-type? ( seq -- type ) drop T_Array ;
M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
TYPED: write-cstring ( string: string -- )
get-output [ length ] [ ] bi copy 0 write1 ; inline
M: oid bson-type? ( word -- type ) drop T_OID ;
M: objref bson-type? ( objref -- type ) drop T_Binary ;
M: word bson-type? ( word -- type ) drop T_Binary ;
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
: write-int32 ( int -- ) INT32-SIZE >le write ; inline
: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
: write-cstring ( string -- ) B{ } like write 0 write1 ; inline
: write-longlong ( object -- ) INT64-SIZE >le write ; inline
: write-longlong ( object -- ) INT64-SIZE (>le) ; inline
: write-eoo ( -- ) T_EOO write1 ; inline
: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline
: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
M: string bson-write ( obj -- )
'[ _ write-cstring ] with-length-prefix-excl ;
TYPED: write-header ( name: string object type: integer -- object )
write1 [ write-cstring ] dip ; inline
M: f bson-write ( f -- )
drop 0 write1 ;
DEFER: write-pair
M: t bson-write ( t -- )
drop 1 write1 ;
TYPED: write-byte-array ( binary: byte-array -- )
[ length write-int32 ]
[ T_Binary_Bytes write1 write ] bi ; inline
M: integer bson-write ( num -- )
write-int32 ;
M: real bson-write ( num -- )
>float write-double ;
M: timestamp bson-write ( timestamp -- )
timestamp>millis write-longlong ;
M: byte-array bson-write ( binary -- )
[ length write-int32 ] keep
T_Binary_Bytes write1
write ;
M: oid bson-write ( oid -- )
[ a>> write-longlong ] [ b>> write-int32 ] bi ;
M: mdbregexp bson-write ( regexp -- )
TYPED: write-mdbregexp ( regexp: mdbregexp -- )
[ regexp>> write-cstring ]
[ options>> write-cstring ] bi ;
M: sequence bson-write ( array -- )
'[ _ [ [ write-type ] dip number>string
write-cstring bson-write ] each-index
write-eoo ] with-length-prefix ;
[ options>> write-cstring ] bi ; inline
: write-oid ( assoc -- )
[ MDB_OID_FIELD ] dip at
[ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline
: skip-field? ( name -- boolean )
{ $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
M: assoc bson-write ( assoc -- )
'[
_ [ write-oid ] keep
[ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
TYPED: write-sequence ( array: sequence -- )
'[
_ [ number>string swap write-pair ] each-index
write-eoo
] with-length-prefix ;
] with-length-prefix ; inline recursive
: (serialize-code) ( code -- )
object>bytes [ length write-int32 ] keep
T_Binary_Custom write1
write ;
TYPED: write-oid ( oid: oid -- )
[ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
M: quotation bson-write ( quotation -- )
(serialize-code) ;
M: word bson-write ( word -- )
(serialize-code) ;
: write-oid-field ( assoc -- )
[ MDB_OID_FIELD dup ] dip at
[ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ]
[ drop ] if* ; inline
: skip-field? ( name value -- name value boolean )
over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline
UNION: hashtables hashtable linked-assoc ;
TYPED: write-assoc ( assoc: hashtables -- )
'[ _ [ write-oid-field ] [
[ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
] bi write-eoo
] with-length-prefix ; inline recursive
UNION: code word quotation ;
TYPED: (serialize-code) ( code: code -- )
object>bytes
[ length write-int32 ]
[ T_Binary_Custom write1 write ] bi ; inline
TYPED: write-string ( string: string -- )
'[ _ write-cstring ] with-length-prefix-excl ; inline
TYPED: write-boolean ( bool: boolean -- )
[ 1 write1 ] [ 0 write1 ] if ; inline
TYPED: write-pair ( name: string obj -- )
{
{
[ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
[ T_Object write-header write-assoc ]
} {
[ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ]
[ T_Array write-header write-sequence ]
} {
[ dup byte-array? ]
[ T_Binary write-header write-byte-array ]
} {
[ dup string? ]
[ T_String write-header write-string ]
} {
[ dup oid? ]
[ T_OID write-header write-oid ]
} {
[ dup integer? ]
[ T_Integer write-header write-int32 ]
} {
[ dup boolean? ]
[ T_Boolean write-header write-boolean ]
} {
[ dup real? ]
[ T_Double write-header >float write-double ]
} {
[ dup timestamp? ]
[ T_Date write-header timestamp>millis write-longlong ]
} {
[ dup mdbregexp? ]
[ T_Regexp write-header write-mdbregexp ]
} {
[ dup quotation? ]
[ T_Binary write-header (serialize-code) ]
} {
[ dup word? ]
[ T_Binary write-header (serialize-code) ]
} {
[ dup dbref? ]
[ T_Object write-header dbref>assoc write-assoc ]
} {
[ dup f = ]
[ T_NULL write-header drop ]
}
} cond ;
PRIVATE>
: assoc>bv ( assoc -- byte-vector )
[ '[ _ bson-write ] with-buffer ] with-scope ; inline
TYPED: assoc>bv ( assoc: hashtables -- byte-vector: byte-vector )
[ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline
: assoc>stream ( assoc -- )
{ assoc } declare bson-write ; inline
TYPED: assoc>stream ( assoc: hashtables -- )
write-assoc ; inline
: mdb-special-value? ( value -- ? )
TYPED: mdb-special-value? ( value -- ?: boolean )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ]
[ oid? ] [ byte-array? ] } 1|| ; inline
[ oid? ] [ byte-array? ] } 1|| ; inline

19
extra/cuda/contexts/contexts.factor
View File

@ -1,8 +1,12 @@
! (c)2010 Joe Groff bsd license
USING: alien.c-types alien.data continuations cuda cuda.ffi
cuda.libraries fry kernel namespaces ;
cuda.libraries alien.destructors fry kernel namespaces ;
IN: cuda.contexts
: set-up-cuda-context ( -- )
H{ } clone cuda-modules set-global
H{ } clone cuda-functions set-global ; inline
: create-context ( device flags -- context )
swap
[ CUcontext <c-object> ] 2dip
@ -16,14 +20,15 @@ IN: cuda.contexts
: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
: (set-up-cuda-context) ( device flags create-quot -- )
H{ } clone cuda-modules set-global
H{ } clone cuda-functions set
call ; inline
: clean-up-context ( context -- )
[ sync-context ] ignore-errors destroy-context ; inline
DESTRUCTOR: destroy-context
DESTRUCTOR: clean-up-context
: (with-cuda-context) ( context quot -- )
swap '[ [ sync-context ] ignore-errors _ destroy-context ] [ ] cleanup ; inline
swap '[ _ clean-up-context ] [ ] cleanup ; inline
: with-cuda-context ( device flags quot -- )
[ [ create-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline
[ set-up-cuda-context create-context ] dip (with-cuda-context) ; inline

18
extra/cuda/gl/gl.factor
View File

@ -1,5 +1,5 @@
! (c)2010 Joe Groff bsd license
USING: accessors alien.c-types alien.data alien.destructors
USING: accessors alien alien.c-types alien.data alien.destructors
alien.enums continuations cuda cuda.contexts cuda.ffi
cuda.gl.ffi destructors fry gpu.buffers kernel ;
IN: cuda.gl
@ -10,7 +10,7 @@ IN: cuda.gl
[ cuGLCtxCreate cuda-error ] 3keep 2drop *void* ; inline
: with-gl-cuda-context ( device flags quot -- )
[ [ create-gl-cuda-context ] (set-up-cuda-context) ] dip (with-cuda-context) ; inline
[ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline
: gl-buffer>resource ( gl-buffer flags -- resource )
enum>number
@ -39,3 +39,17 @@ DESTRUCTOR: free-resource
: with-mapped-resource ( ..a resource quot: ( ..a device-ptr size -- ..b ) -- ..b )
over [ map-resource ] 2dip '[ _ unmap-resource ] [ ] cleanup ; inline
TUPLE: cuda-buffer
{ buffer buffer }
{ resource pinned-c-ptr } ;
: <cuda-buffer> ( upload usage kind size initial-data flags -- buffer )
[ <buffer> dup ] dip buffer>resource cuda-buffer boa ; inline
M: cuda-buffer dispose
[ [ free-resource ] when* f ] change-resource
buffer>> dispose ; inline
: with-mapped-cuda-buffer ( ..a cuda-buffer quot: ( ..a device-ptr size -- ..b ) -- ..b )
[ resource>> ] dip with-mapped-resource ; inline

0
extra/joystick-demo/authors.txt → extra/game/input/demos/joysticks/authors.txt
View File

0
extra/joystick-demo/deploy.factor → extra/game/input/demos/joysticks/deploy.factor
View File

2
extra/joystick-demo/joystick-demo.factor → extra/game/input/demos/joysticks/joysticks.factor
View File

@ -3,7 +3,7 @@ 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
combinators math.parser assocs threads ;
IN: joystick-demo
IN: game.input.demos.joysticks
CONSTANT: SIZE { 151 151 }
CONSTANT: INDICATOR-SIZE { 4 4 }

0
extra/joystick-demo/summary.txt → extra/game/input/demos/joysticks/summary.txt
View File

0
extra/joystick-demo/tags.txt → extra/game/input/demos/joysticks/tags.txt
View File

0
extra/key-caps/authors.txt → extra/game/input/demos/key-caps/authors.txt
View File

6
extra/key-caps/key-caps.factor → extra/game/input/demos/key-caps/key-caps.factor
View File

@ -1,8 +1,8 @@
USING: game.input game.input.scancodes
kernel ui.gadgets ui.gadgets.buttons sequences accessors
words arrays assocs math calendar fry alarms ui
ui.gadgets.borders ui.gestures ;
IN: key-caps
ui.gadgets.borders ui.gestures literals ;
IN: game.input.demos.key-caps
CONSTANT: key-locations H{
{ key-escape { { 0 0 } { 10 10 } } }
@ -132,7 +132,7 @@ CONSTANT: key-locations H{
}
CONSTANT: KEYBOARD-SIZE { 230 65 }
: FREQUENCY ( -- f ) 30 recip seconds ;
CONSTANT: FREQUENCY $[ 1/30 seconds ]
TUPLE: key-caps-gadget < gadget keys alarm ;

0
extra/key-caps/summary.txt → extra/game/input/demos/key-caps/summary.txt
View File

0
extra/key-caps/tags.txt → extra/game/input/demos/key-caps/tags.txt
View File

5
extra/gpu/buffers/buffers-docs.factor
View File

@ -149,6 +149,10 @@ HELP: dynamic-upload
HELP: gpu-data-ptr
{ $class-description "This class is a union of the " { $link c-ptr } " and " { $link buffer-ptr } " classes. It represents a value that can be supplied either from CPU or GPU memory." } ;
HELP: grow-buffer
{ $values { "buffer" buffer } { "target-size" integer } }
{ $description "If the " { $link buffer-size } " of the given " { $link buffer } " is less than " { $snippet "target-size" } ", reallocates the buffer to a size large enough to accommodate " { $snippet "target-size" } " bytes. If the buffer is reallocated, the original contents are lost." } ;
HELP: index-buffer
{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to index vertex arrays." } ;
@ -243,6 +247,7 @@ ARTICLE: "gpu.buffers" "Buffer objects"
{ $subsections
allocate-buffer
allocate-byte-array
grow-buffer
update-buffer
read-buffer
copy-buffer

7
extra/gpu/buffers/buffers.factor
View File

@ -132,6 +132,13 @@ TYPED:: copy-buffer ( to-buffer-ptr: buffer-ptr from-buffer-ptr: buffer-ptr size
from-buffer-ptr offset>> to-buffer-ptr offset>>
size glCopyBufferSubData ;
: (grow-buffer-size) ( target-size old-size -- new-size )
[ 2dup > ] [ 2 * ] while nip ; inline
TYPED: grow-buffer ( buffer: buffer target-size: integer -- )
over buffer-size 2dup >
[ (grow-buffer-size) f allocate-buffer ] [ 3drop ] if ; inline
:: with-mapped-buffer ( ..a buffer access quot: ( ..a alien -- ..b ) -- ..b )
buffer bind-buffer :> target
target access gl-access glMapBuffer

1
extra/key-logger/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

15
extra/key-logger/deploy.factor Normal file
View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-name "key-logger" }
{ deploy-ui? f }
{ deploy-c-types? f }
{ deploy-console? f }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
{ deploy-io 3 }
{ deploy-reflection 1 }
{ deploy-word-props? f }
{ deploy-math? t }
{ deploy-threads? t }
{ deploy-word-defs? f }
}

35
extra/key-logger/key-logger.factor Normal file
View File

@ -0,0 +1,35 @@
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alarms bit-arrays calendar game.input io
io.binary io.encodings.binary io.files kernel literals math
namespaces system threads ;
IN: key-logger
CONSTANT: frequency $[ 1/30 seconds ]
CONSTANT: path "resource:key-log.txt"
: update-key-caps-state ( -- )
read-keyboard keys>>
path binary [
[ gmt unix-1970 time- duration>nanoseconds >integer ]
[ bit-array>integer ] bi*
[ 8 >be write ] bi@ flush
] with-file-appender ;
SYMBOL: key-logger
: start-key-logger ( -- )
key-logger get-global [
[
open-game-input
[ update-key-caps-state ] frequency every key-logger set-global
] in-thread
] unless ;
: stop-key-logger ( -- )
key-logger get-global [ stop-alarm ] when*
f key-logger set-global
close-game-input ;
MAIN: start-key-logger

5
extra/mason/updates/updates.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! 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 ;
@ -20,8 +20,7 @@ IN: mason.updates
= not ;
: new-image-available? ( -- ? )
boot-image-name need-new-image?
[ boot-image-arch download-image t ] [ f ] if ;
boot-image-name maybe-download-image ;
: new-code-available? ( -- ? )
updates-available?

5
extra/mongodb/benchmark/benchmark.factor
View File

@ -247,7 +247,8 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
'[ _ swap _
'[ [ [ _ execute( -- quot ) ] dip
[ execute( -- ) ] each _ execute( quot -- quot ) gc benchmark ] with-result ] each
[ execute( -- ) ] each _ execute( quot -- quot ) gc
benchmark ] with-result ] each
print-separator ] ;
: run-serialization-bench ( doc-word-seq feat-seq -- )
@ -282,7 +283,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
: run-benchmarks ( -- )
"db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb>
"db" "db" get* "host" "127.0.0.1" get* "port" 27017 get* ensure-number <mdb>
[ print-header
! serialization
{ small-doc-prepare medium-doc-prepare

132
extra/mongodb/cmd/cmd.factor Normal file
View File

@ -0,0 +1,132 @@
USING: accessors assocs hashtables kernel linked-assocs strings ;
IN: mongodb.cmd
<PRIVATE
TUPLE: mongodb-cmd
{ name string }
{ const? boolean }
{ admin? boolean }
{ auth? boolean }
{ assoc assoc }
{ norep? boolean } ;
PRIVATE>
CONSTANT: buildinfo-cmd
T{ mongodb-cmd f "buildinfo" t t f H{ { "buildinfo" 1 } } }
CONSTANT: list-databases-cmd
T{ mongodb-cmd f "listDatabases" t t f H{ { "listDatabases" 1 } } }
! Options: { "async" t }
CONSTANT: fsync-cmd
T{ mongodb-cmd f "fsync" f t f H{ { "fsync" 1 } } }
! Value: { "clone" from_host }
CONSTANT: clone-db-cmd
T{ mongodb-cmd f "clone" f f t H{ { "clone" f } } }
! Options { { "fromdb" db } { "todb" db } { fromhost host } }
CONSTANT: copy-db-cmd
T{ mongodb-cmd f "copydb" f f f H{ { "copydb" 1 } } }
CONSTANT: shutdown-cmd
T{ mongodb-cmd f "shutdown" t t t H{ { "shutdown" 1 } } t }
CONSTANT: reseterror-cmd
T{ mongodb-cmd f "reseterror" t f f H{ { "reseterror" 1 } } }
CONSTANT: getlasterror-cmd
T{ mongodb-cmd f "getlasterror" t f f H{ { "getlasterror" 1 } } }
CONSTANT: getpreverror-cmd
T{ mongodb-cmd f "getpreverror" t f f H{ { "getpreverror" 1 } } }
CONSTANT: forceerror-cmd
T{ mongodb-cmd f "forceerror" t f f H{ { "forceerror" 1 } } }
CONSTANT: drop-db-cmd
T{ mongodb-cmd f "dropDatabase" t f f H{ { "dropDatabase" 1 } } }
! Options { { "preserveClonedFilesOnFailure" t/f } { "backupOriginalFiles" t/f } }
CONSTANT: repair-db-cmd
T{ mongodb-cmd f "repairDatabase" f f f H{ { "repairDatabase" 1 } } }
! Options: -1 gets the current profile level; 0-2 set the profile level
CONSTANT: profile-cmd
T{ mongodb-cmd f "profile" f f f H{ { "profile" 0 } } }
CONSTANT: server-status-cmd
T{ mongodb-cmd f "serverStatus" t f f H{ { "serverStatus" 1 } } }
CONSTANT: assertinfo-cmd
T{ mongodb-cmd f "assertinfo" t f f H{ { "assertinfo" 1 } } }
CONSTANT: getoptime-cmd
T{ mongodb-cmd f "getoptime" t f f H{ { "getoptime" 1 } } }
CONSTANT: oplog-cmd
T{ mongodb-cmd f "opLogging" t f f H{ { "opLogging" 1 } } }
! Value: { "deleteIndexes" collection-name }
! Options: { "index" index_name or "*" }
CONSTANT: delete-index-cmd
T{ mongodb-cmd f "deleteIndexes" f f f H{ { "deleteIndexes" f } } }
! Value: { "create" collection-name }
! Options: { { "capped" t } { "size" size_in_bytes } { "max" max_number_of_objects } { "autoIndexId" t/f } }
CONSTANT: create-cmd
T{ mongodb-cmd f "drop" f f f H{ { "create" f } } }
! Value { "drop" collection-name }
CONSTANT: drop-cmd
T{ mongodb-cmd f "drop" f f f H{ { "drop" f } } }
! Value { "count" collection-name }
! Options: { "query" query-object }
CONSTANT: count-cmd
T{ mongodb-cmd f "count" f f f H{ { "count" f } } }
! Value { "validate" collection-name }
CONSTANT: validate-cmd
T{ mongodb-cmd f "validate" f f f H{ { "validate" f } } }
! Value { "collstats" collection-name }
CONSTANT: collstats-cmd
T{ mongodb-cmd f "collstats" f f f H{ { "collstats" f } } }
! Value: { "distinct" collection-name }
! Options: { "key" key-name }
CONSTANT: distinct-cmd
T{ mongodb-cmd f "distinct" f f f H{ { "distinct" f } } }
! Value: { "filemd5" oid }
! Options: { "root" bucket-name }
CONSTANT: filemd5-cmd
T{ mongodb-cmd f "filemd5" f f f H{ { "filemd5" f } } }
CONSTANT: getnonce-cmd
T{ mongodb-cmd f "getnonce" t f f H{ { "getnonce" 1 } } }
! Options: { { "user" username } { "nonce" nonce } { "key" digest } }
CONSTANT: authenticate-cmd
T{ mongodb-cmd f "authenticate" f f f H{ { "authenticate" 1 } } }
CONSTANT: logout-cmd
T{ mongodb-cmd f "logout" t f f H{ { "logout" 1 } } }
! Value: { "findandmodify" collection-name }
! Options: { { "query" selector } { "sort" sort-spec }
! { "remove" t/f } { "update" modified-object }
! { "new" t/f } }
CONSTANT: findandmodify-cmd
T{ mongodb-cmd f "findandmodify" f f f H{ { "findandmodify" f } } }
: make-cmd ( cmd-stub -- cmd-assoc )
dup const?>> [ ] [
clone [ clone <linked-assoc> ] change-assoc
] if ; inline
: set-cmd-opt ( cmd value key -- cmd )
pick assoc>> set-at ; inline

57
extra/mongodb/connection/connection.factor
View File

@ -1,9 +1,9 @@
USING: accessors assocs fry io.encodings.binary io.sockets kernel math
math.parser mongodb.msg mongodb.operations namespaces destructors
constructors sequences splitting checksums checksums.md5
io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
arrays hashtables sequences.deep vectors locals ;
USING: accessors arrays assocs byte-vectors checksums
checksums.md5 constructors destructors fry hashtables
io.encodings.binary io.encodings.string io.encodings.utf8
io.sockets io.streams.duplex kernel locals math math.parser
mongodb.cmd mongodb.msg namespaces sequences
splitting ;
IN: mongodb.connection
: md5-checksum ( string -- digest )
@ -15,13 +15,18 @@ TUPLE: mdb-node master? { address inet } remote ;
CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
TUPLE: mdb-connection instance node handle remote local ;
TUPLE: mdb-connection instance node handle remote local buffer ;
: connection-buffer ( -- buffer )
mdb-connection get buffer>> 0 >>length ; inline
USE: mongodb.operations
CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
: check-ok ( result -- errmsg ? )
[ [ "errmsg" ] dip at ]
[ [ "ok" ] dip at >integer 1 = ] bi ; inline
[ [ "ok" ] dip at ] bi ; inline
: <mdb-db> ( name nodes -- mdb-db )
mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
@ -33,7 +38,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
nodes>> f swap at ;
: with-connection ( connection quot -- * )
[ mdb-connection set ] prepose with-scope ; inline
[ mdb-connection ] dip with-variable ; inline
: mdb-instance ( -- mdb )
mdb-connection get instance>> ; inline
@ -44,8 +49,9 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
: namespaces-collection ( -- ns )
mdb-instance name>> "system.namespaces" "." glue ; inline
: cmd-collection ( -- ns )
mdb-instance name>> "$cmd" "." glue ; inline
: cmd-collection ( cmd -- ns )
admin?>> [ "admin" ] [ mdb-instance name>> ] if
"$cmd" "." glue ; inline
: index-ns ( colname -- index-ns )
[ mdb-instance name>> ] dip "." glue ; inline
@ -58,15 +64,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
'[ _ write-message read-message ] with-stream* ;
: send-query-1result ( collection assoc -- result )
<mdb-query-msg>
1 >>return#
send-query-plain objects>>
[ f ] [ first ] if-empty ;
<mdb-query-msg> -1 >>return# send-query-plain
objects>> [ f ] [ first ] if-empty ;
: send-cmd ( cmd -- result )
[ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline
<PRIVATE
: get-nonce ( -- nonce )
cmd-collection H{ { "getnonce" 1 } } send-query-1result
getnonce-cmd make-cmd send-cmd
[ "nonce" swap at ] [ f ] if* ;
: auth? ( mdb -- ? )
@ -78,16 +85,14 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
[ pwd-digest>> ] bi
3array concat md5-checksum ; inline
: build-auth-query ( -- query-assoc )
{ "authenticate" 1 }
"user" mdb-instance username>> 2array
"nonce" get-nonce 2array
3array >hashtable
[ [ "nonce" ] dip at calculate-key-digest "key" ] keep
[ set-at ] keep ;
: build-auth-cmd ( cmd -- cmd )
mdb-instance username>> "user" set-cmd-opt
get-nonce [ "nonce" set-cmd-opt ] [ ] bi
calculate-key-digest "key" set-cmd-opt ; inline
: perform-authentication ( -- )
cmd-collection build-auth-query send-query-1result
authenticate-cmd make-cmd
build-auth-cmd send-cmd
check-ok [ drop ] [ throw ] if ; inline
: authenticate-connection ( mdb-connection -- )
@ -98,7 +103,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
: open-connection ( mdb-connection node -- mdb-connection )
[ >>node ] [ address>> ] bi
[ >>remote ] keep binary <client>
[ >>handle ] dip >>local ;
[ >>handle ] dip >>local 4096 <byte-vector> >>buffer ;
: get-ismaster ( -- result )
"admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
@ -119,7 +124,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
: nodelist>table ( seq -- assoc )
[ [ master?>> ] keep 2array ] map >hashtable ;
PRIVATE>
:: verify-nodes ( mdb -- )

105
extra/mongodb/driver/driver.factor
View File

@ -1,10 +1,10 @@
USING: accessors arrays assocs bson.constants combinators
combinators.smart constructors destructors formatting fry hashtables
io io.pools io.sockets kernel linked-assocs math mongodb.connection
mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections
sequences sets splitting strings
tools.continuations uuid memoize locals ;
combinators.smart constructors destructors fry hashtables io
io.pools io.sockets kernel linked-assocs locals math
mongodb.cmd mongodb.connection mongodb.msg namespaces parser
prettyprint prettyprint.custom prettyprint.sections sequences
sets splitting strings ;
FROM: ascii => ascii? ;
IN: mongodb.driver
TUPLE: mdb-pool < pool mdb ;
@ -13,9 +13,9 @@ TUPLE: mdb-cursor id query ;
TUPLE: mdb-collection
{ name string }
{ capped boolean initial: f }
{ size integer initial: -1 }
{ max integer initial: -1 } ;
{ capped boolean }
{ size integer }
{ max integer } ;
CONSTRUCTOR: mdb-collection ( name -- collection ) ;
@ -61,7 +61,7 @@ M: mdb-getmore-msg update-query
query>> update-query ;
: make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f )
over cursor>> 0 >
over cursor>> 0 >
[ [ update-query ]
[ [ cursor>> ] dip <mdb-cursor> ] 2bi
] [ 2drop f ] if ;
@ -84,23 +84,23 @@ M: mdb-getmore-msg verify-query-result
[ make-cursor ] 2tri
swap objects>> ;
: make-collection-assoc ( collection assoc -- )
[ [ name>> "create" ] dip set-at ]
[ [ [ capped>> ] keep ] dip
'[ _ _
[ [ drop t "capped" ] dip set-at ]
[ [ size>> "size" ] dip set-at ]
[ [ max>> "max" ] dip set-at ] 2tri ] when
] 2bi ;
PRIVATE>
SYNTAX: r/ ( token -- mdbregexp )
\ / [ >mdbregexp ] parse-literal ;
: with-db ( mdb quot -- * )
: with-db ( mdb quot -- )
'[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
: with-mdb ( mdb quot -- )
[ <mdb-pool> ] dip
[ mdb-pool swap with-variable ] curry with-disposal ; inline
: with-mdb-connection ( quot -- )
[ mdb-pool get ] dip
'[ _ with-connection ] with-pooled-connection ; inline
: >id-selector ( assoc -- selector )
[ MDB_OID_FIELD swap at ] keep
H{ } clone [ set-at ] keep ;
@ -115,11 +115,16 @@ GENERIC: create-collection ( name/collection -- )
M: string create-collection
<mdb-collection> create-collection ;
M: mdb-collection create-collection
[ [ cmd-collection ] dip
<linked-hash> [ make-collection-assoc ] keep
<mdb-query-msg> 1 >>return# send-query-plain drop ] keep
[ ] [ name>> ] bi mdb-instance collections>> set-at ;
M: mdb-collection create-collection ( collection -- )
create-cmd make-cmd over
{
[ name>> "create" set-cmd-opt ]
[ capped>> [ "capped" set-cmd-opt ] when* ]
[ max>> [ "max" set-cmd-opt ] when* ]
[ size>> [ "size" set-cmd-opt ] when* ]
} cleave send-cmd check-ok
[ drop [ ] [ name>> ] bi mdb-instance collections>> set-at ]
[ throw ] if ;
: load-collection-list ( -- collection-list )
namespaces-collection
@ -128,8 +133,12 @@ M: mdb-collection create-collection
<PRIVATE
: ensure-valid-collection-name ( collection -- )
[ ";$." intersect length 0 > ] keep
'[ _ "contains invalid characters ( . $ ; )" "." glue throw ] when ; inline
[
[ ";$." intersect length 0 > ] keep
'[ _ "contains invalid characters ( . $ ; )" ":" glue throw ] when
] [
[ ascii? ] all? [ "collection names must only contain ascii characters" throw ] unless
] bi ; inline
: build-collection-map ( -- assoc )
H{ } clone load-collection-list
@ -215,21 +224,21 @@ M: mdb-cursor find
dup empty? [ drop f ] [ first ] if ;
: count ( mdb-query-msg -- result )
[ collection>> "count" H{ } clone [ set-at ] keep ] keep
query>> [ over [ "query" ] dip set-at ] when*
[ cmd-collection ] dip <mdb-query-msg> find-one
[ count-cmd make-cmd ] dip
[ collection>> "count" set-cmd-opt ]
[ query>> "query" set-cmd-opt ] bi send-cmd
[ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
: lasterror ( -- error )
cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
find-one [ "err" ] dip at ;
getlasterror-cmd make-cmd send-cmd
[ "err" ] dip at ;
GENERIC: validate. ( collection -- )
M: string validate.
[ cmd-collection ] dip
"validate" H{ } clone [ set-at ] keep
<mdb-query-msg> find-one [ check-ok nip ] keep
[ validate-cmd make-cmd ] dip
"validate" set-cmd-opt send-cmd
[ check-ok nip ] keep
'[ "result" _ at print ] [ ] if ;
M: mdb-collection validate.
@ -251,7 +260,7 @@ PRIVATE>
<mdb-insert-msg> send-message ;
: ensure-index ( index-spec -- )
<linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
<linked-hash> [ [ <oid> "_id" ] dip set-at ] keep
[ { [ [ name>> "name" ] dip set-at ]
[ [ ns>> index-ns "ns" ] dip set-at ]
[ [ key>> "key" ] dip set-at ]
@ -261,11 +270,9 @@ PRIVATE>
[ index-collection ] dip save ;
: drop-index ( collection name -- )
H{ } clone
[ [ "index" ] dip set-at ] keep
[ [ "deleteIndexes" ] dip set-at ] keep
[ cmd-collection ] dip <mdb-query-msg>
find-one drop ;
[ delete-index-cmd make-cmd ] 2dip
[ "deleteIndexes" set-cmd-opt ]
[ "index" set-cmd-opt ] bi* send-cmd drop ;
: <update> ( collection selector object -- mdb-update-msg )
[ check-collection ] 2dip <mdb-update-msg> ;
@ -278,7 +285,16 @@ PRIVATE>
: update-unsafe ( mdb-update-msg -- )
send-message ;
: find-and-modify ( collection selector modifier -- mongodb-cmd )
[ findandmodify-cmd make-cmd ] 3dip
[ "findandmodify" set-cmd-opt ]
[ "query" set-cmd-opt ]
[ "update" set-cmd-opt ] tri* ; inline
: run-cmd ( cmd -- result )
send-cmd ; inline
: delete ( collection selector -- )
[ check-collection ] dip
<mdb-delete-msg> send-message-check-error ;
@ -298,8 +314,7 @@ PRIVATE>
check-collection drop ;
: drop-collection ( name -- )
[ cmd-collection ] dip
"drop" H{ } clone [ set-at ] keep
<mdb-query-msg> find-one drop ;
[ drop-cmd make-cmd ] dip
"drop" set-cmd-opt send-cmd drop ;

285
extra/mongodb/gridfs/gridfs.factor Normal file
View File

@ -0,0 +1,285 @@
USING: accessors arrays assocs base64 bson.constants
byte-arrays byte-vectors calendar combinators
combinators.short-circuit destructors formatting fry hashtables
io kernel linked-assocs locals math math.parser mongodb.cmd
mongodb.connection mongodb.driver mongodb.msg namespaces
sequences splitting strings ;
FROM: mongodb.driver => update ;
IN: mongodb.gridfs
CONSTANT: default-chunk-size 262144
TUPLE: gridfs
{ bucket string }
{ files string }
{ chunks string } ;
<PRIVATE
: gridfs> ( -- gridfs )
gridfs get ; inline
: files-collection ( -- str ) gridfs> files>> ; inline
: chunks-collection ( -- str ) gridfs> chunks>> ; inline
: init-gridfs ( gridfs -- )
chunks>> "ChunkIdx" H{ { "files_id" 1 } { "n" 1 } }
<index-spec> ensure-index ; inline
PRIVATE>
: <gridfs> ( bucket -- gridfs )
[ ]
[ "files" "%s.%s" sprintf ]
[ "chunks" "%s.%s" sprintf ] tri
gridfs boa [ init-gridfs ] keep ;
: with-gridfs ( gridfs quot -- * )
[ gridfs ] dip with-variable ; inline
TUPLE: entry
{ id oid }
{ filename string }
{ content-type string }
{ length integer }
{ chunk-size integer }
{ created timestamp }
{ aliases array }
{ metadata hashtable }
{ md5 string } ;
<PRIVATE
: id>base64 ( id -- str )
[ a>> >hex ] [ b>> >hex ] bi
2array "#" join >base64 >string ; inline
: base64>id ( str -- objid )
base64> >string "#" split
[ first ] [ second ] bi
[ hex> ] bi@ oid boa ; inline
PRIVATE>
: <entry> ( name content-type -- entry )
entry new
swap >>content-type swap >>filename
<oid> >>id 0 >>length default-chunk-size >>chunk-size
now >>created ; inline
<PRIVATE
TUPLE: chunk
{ id oid }
{ fileid oid }
{ n integer }
{ data byte-array } ;
: at> ( assoc key -- value/f )
swap at ; inline
:: >set-at ( assoc value key -- )
value key assoc set-at ; inline
: (update-file) ( entry assoc -- entry )
{
[ "_id" at> >>id ]
[ "filename" at> >>filename ]
[ "contentType" at> >>content-type ]
[ "length" at> >>length ]
[ "chunkSize" at> >>chunk-size ]
[ "uploadDate" at> >>created ]
[ "aliases" at> >>aliases ]
[ "metadata" at> >>metadata ]
[ "md5" at> >>md5 ]
} cleave ; inline
: assoc>chunk ( assoc -- chunk )
[ chunk new ] dip
{
[ "_id" at> >>id ]
[ "files_id" at> >>fileid ]
[ "n" at> >>n ]
[ "data" at> >>data ]
} cleave ;
: assoc>entry ( assoc -- entry )
[ entry new ] dip (update-file) ;
: entry>assoc ( entry -- assoc )
[ H{ } clone ] dip
{
[ id>> "_id" >set-at ]
[ filename>> "filename" >set-at ]
[ content-type>> "contentType" >set-at ]
[ length>> "length" >set-at ]
[ chunk-size>> "chunkSize" >set-at ]
[ created>> "uploadDate" >set-at ]
[ aliases>> "aliases" >set-at ]
[ metadata>> "metadata" >set-at ]
[ md5>> "md5" >set-at ]
[ drop ]
} 2cleave ; inline
: create-entry ( entry -- entry )
[ [ files-collection ] dip entry>assoc save ] [ ] bi ;
TUPLE: state bytes count ;
: <state> ( -- state )
0 0 state boa ; inline
: get-state ( -- n )
state get ; inline
: with-state ( quot -- state )
[ <state> state ] dip
[ get-state ] compose
with-variable ; inline
: update-state ( bytes -- )
[ get-state ] dip
'[ _ + ] change-bytes
[ 1 + ] change-count drop ; inline
:: store-chunk ( chunk entry n -- )
entry id>> :> id
H{ { "files_id" id }
{ "n" n } { "data" chunk } }
[ chunks-collection ] dip save ; inline
:: write-chunks ( stream entry -- length )
entry chunk-size>> :> chunk-size
[
[
chunk-size stream stream-read dup [
[ entry get-state count>> store-chunk ]
[ length update-state ] bi
] when*
] loop
] with-state bytes>> ;
: (entry-selector) ( entry -- selector )
id>> "_id" associate ; inline
:: file-md5 ( id -- md5-str )
filemd5-cmd make-cmd
id "filemd5" set-cmd-opt
gridfs> bucket>> "root" set-cmd-opt
send-cmd "md5" at> ; inline
: update-entry ( bytes entry -- entry )
[ swap >>length dup id>> file-md5 >>md5 ]
[ nip [ (entry-selector) ] [ ] bi
[ length>> "length" associate "$set" associate
[ files-collection ] 2dip <update> update ]
[ md5>> "md5" associate "$set" associate
[ files-collection ] 2dip <update> update ] 2bi
] 2bi ;
TUPLE: gridfs-input-stream entry chunk n offset cpos ;
: <gridfs-input-stream> ( entry -- stream )
[ gridfs-input-stream new ] dip
>>entry 0 >>offset 0 >>cpos -1 >>n ;
PRIVATE>
: write-entry ( input-stream entry -- entry )
create-entry [ write-chunks ] keep update-entry ;
: get-entry ( id -- entry )
[ files-collection ] dip
"_id" associate <query> find-one assoc>entry ;
: open-entry ( entry -- input-stream )
<gridfs-input-stream> ;
: entry-contents ( entry -- bytearray )
<gridfs-input-stream> stream-contents ;
<PRIVATE
: load-chunk ( stream -- chunk/f )
[ entry>> id>> "files_id" associate ]
[ n>> "n" associate ] bi assoc-union
[ chunks-collection ] dip
<query> find-one dup [ assoc>chunk ] when ;
: exhausted? ( stream -- boolean )
[ offset>> ] [ entry>> length>> ] bi = ; inline
: fresh? ( stream -- boolean )
[ offset>> 0 = ] [ chunk>> f = ] bi and ; inline
: data-available ( stream -- int/f )
[ cpos>> ] [ chunk>> data>> length ] bi
2dup < [ swap - ] [ 2drop f ] if ; inline
: next-chunk ( stream -- available chunk/f )
0 >>cpos [ 1 + ] change-n
[ ] [ load-chunk ] bi >>chunk
[ data-available ] [ chunk>> ] bi ; inline
: ?chunk ( stream -- available chunk/f )
dup fresh? [ next-chunk ] [
dup exhausted? [ drop 0 f ] [
dup data-available [ swap chunk>> ] [ next-chunk ] if*
] if
] if ; inline
: set-stream ( n stream -- )
swap {
[ >>offset drop ]
[ over entry>> chunk-size>> /mod [ >>n ] [ >>cpos ] bi* drop ]
[ drop dup load-chunk >>chunk drop ]
} 2cleave ; inline
:: advance-stream ( n stream -- )
stream [ n + ] change-cpos [ n + ] change-offset drop ; inline
: read-part ( n stream chunk -- seq/f )
[ [ cpos>> swap [ drop ] [ + ] 2bi ] [ data>> ] bi* <slice> ]
[ drop advance-stream ] 3bi ; inline
:: (stream-read-partial) ( n stream -- seq/f )
stream ?chunk :> chunk :> available
chunk [
n available <
[ n ] [ available ] if
stream chunk read-part
] [ f ] if ; inline
:: (stream-read) ( n stream acc -- )
n stream (stream-read-partial)
{
{ [ dup not ] [ drop ] }
{ [ dup length n = ] [ acc push-all ] }
{ [ dup length n < ] [
[ acc push-all ] [ length ] bi
n swap - stream acc (stream-read) ]
}
} cond ; inline recursive
PRIVATE>
M: gridfs-input-stream stream-element-type drop +byte+ ;
M: gridfs-input-stream stream-read ( n stream -- seq/f )
over <byte-vector> [ (stream-read) ] [ ] bi
dup empty? [ drop f ] [ >byte-array ] if ;
M: gridfs-input-stream stream-read-partial ( n stream -- seq/f )
(stream-read-partial) ;
M: gridfs-input-stream stream-tell ( stream -- n )
offset>> ;
M: gridfs-input-stream stream-seek ( n seek-type stream -- )
swap seek-absolute =
[ set-stream ]
[ "seek-type not supported" throw ] if ;
M: gridfs-input-stream dispose drop ;

2
extra/mongodb/mongodb-docs.factor
View File

@ -9,7 +9,7 @@ ARTICLE: "mongodb" "MongoDB factor integration"
"USING: mongodb.driver ;"
"\"db\" \"127.0.0.1\" 27017 <mdb>"
"[ \"mycollection\" [ H{ { \"name\" \"Alfred\" } { \"age\" 57 } } save ] "
" [ ageIdx [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
" [ \"ageIdx\" [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
" [ H{ { \"age\" H{ { \"$gt\" 50 } } } } <query> find-one ] tri ] with-db "
"" }
{ $heading "Highlevel tuple integration" }

64
extra/mongodb/msg/msg.factor
View File

@ -17,52 +17,52 @@ CONSTANT: ResultFlag_ErrSet 2 ! /* { $err : ... } is being returned */
CONSTANT: ResultFlag_ShardConfigStale 4 ! /* have to update config from the server, usually $err is also set */
TUPLE: mdb-msg
{ opcode integer }
{ req-id integer initial: 0 }
{ resp-id integer initial: 0 }
{ length integer initial: 0 }
{ flags integer initial: 0 } ;
{ opcode integer }
{ req-id integer initial: 0 }
{ resp-id integer initial: 0 }
{ length integer initial: 0 }
{ flags integer initial: 0 } ;
TUPLE: mdb-query-msg < mdb-msg
{ collection string }
{ skip# integer initial: 0 }
{ return# integer initial: 0 }
{ query assoc }
{ returnfields assoc }
{ orderby assoc }
explain hint ;
{ collection string }
{ skip# integer initial: 0 }
{ return# integer initial: 0 }
{ query assoc }
{ returnfields assoc }
{ orderby assoc }
explain hint ;
TUPLE: mdb-insert-msg < mdb-msg
{ collection string }
{ objects sequence } ;
{ collection string }
{ objects sequence } ;
TUPLE: mdb-update-msg < mdb-msg
{ collection string }
{ upsert? integer initial: 0 }
{ selector assoc }
{ object assoc } ;
{ collection string }
{ upsert? integer initial: 0 }
{ selector assoc }
{ object assoc } ;
TUPLE: mdb-delete-msg < mdb-msg
{ collection string }
{ selector assoc } ;
{ collection string }
{ selector assoc } ;
TUPLE: mdb-getmore-msg < mdb-msg
{ collection string }
{ return# integer initial: 0 }
{ cursor integer initial: 0 }
{ query mdb-query-msg } ;
{ collection string }
{ return# integer initial: 0 }
{ cursor integer initial: 0 }
{ query mdb-query-msg } ;
TUPLE: mdb-killcursors-msg < mdb-msg
{ cursors# integer initial: 0 }
{ cursors sequence } ;
{ cursors# integer initial: 0 }
{ cursors sequence } ;
TUPLE: mdb-reply-msg < mdb-msg
{ collection string }
{ cursor integer initial: 0 }
{ start# integer initial: 0 }
{ requested# integer initial: 0 }
{ returned# integer initial: 0 }
{ objects sequence } ;
{ collection string }
{ cursor integer initial: 0 }
{ start# integer initial: 0 }
{ requested# integer initial: 0 }
{ returned# integer initial: 0 }
{ objects sequence } ;
CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg )

215
extra/mongodb/operations/operations.factor
View File

@ -1,11 +1,15 @@
USING: accessors assocs bson.reader bson.writer byte-arrays
byte-vectors combinators formatting fry io io.binary
io.encodings.private io.encodings.binary io.encodings.string
io.encodings.utf8 io.encodings.utf8.private io.files kernel
locals math mongodb.msg namespaces sequences uuid
bson.writer.private ;
byte-vectors combinators formatting fry io io.binary io.encodings.private
io.encodings.binary io.encodings.string io.encodings.utf8 io.encodings.utf8.private io.files
kernel locals math mongodb.msg namespaces sequences uuid bson.writer.private ;
FROM: mongodb.connection => connection-buffer ;
FROM: alien => byte-length ;
IN: mongodb.operations
M: byte-vector byte-length length ;
<PRIVATE
PREDICATE: mdb-reply-op < integer OP_Reply = ;
@ -16,12 +20,6 @@ PREDICATE: mdb-delete-op < integer OP_Delete = ;
PREDICATE: mdb-getmore-op < integer OP_GetMore = ;
PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ;
PRIVATE>
GENERIC: write-message ( message -- )
<PRIVATE
CONSTANT: MSG-HEADER-SIZE 16
SYMBOL: msg-bytes-read
@ -40,34 +38,26 @@ SYMBOL: msg-bytes-read
: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline
: read-byte ( -- byte ) read-byte-raw first ; inline
: (read-cstring) ( acc -- )
[ read-byte ] dip ! b acc
2dup push ! b acc
[ 0 = ] dip ! bool acc
'[ _ (read-cstring) ] unless ; inline recursive
: read-cstring ( -- string )
BV{ } clone
[ (read-cstring) ] keep
[ zero? ] trim-tail
>byte-array utf8 decode ; inline
GENERIC: (read-message) ( message opcode -- message )
: copy-header ( message msg-stub -- message )
[ length>> ] keep [ >>length ] dip
[ req-id>> ] keep [ >>req-id ] dip
[ resp-id>> ] keep [ >>resp-id ] dip
[ opcode>> ] keep [ >>opcode ] dip
flags>> >>flags ;
{
[ length>> >>length ]
[ req-id>> >>req-id ]
[ resp-id>> >>resp-id ]
[ opcode>> >>opcode ]
[ flags>> >>flags ]
} cleave ; inline
M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
drop
: reply-read-message ( msg-stub -- message )
[ <mdb-reply-msg> ] dip copy-header
read-longlong >>cursor
read-int32 >>start#
read-int32 [ >>returned# ] keep
[ H{ } stream>assoc ] collector [ times ] dip >>objects ;
[ H{ } clone stream>assoc ] collector [ times ] dip >>objects ;
: (read-message) ( message opcode -- message )
OP_Reply =
[ reply-read-message ]
[ "unknown message type" throw ] if ; inline
: read-header ( message -- message )
read-int32 >>length
@ -77,94 +67,97 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
read-int32 >>flags ; inline
: write-header ( message -- )
[ req-id>> write-int32 ] keep
[ resp-id>> write-int32 ] keep
opcode>> write-int32 ; inline
[ req-id>> write-int32 ]
[ resp-id>> write-int32 ]
[ opcode>> write-int32 ] tri ; inline
PRIVATE>
: read-message ( -- message )
mdb-msg new
0 >bytes-read
read-header
[ ] [ opcode>> ] bi (read-message) ;
[
mdb-msg new 0 >bytes-read read-header
[ ] [ opcode>> ] bi (read-message)
] with-scope ;
<PRIVATE
USE: tools.walker
: dump-to-file ( array -- )
[ uuid1 "/tmp/mfb/%s.dump" sprintf binary ] dip
'[ _ write ] with-file-writer ;
: (write-message) ( message quot -- )
'[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer
! [ dump-to-file ] keep
write flush ; inline
: (write-message) ( message quot -- )
[ connection-buffer dup ] 2dip
'[
[ _ [ write-header ] [ @ ] bi ] with-length-prefix
] with-output-stream* write flush ; inline
:: build-query-object ( query -- selector )
H{ } clone :> selector
query { [ orderby>> [ "$orderby" selector set-at ] when* ]
[ explain>> [ "$explain" selector set-at ] when* ]
[ hint>> [ "$hint" selector set-at ] when* ]
[ query>> "query" selector set-at ]
} cleave
selector ;
query {
[ orderby>> [ "$orderby" selector set-at ] when* ]
[ explain>> [ "$explain" selector set-at ] when* ]
[ hint>> [ "$hint" selector set-at ] when* ]
[ query>> "query" selector set-at ]
} cleave selector ; inline
: write-query-message ( message -- )
[
{
[ flags>> write-int32 ]
[ collection>> write-cstring ]
[ skip#>> write-int32 ]
[ return#>> write-int32 ]
[ build-query-object assoc>stream ]
[ returnfields>> [ assoc>stream ] when* ]
} cleave
] (write-message) ; inline
: write-insert-message ( message -- )
[
[ flags>> write-int32 ]
[ collection>> write-cstring ]
[ objects>> [ assoc>stream ] each ] tri
] (write-message) ; inline
: write-update-message ( message -- )
[
{
[ flags>> write-int32 ]
[ collection>> write-cstring ]
[ upsert?>> write-int32 ]
[ selector>> assoc>stream ]
[ object>> assoc>stream ]
} cleave
] (write-message) ; inline
: write-delete-message ( message -- )
[
[ flags>> write-int32 ]
[ collection>> write-cstring ]
[ 0 write-int32 selector>> assoc>stream ] tri
] (write-message) ; inline
: write-getmore-message ( message -- )
[
{
[ flags>> write-int32 ]
[ collection>> write-cstring ]
[ return#>> write-int32 ]
[ cursor>> write-longlong ]
} cleave
] (write-message) ; inline
: write-killcursors-message ( message -- )
[
[ flags>> write-int32 ]
[ cursors#>> write-int32 ]
[ cursors>> [ write-longlong ] each ] tri
] (write-message) ; inline
PRIVATE>
M: mdb-query-msg write-message ( message -- )
dup
'[ _
[ flags>> write-int32 ] keep
[ collection>> write-cstring ] keep
[ skip#>> write-int32 ] keep
[ return#>> write-int32 ] keep
[ build-query-object assoc>stream ] keep
returnfields>> [ assoc>stream ] when*
] (write-message) ;
M: mdb-insert-msg write-message ( message -- )
dup
'[ _
[ flags>> write-int32 ] keep
[ collection>> write-cstring ] keep
objects>> [ assoc>stream ] each
] (write-message) ;
M: mdb-update-msg write-message ( message -- )
dup
'[ _
[ flags>> write-int32 ] keep
[ collection>> write-cstring ] keep
[ upsert?>> write-int32 ] keep
[ selector>> assoc>stream ] keep
object>> assoc>stream
] (write-message) ;
M: mdb-delete-msg write-message ( message -- )
dup
'[ _
[ flags>> write-int32 ] keep
[ collection>> write-cstring ] keep
0 write-int32
selector>> assoc>stream
] (write-message) ;
M: mdb-getmore-msg write-message ( message -- )
dup
'[ _
[ flags>> write-int32 ] keep
[ collection>> write-cstring ] keep
[ return#>> write-int32 ] keep
cursor>> write-longlong
] (write-message) ;
M: mdb-killcursors-msg write-message ( message -- )
dup
'[ _
[ flags>> write-int32 ] keep
[ cursors#>> write-int32 ] keep
cursors>> [ write-longlong ] each
] (write-message) ;
: write-message ( message -- )
{
{ [ dup mdb-query-msg? ] [ write-query-message ] }
{ [ dup mdb-insert-msg? ] [ write-insert-message ] }
{ [ dup mdb-update-msg? ] [ write-update-message ] }
{ [ dup mdb-delete-msg? ] [ write-delete-message ] }
{ [ dup mdb-getmore-msg? ] [ write-getmore-message ] }
{ [ dup mdb-killcursors-msg? ] [ write-killcursors-message ] }
} cond ;

12
extra/mongodb/tuple/persistent/persistent.factor
View File

@ -42,7 +42,7 @@ DEFER: assoc>tuple
swap set-at ; inline
: write-field? ( tuple key value -- ? )
pick mdb-persistent? [
pick mdb-persistent? [
{ [ [ 2drop ] dip not ]
[ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
@ -54,7 +54,7 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
over [ call( tuple -- assoc ) ] dip
[ [ tuple-collection name>> ] [ >toid ] bi ] keep
[ add-storable ] dip
[ tuple-collection name>> ] [ id>> ] bi <objref> ;
[ tuple-collection name>> ] [ id>> ] bi <dbref> ;
: write-field ( value quot -- value' )
<cond-value> {
@ -78,9 +78,6 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
: prepare-assoc ( tuple -- assoc mirror tuple assoc )
H{ } clone swap [ <mirror> ] keep pick ; inline
: ensure-mdb-info ( tuple -- tuple )
dup id>> [ <objid> >>id ] unless ; inline
: with-object-map ( quot: ( -- ) -- store-assoc )
[ H{ } clone dup object-map ] dip with-variable ; inline
@ -92,11 +89,14 @@ PRIVATE>
GENERIC: tuple>storable ( tuple -- storable )
: ensure-oid ( tuple -- tuple )
dup id>> [ <oid> >>id ] unless ; inline
M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
'[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
M: mdb-persistent tuple>assoc ( tuple -- assoc )
ensure-mdb-info (tuple>assoc) ;
ensure-oid (tuple>assoc) ;
M: tuple tuple>assoc ( tuple -- assoc )
(tuple>assoc) ;

4
extra/mongodb/tuple/tuple.factor
View File

@ -61,9 +61,9 @@ PRIVATE>
: update-tuple ( tuple -- )
[ tuple-collection name>> ]
[ id-selector ]
[ ensure-oid id-selector ]
[ tuple>assoc ] tri
<update> update ;
<update> >upsert update ;
: save-tuple ( tuple -- )
update-tuple ;

72
extra/nehe/2/2.factor
View File

@ -1,5 +1,6 @@
USING: arrays kernel math opengl opengl.gl opengl.glu
opengl.demo-support ui ui.gadgets ui.render literals accessors ;
opengl.demo-support ui ui.gadgets ui.render ui.pixel-formats
literals accessors ;
IN: nehe.2
TUPLE: nehe2-gadget < gadget ;
@ -8,36 +9,45 @@ CONSTANT: width 256
CONSTANT: height 256
: <nehe2-gadget> ( -- gadget )
nehe2-gadget new ;
nehe2-gadget new ;
M: nehe2-gadget draw-gadget* ( gadget -- )
drop
GL_PROJECTION glMatrixMode
glLoadIdentity
45.0 width height / >float 0.1 100.0 gluPerspective
GL_MODELVIEW glMatrixMode
glLoadIdentity
GL_SMOOTH glShadeModel
0.0 0.0 0.0 0.0 glClearColor
1.0 glClearDepth
GL_DEPTH_TEST glEnable
GL_LEQUAL glDepthFunc
GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
glLoadIdentity
-1.5 0.0 -6.0 glTranslatef
GL_TRIANGLES [
0.0 1.0 0.0 glVertex3f
-1.0 -1.0 0.0 glVertex3f
1.0 -1.0 0.0 glVertex3f
] do-state
3.0 0.0 0.0 glTranslatef
GL_QUADS [
-1.0 1.0 0.0 glVertex3f
1.0 1.0 0.0 glVertex3f
1.0 -1.0 0.0 glVertex3f
-1.0 -1.0 0.0 glVertex3f
] do-state ;
drop
GL_PROJECTION glMatrixMode
glLoadIdentity
45.0 width height / >float 0.1 100.0 gluPerspective
GL_MODELVIEW glMatrixMode
glLoadIdentity
GL_SMOOTH glShadeModel
0.0 0.0 0.0 0.0 glClearColor
1.0 glClearDepth
GL_DEPTH_TEST glEnable
GL_LEQUAL glDepthFunc
GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
glLoadIdentity
-1.5 0.0 -6.0 glTranslatef
GL_TRIANGLES [
0.0 1.0 0.0 glVertex3f
-1.0 -1.0 0.0 glVertex3f
1.0 -1.0 0.0 glVertex3f
] do-state
3.0 0.0 0.0 glTranslatef
GL_QUADS [
-1.0 1.0 0.0 glVertex3f
1.0 1.0 0.0 glVertex3f
1.0 -1.0 0.0 glVertex3f
-1.0 -1.0 0.0 glVertex3f
] do-state ;
MAIN-WINDOW: run2 { { title "NeHe Tutorial 2" } { pref-dim { $ width $ height } } }
<nehe2-gadget> >>gadgets ;
MAIN-WINDOW: run2
{
{ title "NeHe Tutorial 2" }
{ pref-dim { $ width $ height } }
{ pixel-format-attributes {
windowed
double-buffered
T{ depth-bits { value 16 } }
} }
}
<nehe2-gadget> >>gadgets ;

105
extra/nehe/4/4.factor
View File

@ -1,6 +1,6 @@
USING: arrays kernel math opengl opengl.gl opengl.glu
opengl.demo-support ui ui.gadgets ui.render threads accessors
calendar literals ;
opengl.demo-support ui ui.gadgets ui.render ui.pixel-formats
threads accessors calendar literals ;
IN: nehe.4
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
@ -10,63 +10,72 @@ CONSTANT: height 256
: redraw-interval ( -- dt ) 10 milliseconds ;
: <nehe4-gadget> ( -- gadget )
nehe4-gadget new
nehe4-gadget new
0.0 >>rtri
0.0 >>rquad ;
M: nehe4-gadget draw-gadget* ( gadget -- )
GL_PROJECTION glMatrixMode
glLoadIdentity
45.0 width height / >float 0.1 100.0 gluPerspective
GL_MODELVIEW glMatrixMode
glLoadIdentity
GL_SMOOTH glShadeModel
0.0 0.0 0.0 0.0 glClearColor
1.0 glClearDepth
GL_DEPTH_TEST glEnable
GL_LEQUAL glDepthFunc
GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
glLoadIdentity
-1.5 0.0 -6.0 glTranslatef
dup rtri>> 0.0 1.0 0.0 glRotatef
GL_PROJECTION glMatrixMode
glLoadIdentity
45.0 width height / >float 0.1 100.0 gluPerspective
GL_MODELVIEW glMatrixMode
glLoadIdentity
GL_SMOOTH glShadeModel
0.0 0.0 0.0 0.0 glClearColor
1.0 glClearDepth
GL_DEPTH_TEST glEnable
GL_LEQUAL glDepthFunc
GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
glLoadIdentity
-1.5 0.0 -6.0 glTranslatef
dup rtri>> 0.0 1.0 0.0 glRotatef
GL_TRIANGLES [
1.0 0.0 0.0 glColor3f
0.0 1.0 0.0 glVertex3f
0.0 1.0 0.0 glColor3f
-1.0 -1.0 0.0 glVertex3f
0.0 0.0 1.0 glColor3f
1.0 -1.0 0.0 glVertex3f
] do-state
GL_TRIANGLES [
1.0 0.0 0.0 glColor3f
0.0 1.0 0.0 glVertex3f
0.0 1.0 0.0 glColor3f
-1.0 -1.0 0.0 glVertex3f
0.0 0.0 1.0 glColor3f
1.0 -1.0 0.0 glVertex3f
] do-state
glLoadIdentity
glLoadIdentity
1.5 0.0 -6.0 glTranslatef
dup rquad>> 1.0 0.0 0.0 glRotatef
0.5 0.5 1.0 glColor3f
GL_QUADS [
-1.0 1.0 0.0 glVertex3f
1.0 1.0 0.0 glVertex3f
1.0 -1.0 0.0 glVertex3f
-1.0 -1.0 0.0 glVertex3f
] do-state
[ 0.2 + ] change-rtri
[ 0.15 - ] change-rquad drop ;
1.5 0.0 -6.0 glTranslatef
dup rquad>> 1.0 0.0 0.0 glRotatef
0.5 0.5 1.0 glColor3f
GL_QUADS [
-1.0 1.0 0.0 glVertex3f
1.0 1.0 0.0 glVertex3f
1.0 -1.0 0.0 glVertex3f
-1.0 -1.0 0.0 glVertex3f
] do-state
[ 0.2 + ] change-rtri
[ 0.15 - ] change-rquad drop ;
: nehe4-update-thread ( gadget -- )
dup quit?>> [ drop ] [
redraw-interval sleep
dup relayout-1
nehe4-update-thread
] if ;
dup quit?>> [ drop ] [
redraw-interval sleep
dup relayout-1
nehe4-update-thread
] if ;
M: nehe4-gadget graft* ( gadget -- )
f >>quit?
[ nehe4-update-thread ] curry in-thread ;
f >>quit?
[ nehe4-update-thread ] curry in-thread ;
M: nehe4-gadget ungraft* ( gadget -- )
t >>quit? drop ;
t >>quit? drop ;
MAIN-WINDOW: run4 { { title "NeHe Tutorial 4" } { pref-dim { $ width $ height } } }
<nehe4-gadget> >>gadgets ;
MAIN-WINDOW: run4
{
{ title "NeHe Tutorial 4" }
{ pref-dim { $ width $ height } }
{ pixel-format-attributes {
windowed
double-buffered
T{ depth-bits { value 16 } }
} }
}
<nehe4-gadget> >>gadgets ;

197
extra/nehe/5/5.factor
View File

@ -1,6 +1,6 @@
USING: arrays kernel math opengl opengl.gl opengl.glu
opengl.demo-support ui ui.gadgets ui.render threads accessors
calendar literals ;
opengl.demo-support ui ui.gadgets ui.render ui.pixel-formats
threads accessors calendar literals ;
IN: nehe.5
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
@ -9,116 +9,125 @@ CONSTANT: height 256
: redraw-interval ( -- dt ) 10 milliseconds ;
: <nehe5-gadget> ( -- gadget )
nehe5-gadget new
nehe5-gadget new
0.0 >>rtri
0.0 >>rquad ;
M: nehe5-gadget draw-gadget* ( gadget -- )
GL_PROJECTION glMatrixMode
glLoadIdentity
45.0 width height / >float 0.1 100.0 gluPerspective
GL_MODELVIEW glMatrixMode
glLoadIdentity
GL_SMOOTH glShadeModel
0.0 0.0 0.0 0.0 glClearColor
1.0 glClearDepth
GL_DEPTH_TEST glEnable
GL_LEQUAL glDepthFunc
GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
glLoadIdentity
-1.5 0.0 -6.0 glTranslatef
dup rtri>> 0.0 1.0 0.0 glRotatef
GL_PROJECTION glMatrixMode
glLoadIdentity
45.0 width height / >float 0.1 100.0 gluPerspective
GL_MODELVIEW glMatrixMode
glLoadIdentity
GL_SMOOTH glShadeModel
0.0 0.0 0.0 0.0 glClearColor
1.0 glClearDepth
GL_DEPTH_TEST glEnable
GL_LEQUAL glDepthFunc
GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
glLoadIdentity
-1.5 0.0 -6.0 glTranslatef
dup rtri>> 0.0 1.0 0.0 glRotatef
GL_TRIANGLES [
1.0 0.0 0.0 glColor3f
0.0 1.0 0.0 glVertex3f
0.0 1.0 0.0 glColor3f
-1.0 -1.0 1.0 glVertex3f
0.0 0.0 1.0 glColor3f
1.0 -1.0 1.0 glVertex3f
GL_TRIANGLES [
1.0 0.0 0.0 glColor3f
0.0 1.0 0.0 glVertex3f
0.0 1.0 0.0 glColor3f
-1.0 -1.0 1.0 glVertex3f
0.0 0.0 1.0 glColor3f
1.0 -1.0 1.0 glVertex3f
1.0 0.0 0.0 glColor3f
0.0 1.0 0.0 glVertex3f
0.0 0.0 1.0 glColor3f
1.0 -1.0 1.0 glVertex3f
0.0 1.0 0.0 glColor3f
1.0 -1.0 -1.0 glVertex3f
1.0 0.0 0.0 glColor3f
0.0 1.0 0.0 glVertex3f
0.0 0.0 1.0 glColor3f
1.0 -1.0 1.0 glVertex3f
0.0 1.0 0.0 glColor3f
1.0 -1.0 -1.0 glVertex3f
1.0 0.0 0.0 glColor3f
0.0 1.0 0.0 glVertex3f
0.0 1.0 0.0 glColor3f
1.0 -1.0 -1.0 glVertex3f
0.0 0.0 1.0 glColor3f
-1.0 -1.0 -1.0 glVertex3f
1.0 0.0 0.0 glColor3f
0.0 1.0 0.0 glVertex3f
0.0 1.0 0.0 glColor3f
1.0 -1.0 -1.0 glVertex3f
0.0 0.0 1.0 glColor3f
-1.0 -1.0 -1.0 glVertex3f
1.0 0.0 0.0 glColor3f
0.0 1.0 0.0 glVertex3f
0.0 0.0 1.0 glColor3f
-1.0 -1.0 -1.0 glVertex3f
0.0 1.0 0.0 glColor3f
-1.0 -1.0 1.0 glVertex3f
] do-state
1.0 0.0 0.0 glColor3f
0.0 1.0 0.0 glVertex3f
0.0 0.0 1.0 glColor3f
-1.0 -1.0 -1.0 glVertex3f
0.0 1.0 0.0 glColor3f
-1.0 -1.0 1.0 glVertex3f
] do-state
glLoadIdentity
glLoadIdentity
1.5 0.0 -7.0 glTranslatef
dup rquad>> 1.0 0.0 0.0 glRotatef
GL_QUADS [
0.0 1.0 0.0 glColor3f
1.0 1.0 -1.0 glVertex3f
-1.0 1.0 -1.0 glVertex3f
-1.0 1.0 1.0 glVertex3f
1.0 1.0 1.0 glVertex3f
1.5 0.0 -7.0 glTranslatef
dup rquad>> 1.0 0.0 0.0 glRotatef
GL_QUADS [
0.0 1.0 0.0 glColor3f
1.0 1.0 -1.0 glVertex3f
-1.0 1.0 -1.0 glVertex3f
-1.0 1.0 1.0 glVertex3f
1.0 1.0 1.0 glVertex3f
1.0 0.5 0.0 glColor3f
1.0 -1.0 1.0 glVertex3f
-1.0 -1.0 1.0 glVertex3f
-1.0 -1.0 -1.0 glVertex3f
1.0 -1.0 -1.0 glVertex3f
1.0 0.5 0.0 glColor3f
1.0 -1.0 1.0 glVertex3f
-1.0 -1.0 1.0 glVertex3f
-1.0 -1.0 -1.0 glVertex3f
1.0 -1.0 -1.0 glVertex3f
1.0 0.0 0.0 glColor3f
1.0 1.0 1.0 glVertex3f
-1.0 1.0 1.0 glVertex3f
-1.0 -1.0 1.0 glVertex3f
1.0 -1.0 1.0 glVertex3f
1.0 0.0 0.0 glColor3f
1.0 1.0 1.0 glVertex3f
-1.0 1.0 1.0 glVertex3f
-1.0 -1.0 1.0 glVertex3f
1.0 -1.0 1.0 glVertex3f
1.0 1.0 0.0 glColor3f
1.0 -1.0 -1.0 glVertex3f
-1.0 -1.0 -1.0 glVertex3f
-1.0 1.0 -1.0 glVertex3f
1.0 1.0 -1.0 glVertex3f
1.0 1.0 0.0 glColor3f
1.0 -1.0 -1.0 glVertex3f
-1.0 -1.0 -1.0 glVertex3f
-1.0 1.0 -1.0 glVertex3f
1.0 1.0 -1.0 glVertex3f
0.0 0.0 1.0 glColor3f
-1.0 1.0 1.0 glVertex3f
-1.0 1.0 -1.0 glVertex3f
-1.0 -1.0 -1.0 glVertex3f
-1.0 -1.0 1.0 glVertex3f
0.0 0.0 1.0 glColor3f
-1.0 1.0 1.0 glVertex3f
-1.0 1.0 -1.0 glVertex3f
-1.0 -1.0 -1.0 glVertex3f
-1.0 -1.0 1.0 glVertex3f
1.0 0.0 1.0 glColor3f
1.0 1.0 -1.0 glVertex3f
1.0 1.0 1.0 glVertex3f
1.0 -1.0 1.0 glVertex3f
1.0 -1.0 -1.0 glVertex3f
] do-state
[ 0.2 + ] change-rtri
[ 0.15 - ] change-rquad drop ;
1.0 0.0 1.0 glColor3f
1.0 1.0 -1.0 glVertex3f
1.0 1.0 1.0 glVertex3f
1.0 -1.0 1.0 glVertex3f
1.0 -1.0 -1.0 glVertex3f
] do-state
[ 0.2 + ] change-rtri
[ 0.15 - ] change-rquad drop ;
: nehe5-update-thread ( gadget -- )
dup quit?>> [
drop
] [
redraw-interval sleep
dup relayout-1
nehe5-update-thread
] if ;
: nehe5-update-thread ( gadget -- )
dup quit?>> [
drop
] [
redraw-interval sleep
dup relayout-1
nehe5-update-thread
] if ;
M: nehe5-gadget graft* ( gadget -- )
f >>quit?
[ nehe5-update-thread ] curry in-thread ;
f >>quit?
[ nehe5-update-thread ] curry in-thread ;
M: nehe5-gadget ungraft* ( gadget -- )
t >>quit? drop ;
t >>quit? drop ;
MAIN-WINDOW: run5 { { title "NeHe Tutorial 5" } { pref-dim { $ width $ height } } }
<nehe5-gadget> >>gadgets ;
MAIN-WINDOW: run5
{
{ title "NeHe Tutorial 5" }
{ pref-dim { $ width $ height } }
{ pixel-format-attributes {
windowed
double-buffered
T{ depth-bits { value 16 } }
} }
}
<nehe5-gadget> >>gadgets ;