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

Fix conflict

db4
Slava Pestov 2008-02-02 13:36:26 -06:00
parent 8575bc62e3 a05c18152b
commit 36a43a6c3f
206 changed files with 1394 additions and 13185 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
core/bootstrap/primitives.factor
View File

@ -15,12 +15,12 @@ crossref off
"resource:core/bootstrap/syntax.factor" parse-file
"resource:core/cpu/" architecture get {
{ "x86.32" "x86/32" }
{ "x86.64" "x86/64" }
{ "linux-ppc" "ppc/linux" }
{ "macosx-ppc" "ppc/macosx" }
{ "arm" "arm" }
} at "/bootstrap.factor" 3append parse-file
{ "x86.32" "x86/32" }
{ "x86.64" "x86/64" }
{ "linux-ppc" "ppc/linux" }
{ "macosx-ppc" "ppc/macosx" }
{ "arm" "arm" }
} at "/bootstrap.factor" 3append parse-file
"resource:core/bootstrap/layouts/layouts.factor" parse-file
@ -626,7 +626,7 @@ builtins get num-tags get tail f union-class define-class
{ "<float-array>" "float-arrays" }
{ "curry" "kernel" }
{ "<tuple-boa>" "tuples.private" }
{ "class-hash" "kernel.private" }
{ "class-hash" "kernel.private" }
{ "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "kernel.private" }

2
core/inference/transforms/transforms.factor
View File

@ -54,6 +54,8 @@ M: pair (bitfield-quot) ( spec -- quot )
\ bitfield [ bitfield-quot ] 1 define-transform
\ flags [ flags [ ] curry ] 1 define-transform
! Tuple operations
: [get-slots] ( slots -- quot )
[ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;

5
core/io/encodings/encodings.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors
namespaces ;
namespaces unicode.syntax ;
IN: io.encodings
TUPLE: encode-error ;
@ -17,6 +17,9 @@ SYMBOL: begin
: decoded ( buf ch -- buf ch state )
over push 0 begin ;
: push-replacement ( buf -- buf ch state )
UNICHAR: replacement-character decoded ;
: finish-decoding ( buf ch state -- str )
begin eq? [ decode-error ] unless drop "" like ;

14
core/io/utf16/utf16-tests.factor
View File

@ -1,15 +1,15 @@
USING: tools.test io.utf16 ;
USING: tools.test io.utf16 arrays unicode.syntax ;
[ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be >array ] unit-test
[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be >array ] unit-test
[ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test-fails
[ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test-fails
[ { UNICHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test
[ { UNICHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test
[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be >array ] unit-test
[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be ] unit-test
[ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le >array ] unit-test
[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le >array ] unit-test
[ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test-fails
[ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test-fails
[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test
[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test
[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le >array ] unit-test
[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le ] unit-test

18
core/io/utf16/utf16.factor
View File

@ -8,6 +8,9 @@ SYMBOL: double
SYMBOL: quad1
SYMBOL: quad2
SYMBOL: quad3
SYMBOL: ignore
: do-ignore ( -- ch state ) 0 ignore ;
: append-nums ( byte ch -- ch )
8 shift bitor ;
@ -19,21 +22,22 @@ SYMBOL: quad3
dup -3 shift BIN: 11011 number= [
dup BIN: 00000100 bitand zero?
[ BIN: 11 bitand quad1 ]
[ decode-error ] if
[ drop do-ignore ] if
] [ double ] if ;
: handle-quad2be ( byte ch -- ch )
: handle-quad2be ( byte ch -- ch state )
swap dup -2 shift BIN: 110111 number= [
>r 2 shift r> BIN: 11 bitand bitor
] [ decode-error ] if ;
>r 2 shift r> BIN: 11 bitand bitor quad3
] [ 2drop do-ignore ] if ;
: (decode-utf16be) ( buf byte ch state -- buf ch state )
{
{ begin [ drop begin-utf16be ] }
{ double [ end-multibyte ] }
{ quad1 [ append-nums quad2 ] }
{ quad2 [ handle-quad2be quad3 ] }
{ quad2 [ handle-quad2be ] }
{ quad3 [ append-nums HEX: 10000 + decoded ] }
{ ignore [ 2drop push-replacement ] }
} case ;
: decode-utf16be ( seq -- str )
@ -43,13 +47,13 @@ SYMBOL: quad3
swap dup -3 shift BIN: 11011 = [
dup BIN: 100 bitand 0 number=
[ BIN: 11 bitand 8 shift bitor quad2 ]
[ decode-error ] if
[ 2drop push-replacement ] if
] [ end-multibyte ] if ;
: handle-quad3le ( buf byte ch -- buf ch state )
swap dup -2 shift BIN: 110111 = [
BIN: 11 bitand append-nums HEX: 10000 + decoded
] [ decode-error ] if ;
] [ 2drop push-replacement ] if ;
: (decode-utf16le) ( buf byte ch state -- buf ch state )
{

12
core/io/utf8/utf8-tests.factor
View File

@ -1,16 +1,16 @@
USING: io.utf8 tools.test strings ;
USING: io.utf8 tools.test strings arrays unicode.syntax ;
[ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8 ] unit-test-fails
[ { UNICHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8 >array ] unit-test
[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8 ] unit-test
[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test
[ "x" ] [ "x" decode-utf8 >string ] unit-test
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8 ] unit-test
[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8 >array ] unit-test
[ { BIN: 10000000 } decode-utf8 ] unit-test-fails
[ { UNICHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8 >array ] unit-test
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8 ] unit-test
[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test

18
core/io/utf8/utf8.factor
View File

@ -14,10 +14,10 @@ SYMBOL: quad3
: starts-2? ( char -- ? )
-6 shift BIN: 10 number= ;
: append-nums ( bottom top -- num )
over starts-2?
[ 6 shift swap BIN: 111111 bitand bitor ]
[ decode-error ] if ;
: append-nums ( buf bottom top state-out -- buf num state )
>r over starts-2?
[ 6 shift swap BIN: 111111 bitand bitor r> ]
[ r> 3drop push-replacement ] if ;
: begin-utf8 ( buf byte -- buf ch state )
{
@ -25,20 +25,20 @@ SYMBOL: quad3
{ [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] }
{ [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] }
{ [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] }
{ [ t ] [ decode-error ] }
{ [ t ] [ drop push-replacement ] }
} cond ;
: end-multibyte ( buf byte ch -- buf ch state )
append-nums decoded ;
f append-nums [ decoded ] unless* ;
: (decode-utf8) ( buf byte ch state -- buf ch state )
{
{ begin [ drop begin-utf8 ] }
{ double [ end-multibyte ] }
{ triple [ append-nums triple2 ] }
{ triple [ triple2 append-nums ] }
{ triple2 [ end-multibyte ] }
{ quad [ append-nums quad2 ] }
{ quad2 [ append-nums quad3 ] }
{ quad [ quad2 append-nums ] }
{ quad2 [ quad3 append-nums ] }
{ quad3 [ end-multibyte ] }
} case ;

5
core/math/bitfields/bitfields.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math sequences words ;
IN: math.bitfields
@ -13,3 +13,6 @@ M: pair (bitfield) ( value accum pair -- newaccum )
: bitfield ( values... bitspec -- n )
0 [ (bitfield) ] reduce ;
: flags ( values -- n )
0 [ dup word? [ execute ] when bitor ] reduce ;

76
core/parser/parser.factor
View File

@ -347,45 +347,49 @@ SYMBOL: bootstrap-syntax
call
] with-scope ; inline
SYMBOL: interactive-vocabs
{
"arrays"
"assocs"
"combinators"
"compiler.errors"
"continuations"
"debugger"
"definitions"
"editors"
"generic"
"help"
"inspector"
"io"
"io.files"
"kernel"
"listener"
"math"
"memory"
"namespaces"
"prettyprint"
"sequences"
"slicing"
"sorting"
"strings"
"syntax"
"tools.annotations"
"tools.crossref"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.time"
"vocabs"
"vocabs.loader"
"words"
"scratchpad"
} interactive-vocabs set-global
: with-interactive-vocabs ( quot -- )
[
"scratchpad" in set
{
"arrays"
"assocs"
"combinators"
"compiler.errors"
"continuations"
"debugger"
"definitions"
"editors"
"generic"
"help"
"inspector"
"io"
"io.files"
"kernel"
"listener"
"math"
"memory"
"namespaces"
"prettyprint"
"sequences"
"slicing"
"sorting"
"strings"
"syntax"
"tools.annotations"
"tools.crossref"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.time"
"vocabs"
"vocabs.loader"
"words"
"scratchpad"
} set-use
interactive-vocabs get set-use
call
] with-scope ; inline

4
core/prettyprint/backend/backend-docs.factor
View File

@ -18,10 +18,6 @@ HELP: ch>ascii-escape
{ $values { "ch" "a character" } { "str" string } }
{ $description "Converts a character to an escape code." } ;
HELP: ch>unicode-escape
{ $values { "ch" "a character" } { "str" string } }
{ $description "Converts a character to a Unicode escape code (" { $snippet "\\u123456"} ")." } ;
HELP: unparse-ch
{ $values { "ch" "a character" } }
{ $description "Adds the character to the sequence being constructed (see " { $link "namespaces-make" } "). If the character can appear in a string literal, it is added directly, otherwise an escape code is added." } ;

16
core/prettyprint/backend/backend.factor
View File

@ -58,17 +58,17 @@ M: f pprint* drop \ f pprint-word ;
! Strings
: ch>ascii-escape ( ch -- str )
H{
{ CHAR: \e CHAR: \\e }
{ CHAR: \n CHAR: \\n }
{ CHAR: \r CHAR: \\r }
{ CHAR: \t CHAR: \\t }
{ CHAR: \0 CHAR: \\0 }
{ CHAR: \\ CHAR: \\\\ }
{ CHAR: \" CHAR: \\\" }
{ CHAR: \e CHAR: e }
{ CHAR: \n CHAR: n }
{ CHAR: \r CHAR: r }
{ CHAR: \t CHAR: t }
{ CHAR: \0 CHAR: 0 }
{ CHAR: \\ CHAR: \\ }
{ CHAR: \" CHAR: \" }
} at ;
: unparse-ch ( ch -- )
dup ch>ascii-escape [ ] [ ] ?if , ;
dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
: do-string-limit ( str -- trimmed )
string-limit get [

5
core/strings/strings-tests.factor
View File

@ -51,6 +51,9 @@ unit-test
[ "ab" ] [ 2 "abc" resize-string ] unit-test
[ "abc\0\0\0" ] [ 6 "abc" resize-string ] unit-test
[ "\u001234b" ] [ 2 "\u001234bc" resize-string ] unit-test
[ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test
! Random tester found this
[ { "kernel-error" 3 12 -7 } ]
[ [ 2 -7 resize-string ] catch ] unit-test
@ -88,3 +91,5 @@ unit-test
"\udeadbe" clone
CHAR: \u123456 over clone set-first
] unit-test

2
core/strings/strings.factor
View File

@ -38,7 +38,7 @@ M: string set-nth-unsafe
>r >fixnum >r >fixnum r> r> set-string-nth ;
M: string clone
(clone) dup string-aux clone over set-string-aux ;
(clone) dup string-aux clone over set-string-aux ;
M: string resize resize-string ;

6
extra/automata/ui/ui.factor
View File

@ -62,9 +62,9 @@ DEFER: automata-window
{
[ "1 - Center" [ start-center ] view-button ]
[ "2 - Random" [ start-random ] view-button ]
[ "3 - Continue" [ run-rule ] view-button ]
[ "3 - Continue" [ run-rule ] view-button ]
[ "5 - Random Rule" [ random-rule ] view-button ]
[ "n - New" [ automata-window ] view-button ]
[ "n - New" [ automata-window ] view-button ]
} make*
[ [ gadget, ] curry ] map concat ! Hack
make-shelf over @top grid-add
@ -75,7 +75,7 @@ over @center grid-add
{
{ T{ key-down f f "1" } [ [ start-center ] view-action ] }
{ T{ key-down f f "2" } [ [ start-random ] view-action ] }
{ T{ key-down f f "3" } [ [ run-rule ] view-action ] }
{ T{ key-down f f "3" } [ [ run-rule ] view-action ] }
{ T{ key-down f f "5" } [ [ random-rule ] view-action ] }
{ T{ key-down f f "n" } [ [ automata-window ] view-action ] }
} [ make* ] map >hashtable <handler> tuck set-gadget-delegate

8
extra/bake/bake.factor
View File

@ -38,16 +38,16 @@ DEFER: bake
: bake-item ( item -- )
{ { [ dup \ , = ] [ drop , ] }
{ [ dup \ % = ] [ drop % ] }
{ [ dup \ ,u = ] [ drop ,u ] }
{ [ dup \ % = ] [ drop % ] }
{ [ dup \ ,u = ] [ drop ,u ] }
{ [ dup insert-quot? ] [ insert-quot-expr call , ] }
{ [ dup splice-quot? ] [ splice-quot-expr call % ] }
{ [ dup integer? ] [ , ] }
{ [ dup string? ] [ , ] }
{ [ dup string? ] [ , ] }
{ [ dup tuple? ] [ tuple>array bake >tuple , ] }
{ [ dup assoc? ] [ [ >alist bake ] keep assoc-like , ] }
{ [ dup sequence? ] [ bake , ] }
{ [ t ] [ , ] } }
{ [ t ] [ , ] } }
cond ;
: bake-items ( seq -- ) [ bake-item ] each ;

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

@ -1,6 +1,6 @@
USING: kernel io io.files splitting strings
hashtables sequences assocs math namespaces prettyprint
math.parser combinators arrays sorting ;
math.parser combinators arrays sorting unicode.case ;
IN: benchmark.knucleotide

2
extra/benchmark/reverse-complement/reverse-complement.factor
View File

@ -1,6 +1,6 @@
USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting
hints ;
hints unicode.case ;
IN: benchmark.reverse-complement
MEMO: trans-map ( -- str )

22
extra/builder/builder.factor
View File

@ -1,5 +1,5 @@
USING: kernel io io.files io.launcher
USING: kernel io io.files io.launcher tools.deploy.backend
system namespaces sequences splitting math.parser
unix prettyprint tools.time calendar bake vars ;
@ -9,10 +9,10 @@ IN: builder
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
[ number>string 2 CHAR: 0 pad-left ] map "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -31,8 +31,6 @@ SYMBOL: builder-recipients
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: boot-image ( -- filename ) `{ "boot" ,[ cpu ] "image" } "." join ;
: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -61,7 +59,7 @@ if
"factor" cd
{ "/usr/bin/git" "show" } <process-stream>
{ "git" "show" } <process-stream>
[ readln ] with-stream
" " split second
"../git-id" <file-writer> [ print ] with-stream
@ -76,7 +74,7 @@ if
"builder: vm compile" throw
] if
"wget http://factorcode.org/images/latest/" boot-image append system
"wget http://factorcode.org/images/latest/" boot-image-name append system
0 =
[ ]
[
@ -84,7 +82,11 @@ if
"builder: image download" throw
] if
[ "./factor -i=" boot-image " -no-user-init > ../boot-log" 3append system ]
[
"./factor -i=" boot-image-name " -no-user-init > ../boot-log"
3append
system
]
benchmark nip
"../boot-time" <file-writer> [ . ] with-stream
0 =

4
extra/cairo-demo/cairo-demo.factor
View File

@ -7,7 +7,7 @@
USING: cairo math math.constants byte-arrays kernel ui ui.render
ui.gadgets opengl.gl ;
ui.gadgets opengl.gl ;
IN: cairo-demo
@ -66,7 +66,7 @@ M: cairo-gadget ungraft* ( gadget -- )
: run ( -- )
[
<cairo-gadget> "Hello World from Factor!" open-window
<cairo-gadget> "Hello World from Factor!" open-window
] with-ui ;
MAIN: run

34
extra/cairo/cairo.factor
View File

@ -13,9 +13,9 @@ USING: alien alien.syntax combinators system ;
IN: cairo
<< "cairo" {
{ [ win32? ] [ "cairo.dll" ] }
{ [ macosx? ] [ "libcairo.dylib" ] }
{ [ unix? ] [ "libcairo.so.2" ] }
{ [ win32? ] [ "cairo.dll" ] }
{ [ macosx? ] [ "libcairo.dylib" ] }
{ [ unix? ] [ "libcairo.so.2" ] }
} cond "cdecl" add-library >>
! cairo_status_t
@ -152,12 +152,12 @@ C-STRUCT: cairo_t
{ "uint" "status ! cairo_status_t" } ;
C-STRUCT: cairo_matrix_t
{ "double" "xx" }
{ "double" "yx" }
{ "double" "xy" }
{ "double" "yy" }
{ "double" "x0" }
{ "double" "y0" } ;
{ "double" "xx" }
{ "double" "yx" }
{ "double" "xy" }
{ "double" "yy" }
{ "double" "x0" }
{ "double" "y0" } ;
! cairo_format_t
C-ENUM:
@ -204,16 +204,16 @@ C-ENUM:
"cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ;
: cairo_reference ( cairo_t -- cairo_t )
"cairo_t*" "cairo" "cairo_reference" [ "cairo_t*" ] alien-invoke ;
"cairo_t*" "cairo" "cairo_reference" [ "cairo_t*" ] alien-invoke ;
: cairo_destroy ( cairo_t -- )
"void" "cairo" "cairo_destroy" [ "cairo_t*" ] alien-invoke ;
: cairo_save ( cairo_t -- )
"void" "cairo" "cairo_save" [ "cairo_t*" ] alien-invoke ;
"void" "cairo" "cairo_save" [ "cairo_t*" ] alien-invoke ;
: cairo_restore ( cairo_t -- )
"void" "cairo" "cairo_restore" [ "cairo_t*" ] alien-invoke ;
"void" "cairo" "cairo_restore" [ "cairo_t*" ] alien-invoke ;
: cairo_set_operator ( cairo_t cairo_operator_t -- )
"void" "cairo" "cairo_set_operator" [ "cairo_t*" "int" ] alien-invoke ;
@ -268,13 +268,13 @@ C-ENUM:
"void" "cairo" "cairo_rotate" [ "cairo_t*" "double" ] alien-invoke ;
: cairo_transform ( cairo_t cairo_matrix_t -- )
"void" "cairo" "cairo_transform" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
"void" "cairo" "cairo_transform" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
: cairo_set_matrix ( cairo_t cairo_matrix_t -- )
"void" "cairo" "cairo_set_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
"void" "cairo" "cairo_set_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
: cairo_identity_matrix ( cairo_t -- )
"void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ;
"void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ;
! cairo path creating functions
@ -415,10 +415,10 @@ C-ENUM:
"void" "cairo" "cairo_set_font_size" [ "cairo_t*" "double" ] alien-invoke ;
: cairo_set_font_matrix ( cairo_t cairo_matrix_t -- )
"void" "cairo" "cairo_set_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
"void" "cairo" "cairo_set_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
: cairo_get_font_matrix ( cairo_t cairo_matrix_t -- )
"void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;
"void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ;

4
extra/cfdg/cfdg.factor
View File

@ -94,9 +94,9 @@ VAR: threshold
: gl-flip ( angle -- ) deg>rad dup dup dup
[ 2 * cos , 2 * sin , 0 , 0 ,
2 * sin , 2 * cos neg , 0 , 0 ,
2 * sin , 2 * cos neg , 0 , 0 ,
0 , 0 , 1 , 0 ,
0 , 0 , 0 , 1 , ]
0 , 0 , 0 , 1 , ]
{ } make >c-double-array glMultMatrixd ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

4
extra/cfdg/models/aqua-star/aqua-star.factor
View File

@ -9,9 +9,9 @@ iterate? [
{ { 1 [ circle
[ .23 y .99 s .002 b tentacle ] do ] }
{ 1 [ circle
[ .17 y 2 r .99 s .002 b tentacle ] do ] }
[ .17 y 2 r .99 s .002 b tentacle ] do ] }
{ 1 [ circle
[ .12 y -2 r .99 s .001 b tentacle ] do ] } }
[ .12 y -2 r .99 s .001 b tentacle ] do ] } }
call-random-weighted
] when ;

8
extra/cfdg/models/chiaroscuro/chiaroscuro.factor
View File

@ -9,18 +9,18 @@ DEFER: white
: black ( -- ) iterate? [
{ { 60 [ [ 0.6 s circle ] do
[ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] }
[ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] }
{ 1 [ white black ] } }
call-random-weighted
] when ;
: white ( -- ) iterate? [
{ { 60 [
[ 0.6 s circle ] do
[ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do
[ 0.6 s circle ] do
[ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do
] }
{ 1 [
black white
black white
] } }
call-random-weighted
] when ;

4
extra/cfdg/models/game1-turn6/game1-turn6.factor
View File

@ -24,8 +24,8 @@ DEFER: start
: spiral ( -- ) iterate? [
{ { 1 [ f-squares
[ 0.5 x 0.5 y 45 r f-triangles ] do
[ 1 y 25 r 0.9 s spiral ] do ] }
[ 0.5 x 0.5 y 45 r f-triangles ] do
[ 1 y 25 r 0.9 s spiral ] do ] }
{ 0.022 [ [ 90 flip 50 hue start ] do ] } }
call-random-weighted
] when ;

2
extra/cfdg/models/lesson/lesson.factor
View File

@ -73,7 +73,7 @@ DEFER: tree
iterate? [
{
{ 20 [ [ 0.25 size circle ] do
[ 0.1 y 0.97 size tree ] do ] }
[ 0.1 y 0.97 size tree ] do ] }
{ 1.5 [ branch ] }
} random-weighted* do
] when ;

8
extra/cfdg/models/snowflake/snowflake.factor
View File

@ -7,11 +7,11 @@ IN: cfdg.models.snowflake
: spike ( -- )
iterate? [
{ { 1 [ square
[ 0.95 y 0.97 s spike ] do ] }
[ 0.95 y 0.97 s spike ] do ] }
{ 0.03 [ square
[ 60 r spike ] do
[ -60 r spike ] do
[ 0.95 y 0.97 s spike ] do ] } }
[ 60 r spike ] do
[ -60 r spike ] do
[ 0.95 y 0.97 s spike ] do ] } }
call-random-weighted
] when ;

10
extra/concurrency/concurrency-docs.factor
View File

@ -33,7 +33,7 @@ HELP: (mailbox-block-unless-pred)
HELP: (mailbox-block-if-empty)
{ $values { "mailbox" "a mailbox object" }
{ "mailbox2" "same object as 'mailbox'" }
{ "mailbox2" "same object as 'mailbox'" }
{ "timeout" "a timeout in milliseconds" }
}
{ $description "Block the thread if the mailbox is empty." }
@ -41,21 +41,21 @@ HELP: (mailbox-block-if-empty)
HELP: mailbox-get
{ $values { "mailbox" "a mailbox object" }
{ "obj" "an object" }
{ "obj" "an object" }
}
{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." }
{ $see-also make-mailbox mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ;
HELP: mailbox-get-all
{ $values { "mailbox" "a mailbox object" }
{ "array" "an array" }
{ "array" "an array" }
}
{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." }
{ $see-also make-mailbox mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ;
HELP: while-mailbox-empty
{ $values { "mailbox" "a mailbox object" }
{ "quot" "a quotation with stack effect " { $snippet "( -- )" } }
{ "quot" "a quotation with stack effect " { $snippet "( -- )" } }
}
{ $description "Repeatedly call the quotation while there are no items in the mailbox. Quotation should have stack effect " { $snippet "( -- )" } "." }
{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all mailbox-get? } ;
@ -63,7 +63,7 @@ HELP: while-mailbox-empty
HELP: mailbox-get?
{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "mailbox" "a mailbox object" }
{ "obj" "an object" }
{ "obj" "an object" }
}
{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does. 'pred' must have stack effect " { $snippet "( X -- bool }" } "." }
{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty } ;

18
extra/cryptlib/cryptlib.factor
View File

@ -6,7 +6,7 @@
! Adapted from cryptlib.h
! Tested with cryptlib 3.3.1.0
USING: cryptlib.libcl kernel hashtables alien math
namespaces sequences assocs libc alien.c-types continuations ;
namespaces sequences assocs libc alien.c-types alien.accessors continuations ;
IN: cryptlib
@ -59,7 +59,7 @@ SYMBOL: session
cryptEnd check-result ;
: with-cryptlib ( quot -- )
[ init [ end ] [ ] cleanup ] with-scope ; inline
[ init [ end ] [ ] cleanup ] with-scope ; inline
! =========================================================
! Create and destroy an encryption context
@ -71,10 +71,10 @@ SYMBOL: session
: destroy-context ( -- )
context get [ *int cryptDestroyContext check-result ] when*
context off ;
context off ;
: with-context ( algo quot -- )
swap create-context [ destroy-context ] [ ] cleanup ; inline
swap create-context [ destroy-context ] [ ] cleanup ; inline
! =========================================================
! Keyset routines
@ -86,10 +86,10 @@ SYMBOL: session
: close-keyset ( -- )
keyset get *int cryptKeysetClose check-result
destroy-context ;
destroy-context ;
: with-keyset ( type name options quot -- )
>r open-keyset r> [ close-keyset ] [ ] cleanup ; inline
>r open-keyset r> [ close-keyset ] [ ] cleanup ; inline
: get-public-key ( idtype id -- )
>r >r keyset get *int "int*" <c-object> tuck r> r> string>char-alien
@ -128,7 +128,7 @@ SYMBOL: session
certificate get *int cryptDestroyCert check-result ;
: with-certificate ( type quot -- )
swap create-certificate [ destroy-certificate ] [ ] cleanup ; inline
swap create-certificate [ destroy-certificate ] [ ] cleanup ; inline
: sign-certificate ( -- )
certificate get *int context get *int cryptSignCert check-result ;
@ -175,7 +175,7 @@ SYMBOL: session
envelope get *int cryptDestroyEnvelope check-result ;
: with-envelope ( format quot -- )
swap create-envelope [ destroy-envelope ] [ ] cleanup ;
swap create-envelope [ destroy-envelope ] [ ] cleanup ;
: create-session ( format -- )
>r "int" <c-object> dup swap CRYPT_UNUSED r> cryptCreateSession
@ -185,7 +185,7 @@ SYMBOL: session
session get *int cryptDestroySession check-result ;
: with-session ( format quot -- )
swap create-session [ destroy-session ] [ ] cleanup ;
swap create-session [ destroy-session ] [ ] cleanup ;
: push-data ( handle buffer length -- )
>r >r *int r> r> "int" <c-object> [ cryptPushData ]

4
extra/cryptlib/streams/streams.factor
View File

@ -3,7 +3,7 @@
USING: cryptlib cryptlib.libcl kernel alien sequences continuations
byte-arrays namespaces io.buffers math generic io strings
io.streams.lines io.streams.plain io.streams.duplex combinators
alien.c-types ;
alien.c-types continuations ;
IN: cryptlib.streams
@ -154,4 +154,4 @@ M: crypt-stream dispose ( stream -- )
dispose
end
;
;

2
extra/fjsc/fjsc.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg strings promises sequences math math.parser
namespaces words quotations arrays hashtables io
io.streams.string assocs memoize ;
io.streams.string assocs memoize ascii ;
IN: fjsc
TUPLE: ast-number value ;

2
extra/globs/globs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser-combinators regexp lazy-lists sequences kernel
promises strings ;
promises strings unicode.case ;
IN: globs
<PRIVATE

4
extra/hexdump/hexdump.factor
View File

@ -1,6 +1,6 @@
USING: arrays combinators.lib io io.streams.string
kernel math math.parser namespaces prettyprint
sequences splitting strings ;
kernel math math.parser namespaces prettyprint
sequences splitting strings ascii ;
IN: hexdump
<PRIVATE

2
extra/html/elements/elements.factor
View File

@ -4,7 +4,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations
sequences strings words xml.writer xml.entities compiler.units effects ;
sequences strings words xml.entities compiler.units effects ;
IN: html.elements

2
extra/html/html.factor
View File

@ -3,7 +3,7 @@
USING: generic assocs help http io io.styles io.files continuations
io.streams.string kernel math math.parser namespaces
quotations assocs sequences strings words html.elements
xml.writer xml.entities sbufs ;
xml.entities sbufs continuations ;
IN: html
GENERIC: browser-link-href ( presented -- href )

3
extra/html/parser/analyzer/analyzer.factor
View File

@ -1,4 +1,5 @@
USING: assocs html.parser kernel math sequences strings ;
USING: assocs html.parser kernel math sequences strings unicode.categories
unicode.case ;
IN: html.parser.analyzer
: remove-blank-text ( vector -- vector' )

2
extra/html/parser/parser.factor
View File

@ -1,6 +1,6 @@
USING: arrays html.parser.utils hashtables io kernel
namespaces prettyprint quotations
sequences splitting state-parser strings ;
sequences splitting state-parser strings unicode.categories unicode.case ;
IN: html.parser
TUPLE: tag name attributes text matched? closing? ;

2
extra/http/http-tests.factor
View File

@ -14,3 +14,5 @@ IN: temporary
[ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "%20%21%20" ] [ " ! " url-encode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test

21
extra/http/http.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io kernel math namespaces math.parser assocs
sequences strings splitting ;
sequences strings splitting ascii io.utf8 ;
IN: http
: header-line ( line -- )
@ -20,18 +20,15 @@ IN: http
dup letter?
over LETTER? or
over digit? or
swap "/_-?." member? or ; foldable
swap "/_-." member? or ; foldable
: push-utf8 ( string -- )
1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
[
[
dup url-quotable? [
,
] [
CHAR: % , >hex 2 CHAR: 0 pad-left %
] if
] each
] "" make ;
[ [
dup url-quotable? [ , ] [ push-utf8 ] if
] each ] "" make ;
: url-decode-hex ( index str -- )
2dup length 2 - >= [
@ -58,7 +55,7 @@ IN: http
] if ;
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make ;
[ 0 swap url-decode-iter ] "" make decode-utf8 ;
: hash>query ( hash -- str )
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map

2
extra/http/server/templating/templating.factor
View File

@ -25,7 +25,7 @@ M: template-lexer skip-word
{
{ [ 2dup nth CHAR: " = ] [ drop 1+ ] }
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
{ [ t ] [ [ blank? ] skip ] }
{ [ t ] [ f skip ] }
} cond
] change-column ;

2
extra/id3/id3.factor
View File

@ -4,7 +4,7 @@
USING: arrays combinators io io.binary io.files io.paths
io.utf16 kernel math math.parser namespaces sequences
splitting strings assocs ;
splitting strings assocs unicode.categories ;
IN: id3

6
extra/io/server/server.factor
View File

@ -29,7 +29,7 @@ SYMBOL: log-stream
: with-log-file ( file quot -- )
>r <file-appender> r>
[ with-log-stream ] with-disposal ; inline
[ with-log-stream ] curry with-disposal ; inline
: with-log-stdio ( quot -- )
stdio get swap with-log-stream ;
@ -47,11 +47,11 @@ SYMBOL: log-stream
dup log-client
[ swap with-stream ] 2curry concurrency:spawn drop ; inline
: accept-loop ( server quot -- server quot )
: accept-loop ( server quot -- )
[ swap accept with-client ] 2keep accept-loop ; inline
: server-loop ( server quot -- )
[ accept-loop ] compose with-disposal ; inline
[ accept-loop ] curry with-disposal ; inline
: spawn-server ( addrspec quot -- )
"Waiting for connections on " pick unparse append

2
extra/io/sniffer/bsd/bsd.factor
View File

@ -7,7 +7,7 @@ sequences io.sniffer.backend ;
QUALIFIED: unix
IN: io.sniffer.bsd
M: unix-io destruct-handle ( obj -- ) close drop ;
M: unix-io destruct-handle ( obj -- ) unix:close drop ;
C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ;
C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ;

19
extra/io/unix/backend/backend.factor
View File

@ -104,8 +104,21 @@ M: integer close-handle ( fd -- )
: handle-io-task ( mx task -- )
dup do-io-task [ pop-callbacks ] [ 2drop ] if ;
: handle-timeout ( mx task -- )
"Timeout" over io-task-port report-error pop-callbacks ;
: handle-timeout ( port mx assoc -- )
>r swap port-handle r> delete-at* [
"I/O operation cancelled" over io-task-port report-error
pop-callbacks
] [
2drop
] if ;
: cancel-io-tasks ( port mx -- )
2dup
dup mx-reads handle-timeout
dup mx-writes handle-timeout ;
M: unix-io cancel-io ( port -- )
mx get-global cancel-io-tasks ;
! Readers
: reader-eof ( reader -- )
@ -165,7 +178,7 @@ M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: unix-io io-multiplex ( ms -- )
mx get-global wait-for-events ;
expire-timeouts mx get-global wait-for-events ;
M: unix-io init-stdio ( -- )
0 1 handle>duplex-stream io:stdio set-global

2
extra/irc/irc.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays calendar io io.sockets kernel match namespaces
sequences splitting strings continuations threads ;
sequences splitting strings continuations threads ascii ;
IN: irc
! "setup" objects

2
extra/json/reader/reader.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser-combinators namespaces sequences promises strings
assocs math math.parser math.vectors math.functions
lazy-lists hashtables ;
lazy-lists hashtables ascii ;
IN: json.reader
! Grammar for JSON from RFC 4627

2
extra/koszul/koszul.factor
View File

@ -123,7 +123,7 @@ DEFER: (d)
[ drop H{ } ] [ unclip swap [ x.dy ] 2keep dx.y alt+ ] if ;
: linear-op ( vec quot -- vec )
[
[
[
-rot >r swap call r> alt*n (alt+)
] curry assoc-each

5
extra/lint/lint.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs combinators.lib io kernel
USING: alien alien.accessors arrays assocs combinators.lib io kernel
macros math namespaces prettyprint quotations sequences
vectors vocabs words ;
USING: html.elements slots.private tar ;
vectors vocabs words html.elements slots.private tar ;
IN: lint
SYMBOL: def-hash

2
extra/lsys/strings/rewrite/rewrite.factor
View File

@ -19,7 +19,7 @@ VAR: accum
: (rewrite) ( slice -- )
{ { [ empty? ] [ drop ] }
{ [ has-param? ] [ next+rest* [ push-next ] [ (rewrite) ] bi* ] }
{ [ t ] [ next+rest [ push-next ] [ (rewrite) ] bi* ] } }
{ [ t ] [ next+rest [ push-next ] [ (rewrite) ] bi* ] } }
switch ;
: rewrite ( string -- string )

2
extra/match/match.factor
View File

@ -54,7 +54,7 @@ MACRO: match-cond ( assoc -- )
: replace-patterns ( object -- result )
{
{ [ dup number? ] [ ] }
{ [ dup number? ] [ ] }
{ [ dup match-var? ] [ get ] }
{ [ dup sequence? ] [ [ replace-patterns ] map ] }
{ [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }

2
extra/ogg/ogg.factor
View File

@ -104,7 +104,7 @@ FUNCTION: int ogg_stream_flush ( ogg_stream_state* os, ogg_page* og ) ;
FUNCTION: int ogg_sync_init ( ogg_sync_state* oy ) ;
FUNCTION: int ogg_sync_clear ( ogg_sync_state* oy ) ;
FUNCTION: int ogg_sync_reset ( ogg_sync_state* oy ) ;
FUNCTION: int ogg_sync_destroy ( ogg_sync_state* oy ) ;
FUNCTION: int ogg_sync_destroy ( ogg_sync_state* oy ) ;
FUNCTION: void* ogg_sync_buffer ( ogg_sync_state* oy, long size ) ;
FUNCTION: int ogg_sync_wrote ( ogg_sync_state* oy, long bytes ) ;

12
extra/ogg/vorbis/vorbis.factor
View File

@ -100,19 +100,19 @@ FUNCTION: double vorbis_granule_time ( vorbis_dsp_state* v, longlong granulepo
FUNCTION: int vorbis_analysis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ;
FUNCTION: int vorbis_commentheader_out ( vorbis_comment* vc, ogg_packet* op ) ;
FUNCTION: int vorbis_analysis_headerout ( vorbis_dsp_state* v,
vorbis_comment* vc,
ogg_packet* op,
ogg_packet* op_comm,
ogg_packet* op_code ) ;
vorbis_comment* vc,
ogg_packet* op,
ogg_packet* op_comm,
ogg_packet* op_code ) ;
FUNCTION: float** vorbis_analysis_buffer ( vorbis_dsp_state* v, int vals ) ;
FUNCTION: int vorbis_analysis_wrote ( vorbis_dsp_state* v, int vals ) ;
FUNCTION: int vorbis_analysis_blockout ( vorbis_dsp_state* v, vorbis_block* vb ) ;
FUNCTION: int vorbis_analysis ( vorbis_block* vb, ogg_packet* op ) ;
FUNCTION: int vorbis_bitrate_addblock ( vorbis_block* vb ) ;
FUNCTION: int vorbis_bitrate_flushpacket ( vorbis_dsp_state* vd,
ogg_packet* op ) ;
ogg_packet* op ) ;
FUNCTION: int vorbis_synthesis_headerin ( vorbis_info* vi, vorbis_comment* vc,
ogg_packet* op ) ;
ogg_packet* op ) ;
FUNCTION: int vorbis_synthesis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ;
FUNCTION: int vorbis_synthesis_restart ( vorbis_dsp_state* v ) ;
FUNCTION: int vorbis_synthesis ( vorbis_block* vb, ogg_packet* op ) ;

10
extra/opengl/gl/gl.factor
View File

@ -1014,7 +1014,7 @@ FUNCTION: void glTexImage1D ( GLenum target, GLint level, GLint internalFormat,
FUNCTION: void glTexImage2D ( GLenum target, GLint level, GLint internalFormat,
GLsizei width, GLsizei height, GLint border,
GLenum format, GLenum type, GLvoid* pixels ) ;
GLenum format, GLenum type, GLvoid* pixels ) ;
FUNCTION: void glGetTexImage ( GLenum target, GLint level, GLenum format,
GLenum type, GLvoid* pixels ) ;
@ -1039,14 +1039,14 @@ FUNCTION: void glTexSubImage1D ( GLenum target, GLint level, GLint xoffset, GLsi
FUNCTION: void glTexSubImage2D ( GLenum target, GLint level, GLint xoffset, GLint yoffset,
GLsizei width, GLsizei height, GLenum format,
GLenum type, GLvoid* pixels ) ;
GLenum type, GLvoid* pixels ) ;
FUNCTION: void glCopyTexImage1D ( GLenum target, GLint level, GLenum internalformat,
GLint x, GLint y, GLsizei width, GLint border ) ;
FUNCTION: void glCopyTexImage2D ( GLenum target, GLint level, GLenum internalformat,
GLint x, GLint y,
GLsizei width, GLsizei height, GLint border ) ;
GLsizei width, GLsizei height, GLint border ) ;
FUNCTION: void glCopyTexSubImage1D ( GLenum target, GLint level, GLint xoffset,
GLint x, GLint y, GLsizei width ) ;
@ -1064,10 +1064,10 @@ FUNCTION: void glMap1f ( GLenum target, GLfloat u1, GLfloat u2,
FUNCTION: void glMap2d ( GLenum target, GLdouble u1, GLdouble u2, GLint ustride, GLint uorder,
GLdouble v1, GLdouble v2, GLint vstride, GLint vorder,
GLdouble* points ) ;
GLdouble* points ) ;
FUNCTION: void glMap2f ( GLenum target, GLfloat u1, GLfloat u2, GLint ustride, GLint uorder,
GLfloat v1, GLfloat v2, GLint vstride, GLint vorder,
GLfloat* points ) ;
GLfloat* points ) ;
FUNCTION: void glGetMapdv ( GLenum target, GLenum query, GLdouble* v ) ;
FUNCTION: void glGetMapfv ( GLenum target, GLenum query, GLfloat* v ) ;

18
extra/ori/ori.factor
View File

@ -25,19 +25,19 @@ C: <ori> ori
! `Computer Graphics: Principles and Practice'
: Rz ( angle -- Rx ) deg>rad
[ dup cos , dup sin neg , 0 ,
dup sin , dup cos , 0 ,
0 , 0 , 1 , ] 3 make-matrix nip ;
[ dup cos , dup sin neg , 0 ,
dup sin , dup cos , 0 ,
0 , 0 , 1 , ] 3 make-matrix nip ;
: Ry ( angle -- Ry ) deg>rad
[ dup cos , 0 , dup sin ,
0 , 1 , 0 ,
dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
[ dup cos , 0 , dup sin ,
0 , 1 , 0 ,
dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
: Rx ( angle -- Rz ) deg>rad
[ 1 , 0 , 0 ,
0 , dup cos , dup sin neg ,
0 , dup sin , dup cos , ] 3 make-matrix nip ;
[ 1 , 0 , 0 ,
0 , dup cos , dup sin neg ,
0 , dup sin , dup cos , ] 3 make-matrix nip ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/parser-combinators/simple/simple.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings math sequences lazy-lists words
math.parser promises parser-combinators ;
math.parser promises parser-combinators unicode.categories ;
IN: parser-combinators.simple
: 'digit' ( -- parser )

5
extra/peg/ebnf/ebnf.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg ;
quotations vectors namespaces math assocs continuations peg
unicode.categories ;
IN: peg.ebnf
TUPLE: ebnf-non-terminal symbol ;
@ -99,7 +100,7 @@ M: ebnf (generate-parser) ( ast -- id )
DEFER: 'rhs'
: 'non-terminal' ( -- parser )
CHAR: a CHAR: z range repeat1 [ >string <ebnf-non-terminal> ] action ;
CHAR: a CHAR: z range "-" token [ first ] action 2array choice repeat1 [ >string <ebnf-non-terminal> ] action ;
: 'terminal' ( -- parser )
"'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;

3
extra/peg/peg.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
vectors arrays combinators.lib memoize math.parser match ;
vectors arrays combinators.lib memoize math.parser match
unicode.categories ;
IN: peg
TUPLE: parse-result remaining ast ;

264
extra/postgresql/libpq/libpq.factor
View File

@ -17,44 +17,44 @@ IN: postgresql.libpq
>>
! ConnSatusType
: CONNECTION_OK HEX: 0 ; inline
: CONNECTION_BAD HEX: 1 ; inline
: CONNECTION_STARTED HEX: 2 ; inline
: CONNECTION_MADE HEX: 3 ; inline
: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
: CONNECTION_AUTH_OK HEX: 5 ; inline
: CONNECTION_SETENV HEX: 6 ; inline
: CONNECTION_SSL_STARTUP HEX: 7 ; inline
: CONNECTION_NEEDED HEX: 8 ; inline
: CONNECTION_OK HEX: 0 ; inline
: CONNECTION_BAD HEX: 1 ; inline
: CONNECTION_STARTED HEX: 2 ; inline
: CONNECTION_MADE HEX: 3 ; inline
: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
: CONNECTION_AUTH_OK HEX: 5 ; inline
: CONNECTION_SETENV HEX: 6 ; inline
: CONNECTION_SSL_STARTUP HEX: 7 ; inline
: CONNECTION_NEEDED HEX: 8 ; inline
! PostgresPollingStatusType
: PGRES_POLLING_FAILED HEX: 0 ; inline
: PGRES_POLLING_READING HEX: 1 ; inline
: PGRES_POLLING_WRITING HEX: 2 ; inline
: PGRES_POLLING_OK HEX: 3 ; inline
: PGRES_POLLING_ACTIVE HEX: 4 ; inline
: PGRES_POLLING_FAILED HEX: 0 ; inline
: PGRES_POLLING_READING HEX: 1 ; inline
: PGRES_POLLING_WRITING HEX: 2 ; inline
: PGRES_POLLING_OK HEX: 3 ; inline
: PGRES_POLLING_ACTIVE HEX: 4 ; inline
! ExecStatusType;
: PGRES_EMPTY_QUERY HEX: 0 ; inline
: PGRES_COMMAND_OK HEX: 1 ; inline
: PGRES_TUPLES_OK HEX: 2 ; inline
: PGRES_COPY_OUT HEX: 3 ; inline
: PGRES_COPY_IN HEX: 4 ; inline
: PGRES_BAD_RESPONSE HEX: 5 ; inline
: PGRES_NONFATAL_ERROR HEX: 6 ; inline
: PGRES_FATAL_ERROR HEX: 7 ; inline
: PGRES_EMPTY_QUERY HEX: 0 ; inline
: PGRES_COMMAND_OK HEX: 1 ; inline
: PGRES_TUPLES_OK HEX: 2 ; inline
: PGRES_COPY_OUT HEX: 3 ; inline
: PGRES_COPY_IN HEX: 4 ; inline
: PGRES_BAD_RESPONSE HEX: 5 ; inline
: PGRES_NONFATAL_ERROR HEX: 6 ; inline
: PGRES_FATAL_ERROR HEX: 7 ; inline
! PGTransactionStatusType;
: PQTRANS_IDLE HEX: 0 ; inline
: PQTRANS_ACTIVE HEX: 1 ; inline
: PQTRANS_INTRANS HEX: 2 ; inline
: PQTRANS_INERROR HEX: 3 ; inline
: PQTRANS_UNKNOWN HEX: 4 ; inline
: PQTRANS_IDLE HEX: 0 ; inline
: PQTRANS_ACTIVE HEX: 1 ; inline
: PQTRANS_INTRANS HEX: 2 ; inline
: PQTRANS_INERROR HEX: 3 ; inline
: PQTRANS_UNKNOWN HEX: 4 ; inline
! PGVerbosity;
: PQERRORS_TERSE HEX: 0 ; inline
: PQERRORS_DEFAULT HEX: 1 ; inline
: PQERRORS_VERBOSE HEX: 2 ; inline
: PQERRORS_TERSE HEX: 0 ; inline
: PQERRORS_DEFAULT HEX: 1 ; inline
: PQERRORS_VERBOSE HEX: 2 ; inline
TYPEDEF: int size_t
@ -81,7 +81,7 @@ LIBRARY: postgresql
! Exported functions of libpq
! === in fe-connect.c ===
! === in fe-connect.c ===
! make a new client connection to the backend
! Asynchronous (non-blocking)
@ -91,12 +91,12 @@ FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ;
! Synchronous (blocking)
FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ;
FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport,
char* pgoptions, char* pgtty,
char* dbName,
char* login, char* pwd ) ;
char* pgoptions, char* pgtty,
char* dbName,
char* login, char* pwd ) ;
: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
f f PQsetdbLogin ;
f f PQsetdbLogin ;
! close the current connection and free the PGconn data structure
FUNCTION: void PQfinish ( PGconn* conn ) ;
@ -112,7 +112,7 @@ FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
! parameters
!
! Asynchronous (non-blocking)
FUNCTION: int PQresetStart ( PGconn* conn ) ;
FUNCTION: int PQresetStart ( PGconn* conn ) ;
FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
! Synchronous (blocking)
@ -125,7 +125,7 @@ FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ;
FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ;
! issue a cancel request
FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
! Accessor functions for PGconn objects
FUNCTION: char* PQdb ( PGconn* conn ) ;
@ -138,14 +138,14 @@ FUNCTION: char* PQoptions ( PGconn* conn ) ;
FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ;
FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ;
FUNCTION: char* PQparameterStatus ( PGconn* conn,
char* paramName ) ;
FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
FUNCTION: int PQServerVersion ( PGconn* conn ) ;
char* paramName ) ;
FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
FUNCTION: int PQServerVersion ( PGconn* conn ) ;
FUNCTION: char* PQerrorMessage ( PGconn* conn ) ;
FUNCTION: int PQsocket ( PGconn* conn ) ;
FUNCTION: int PQbackendPID ( PGconn* conn ) ;
FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
FUNCTION: int PQsocket ( PGconn* conn ) ;
FUNCTION: int PQbackendPID ( PGconn* conn ) ;
FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
! May not be compiled into libpq
! Get the SSL structure associated with a connection
@ -156,7 +156,7 @@ FUNCTION: void PQinitSSL ( int do_init ) ;
! Set verbosity for PQerrorMessage and PQresultErrorMessage
FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
PGVerbosity verbosity ) ;
PGVerbosity verbosity ) ;
! Enable/disable tracing
FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
@ -171,11 +171,11 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
! Override default notice handling routines
! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
! PQnoticeReceiver proc,
! void* arg ) ;
! PQnoticeReceiver proc,
! void* arg ) ;
! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
! PQnoticeProcessor proc,
! void* arg ) ;
! PQnoticeProcessor proc,
! void* arg ) ;
! END BROKEN
! === in fe-exec.c ===
@ -183,107 +183,107 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
! Simple synchronous query
FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ;
FUNCTION: PGresult* PQexecParams ( PGconn* conn,
char* command,
int nParams,
Oid* paramTypes,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
char* command,
int nParams,
Oid* paramTypes,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
FUNCTION: PGresult* PQprepare ( PGconn* conn, char* stmtName,
char* query, int nParams,
Oid* paramTypes ) ;
FUNCTION: PGresult* PQexecPrepared ( PGconn* conn,
char* stmtName,
int nParams,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
char* stmtName,
int nParams,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
! Interface for multiple-result or asynchronous queries
FUNCTION: int PQsendQuery ( PGconn* conn, char* query ) ;
FUNCTION: int PQsendQueryParams ( PGconn* conn,
char* command,
int nParams,
Oid* paramTypes,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
char* command,
int nParams,
Oid* paramTypes,
char** paramValues,
int* paramLengths,
int* paramFormats,
int resultFormat ) ;
FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, char* stmtName,
char* query, int nParams,
Oid* paramTypes ) ;
FUNCTION: int PQsendQueryPrepared ( PGconn* conn,
char* stmtName,
int nParams,
char** paramValues,
int *paramLengths,
int *paramFormats,
int resultFormat ) ;
char* stmtName,
int nParams,
char** paramValues,
int *paramLengths,
int *paramFormats,
int resultFormat ) ;
FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
! Routines for managing an asynchronous query
FUNCTION: int PQisBusy ( PGconn* conn ) ;
FUNCTION: int PQconsumeInput ( PGconn* conn ) ;
FUNCTION: int PQisBusy ( PGconn* conn ) ;
FUNCTION: int PQconsumeInput ( PGconn* conn ) ;
! LISTEN/NOTIFY support
FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ;
! Routines for copy in/out
FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
! Deprecated routines for copy in/out
FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ;
FUNCTION: int PQputline ( PGconn* conn, char* string ) ;
FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
FUNCTION: int PQendcopy ( PGconn* conn ) ;
FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ;
FUNCTION: int PQputline ( PGconn* conn, char* string ) ;
FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
FUNCTION: int PQendcopy ( PGconn* conn ) ;
! Set blocking/nonblocking connection to the backend
FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ;
FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ;
FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
! Force the write buffer to be written (or at least try)
FUNCTION: int PQflush ( PGconn* conn ) ;
FUNCTION: int PQflush ( PGconn* conn ) ;
!
! * "Fast path" interface --- not really recommended for application
! * use
!
FUNCTION: PGresult* PQfn ( PGconn* conn,
int fnid,
int* result_buf,
int* result_len,
int result_is_int,
PQArgBlock* args,
int nargs ) ;
int fnid,
int* result_buf,
int* result_len,
int result_is_int,
PQArgBlock* args,
int nargs ) ;
! Accessor functions for PGresult objects
FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
FUNCTION: char* PQresStatus ( ExecStatusType status ) ;
FUNCTION: char* PQresultErrorMessage ( PGresult* res ) ;
FUNCTION: char* PQresultErrorField ( PGresult* res, int fieldcode ) ;
FUNCTION: int PQntuples ( PGresult* res ) ;
FUNCTION: int PQnfields ( PGresult* res ) ;
FUNCTION: int PQbinaryTuples ( PGresult* res ) ;
FUNCTION: int PQntuples ( PGresult* res ) ;
FUNCTION: int PQnfields ( PGresult* res ) ;
FUNCTION: int PQbinaryTuples ( PGresult* res ) ;
FUNCTION: char* PQfname ( PGresult* res, int field_num ) ;
FUNCTION: int PQfnumber ( PGresult* res, char* field_name ) ;
FUNCTION: Oid PQftable ( PGresult* res, int field_num ) ;
FUNCTION: int PQftablecol ( PGresult* res, int field_num ) ;
FUNCTION: int PQfformat ( PGresult* res, int field_num ) ;
FUNCTION: Oid PQftype ( PGresult* res, int field_num ) ;
FUNCTION: int PQfsize ( PGresult* res, int field_num ) ;
FUNCTION: int PQfmod ( PGresult* res, int field_num ) ;
FUNCTION: int PQfnumber ( PGresult* res, char* field_name ) ;
FUNCTION: Oid PQftable ( PGresult* res, int field_num ) ;
FUNCTION: int PQftablecol ( PGresult* res, int field_num ) ;
FUNCTION: int PQfformat ( PGresult* res, int field_num ) ;
FUNCTION: Oid PQftype ( PGresult* res, int field_num ) ;
FUNCTION: int PQfsize ( PGresult* res, int field_num ) ;
FUNCTION: int PQfmod ( PGresult* res, int field_num ) ;
FUNCTION: char* PQcmdStatus ( PGresult* res ) ;
FUNCTION: char* PQoidStatus ( PGresult* res ) ;
FUNCTION: Oid PQoidValue ( PGresult* res ) ;
FUNCTION: Oid PQoidValue ( PGresult* res ) ;
FUNCTION: char* PQcmdTuples ( PGresult* res ) ;
FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
! Delete a PGresult
FUNCTION: void PQclear ( PGresult* res ) ;
@ -313,7 +313,7 @@ FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
! These forms are deprecated!
FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ;
FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
size_t* bytealen ) ;
size_t* bytealen ) ;
! === in fe-print.c ===
@ -321,41 +321,41 @@ FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ;
! really old printing routines
FUNCTION: void PQdisplayTuples ( PGresult* res,
FILE* fp,
int fillAlign,
char* fieldSep,
int printHeader,
int quiet ) ;
FILE* fp,
int fillAlign,
char* fieldSep,
int printHeader,
int quiet ) ;
FUNCTION: void PQprintTuples ( PGresult* res,
FILE* fout,
int printAttName,
int terseOutput,
int width ) ;
FILE* fout,
int printAttName,
int terseOutput,
int width ) ;
! === in fe-lobj.c ===
! Large-object access routines
FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
FUNCTION: int lo_close ( PGconn* conn, int fd ) ;
FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ;
! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
FUNCTION: int lo_tell ( PGconn* conn, int fd ) ;
FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ;
FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ;
FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
FUNCTION: int lo_close ( PGconn* conn, int fd ) ;
FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ;
! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
FUNCTION: int lo_tell ( PGconn* conn, int fd ) ;
FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ;
FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ;
FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
! === in fe-misc.c ===
! Determine length of multibyte encoded char at *s
FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
! Determine display length of multibyte encoded char at *s
FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
! Get encoding id from environment variable PGCLIENTENCODING
FUNCTION: int PQenv2encoding ( ) ;
FUNCTION: int PQenv2encoding ( ) ;

3
extra/project-euler/017/017.factor
View File

@ -1,6 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel math.ranges math.text.english sequences strings ;
USING: combinators.lib kernel math.ranges math.text.english sequences strings
ascii ;
IN: project-euler.017
! http://projecteuler.net/index.php?section=problems&id=17

2
extra/project-euler/022/022.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel math math.parser namespaces sequences sorting splitting
strings system vocabs ;
strings system vocabs ascii ;
IN: project-euler.022
! http://projecteuler.net/index.php?section=problems&id=22

2
extra/prolog/prolog.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays vectors namespaces math strings
combinators continuations quotations io assocs ;
combinators continuations quotations io assocs ascii ;
IN: prolog

2
extra/regexp/regexp.factor
View File

@ -1,7 +1,7 @@
USING: arrays combinators kernel lazy-lists math math.parser
namespaces parser parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings
assocs prettyprint.backend memoize ;
assocs prettyprint.backend memoize unicode.case unicode.categories ;
USE: io
IN: regexp

2
extra/roman/roman.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math math.vectors namespaces
quotations sequences sequences.lib sequences.private strings ;
quotations sequences sequences.lib sequences.private strings unicode.case ;
IN: roman
<PRIVATE

2
extra/rot13/rot13.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences strings io combinators ;
USING: kernel math sequences strings io combinators ascii ;
IN: rot13
: rotate ( ch base -- ch ) tuck - 13 + 26 mod + ;

4
extra/sequences/lib/lib.factor
View File

@ -1,6 +1,6 @@
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors ;
USING: arrays math.parser sorting strings ;
random sequences.private shuffle math.functions mirrors
arrays math.parser sorting strings ascii ;
IN: sequences.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/springies/springies.factor
View File

@ -183,7 +183,7 @@ C: <spring> spring
{ [ dup below? ] [ bounce-bottom ] }
{ [ dup beyond-left? ] [ bounce-left ] }
{ [ dup beyond-right? ] [ bounce-right ] }
{ [ t ] [ drop ] } }
{ [ t ] [ drop ] } }
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

4
extra/springies/ui/ui.factor
View File

@ -51,10 +51,10 @@ DEFER: maybe-loop
: springies-window* ( -- )
C[ display ] <slate> >slate
{ 800 600 } slate> set-slate-dim
{ 800 600 } slate> set-slate-dim
C[ { 500 500 } >world-size loop on [ run ] in-thread ]
slate> set-slate-graft
C[ loop off ] slate> set-slate-ungraft
C[ loop off ] slate> set-slate-ungraft
slate> "Springies" open-window ;

1
extra/sqlite/authors.txt
View File

@ -1 +0,0 @@
Chris Double

1
extra/sqlite/lib/authors.txt
View File

@ -1 +0,0 @@
Chris Double

120
extra/sqlite/lib/lib.factor
View File

@ -1,120 +0,0 @@
! Copyright (C) 2005 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
!
! An interface to the sqlite database. Tested against sqlite v3.1.3.
! Remeber to pass the following to factor:
! -libraries:sqlite=libsqlite3.so
!
! Not all functions have been wrapped yet. Only those directly involving
! executing SQL calls and obtaining results.
!
IN: sqlite.lib
USING: alien compiler kernel math namespaces sequences strings alien.syntax
system combinators ;
<<
"sqlite" {
{ [ win32? ] [ "sqlite3.dll" ] }
{ [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
{ [ unix? ] [ "libsqlite3.so" ] }
} cond "cdecl" add-library
>>
! Return values from sqlite functions
: SQLITE_OK 0 ; inline ! Successful result
: SQLITE_ERROR 1 ; inline ! SQL error or missing database
: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite
: SQLITE_PERM 3 ; inline ! Access permission denied
: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort
: SQLITE_BUSY 5 ; inline ! The database file is locked
: SQLITE_LOCKED 6 ; inline ! A table in the database is locked
: SQLITE_NOMEM 7 ; inline ! A malloc() failed
: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database
: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt()
: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred
: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed
: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found
: SQLITE_FULL 13 ; inline ! Insertion failed because database is full
: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file
: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error
: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty
: SQLITE_SCHEMA 17 ; inline ! The database schema changed
: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table
: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation
: SQLITE_MISMATCH 20 ; inline ! Data type mismatch
: SQLITE_MISUSE 21 ; inline ! Library used incorrectly
: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host
: SQLITE_AUTH 23 ; inline ! Authorization denied
: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error
: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range
: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file
: sqlite-error-messages ( -- seq ) {
"Successful result"
"SQL error or missing database"
"An internal logic error in SQLite"
"Access permission denied"
"Callback routine requested an abort"
"The database file is locked"
"A table in the database is locked"
"A malloc() failed"
"Attempt to write a readonly database"
"Operation terminated by sqlite_interrupt()"
"Some kind of disk I/O error occurred"
"The database disk image is malformed"
"(Internal Only) Table or record not found"
"Insertion failed because database is full"
"Unable to open the database file"
"Database lock protocol error"
"(Internal Only) Database table is empty"
"The database schema changed"
"Too much data for one row of a table"
"Abort due to contraint violation"
"Data type mismatch"
"Library used incorrectly"
"Uses OS features not supported on host"
"Authorization denied"
"Auxiliary database format error"
"2nd parameter to sqlite3_bind out of range"
"File opened that is not a database file"
} ;
: SQLITE_ROW 100 ; inline ! sqlite_step() has another row ready
: SQLITE_DONE 101 ; inline ! sqlite_step() has finished executing
! Return values from the sqlite3_column_type function
: SQLITE_INTEGER 1 ; inline
: SQLITE_FLOAT 2 ; inline
: SQLITE_TEXT 3 ; inline
: SQLITE_BLOB 4 ; inline
: SQLITE_NULL 5 ; inline
! Values for the 'destructor' parameter of the 'bind' routines.
: SQLITE_STATIC 0 ; inline
: SQLITE_TRANSIENT -1 ; inline
TYPEDEF: void sqlite3
TYPEDEF: void sqlite3_stmt
LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;

87
extra/sqlite/sqlite-docs.factor
View File

@ -1,87 +0,0 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help help.syntax help.markup ;
IN: sqlite
HELP: sqlite-open
{ $values { "filename" "path to sqlite database" }
{ "db" "the database object" }
}
{ $description "Opens the sqlite3 database." }
{ $see-also sqlite-close sqlite-last-insert-rowid } ;
HELP: sqlite-close
{ $values { "db" "the database object" }
}
{ $description "Closes the sqlite3 database." }
{ $see-also sqlite-open sqlite-last-insert-rowid } ;
HELP: sqlite-last-insert-rowid
{ $values { "db" "the database object" }
{ "rowid" "the row number of the last insert" }
}
{ $description "Returns the number of the row of the last statement inserted into the database." }
{ $see-also sqlite-open sqlite-close } ;
HELP: sqlite-prepare
{ $values { "db" "the database object" }
{ "sql" "the SQL statement as a string" }
{ "statement" "the prepared SQL statement" }
}
{ $description "Internally compiles the SQL statement ready to be run by sqlite. The statement is executed and the results iterated over using " { $link sqlite-each } " and " { $link sqlite-map } ". The SQL statement can use named parameters which are later bound to values using " { $link sqlite-bind-text } " and " { $link sqlite-bind-text-by-name } "." }
{ $see-also sqlite-open sqlite-close } ;
HELP: sqlite-bind-text
{ $values { "statement" "a prepared SQL statement" }
{ "index" "the index of the bound parameter in the SQL statement" }
{ "text" "the string value to bind to that column" }
}
{ $description "Binds the text to a parameter in the SQL statement. The parameter to be bound is identified by the index given and the indexes start from one." }
{ $examples { $code "\"people.db\" sqlite-open\n\"select * from people where name=?\" sqlite-prepare\n1 \"chris\" sqlite-bind-text" } }
{ $see-also sqlite-bind-text-by-name } ;
HELP: sqlite-bind-text-by-name
{ $values { "statement" "a prepared SQL statement" }
{ "name" "the name of the bound parameter in the SQL statement" }
{ "text" "the string value to bind to that column" }
}
{ $description "Binds the text to a parameter in the SQL statement. The parameter to be bound is identified by the given name." }
{ $examples { $code "\"people.db\" sqlite-open\n\"select * from people where name=:name\" sqlite-prepare\n\"name\" \"chris\" sqlite-bind-text" } }
{ $see-also sqlite-bind-text } ;
HELP: sqlite-finalize
{ $values { "statement" "a prepared SQL statement" }
}
{ $description "Clean up all resources related to a statement. Once called the statement cannot be used again. All statements must be finalized before closing the database." }
{ $see-also sqlite-close sqlite-prepare } ;
HELP: sqlite-reset
{ $values { "statement" "a prepared SQL statement" }
}
{ $description "Reset a statement so it can be called again, possibly with different bound parameters." }
{ $see-also sqlite-bind-text sqlite-bind-text-by-name } ;
HELP: column-count
{ $values { "statement" "a prepared SQL statement" } { "int" "the number of columns" } }
{ $description "Return the number of columns in each row of the result set of the given statement." }
{ $see-also column-text sqlite-each sqlite-map } ;
HELP: column-text
{ $values { "statement" "a prepared SQL statement" } { "index" "column number indexed from zero" } { "string" "column value" }
}
{ $description "Return the value of the given column, indexed from zero, as a string." }
{ $see-also column-count sqlite-each sqlite-map } ;
HELP: sqlite-each
{ $values { "statement" "a prepared SQL statement" } { "quot" "A quotation with stack effect ( statement -- )" }
}
{ $description "Executes the SQL statement and for each returned row calls the qutotation passing the statement on the stack. The quotation can use " { $link column-text } " to get result values for that row." }
{ $see-also column-count column-text sqlite-map } ;
HELP: sqlite-map
{ $values { "statement" "a prepared SQL statement" } { "quot" "A quotation with stack effect ( statement -- value )" } { "seq" "a new sequence" }
}
{ $description "Executes the SQL statement and for each returned row calls the qutotation passing the statement on the stack. The quotation can use " { $link column-text } " to get result values for that row. The quotation should leave a value on the stack which gets collected and returned in the resulting sequence." }
{ $see-also column-count column-text sqlite-each } ;

69
extra/sqlite/sqlite-tests.factor
View File

@ -1,69 +0,0 @@
! Copyright (C) 2005 Chris Double.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
! Test the sqlite interface
!
! Create a test database like follows:
!
! sqlite3 test.db < test.txt
!
! Then run this file.
USE: sqlite
USE: kernel
USE: io
USE: io.files
USE: prettyprint
: test.db "libs/sqlite/test.db" resource-path ;
: show-people ( statement -- )
dup 0 column-text write " from " write 1 column-text . ;
: run-test ( -- )
test.db sqlite-open
dup "select * from test" sqlite-prepare
dup [ show-people ] sqlite-each
sqlite-finalize
sqlite-close ;
: find-person ( name -- )
test.db sqlite-open ! name db
dup "select * from test where name=?" sqlite-prepare ! name db stmt
[ rot 1 swap sqlite-bind-text ] keep ! db stmt
[ [ 1 column-text . ] sqlite-each ] keep
sqlite-finalize
sqlite-close ;
: find-all ( -- )
test.db sqlite-open ! db
dup "select * from test" sqlite-prepare ! db stmt
[ [ [ 0 column-text ] keep 1 column-text curry ] sqlite-map ] keep
sqlite-finalize
swap sqlite-close ;
: run-test2 ( -- )
test.db sqlite-open
dup "select * from test" sqlite-prepare
dup [ show-people ] ;
run-test

127
extra/sqlite/sqlite.factor
View File

@ -1,127 +0,0 @@
! Copyright (C) 2005 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
! An interface to the sqlite database. Tested against sqlite v3.0.8.
!
! Not all functions have been wrapped yet. Only those directly involving
! executing SQL calls and obtaining results.
!
IN: sqlite
USING: alien compiler kernel namespaces sequences strings sqlite.lib
alien.c-types continuations ;
TUPLE: sqlite-error n message ;
SYMBOL: db
! High level sqlite routines
: sqlite-check-result ( result -- )
#! Check the result from a sqlite call is ok. If it is
#! return, otherwise throw an error.
dup SQLITE_OK = [
drop
] [
dup sqlite-error-messages nth
\ sqlite-error construct-boa throw
] if ;
: sqlite-open ( filename -- db )
#! Open the database referenced by the filename and return
#! a handle to that database. An error is thrown if the database
#! failed to open.
"void*" <c-object> [ sqlite3_open sqlite-check-result ] keep *void* ;
: sqlite-close ( db -- )
#! Close the given database
sqlite3_close sqlite-check-result ;
: sqlite-last-insert-rowid ( db -- rowid )
#! Return the rowid of the last insert
sqlite3_last_insert_rowid ;
: sqlite-prepare ( db sql -- statement )
#! Prepare a SQL statement. Returns the statement which
#! can have values bound to parameters or simply executed.
#! TODO: Support multiple statements in the SQL string.
dup length "void*" <c-object> "void*" <c-object>
[ sqlite3_prepare sqlite-check-result ] 2keep
drop *void* ;
: sqlite-bind-text ( statement index text -- )
#! Bind the text to the parameterized value in the statement.
dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ;
: sqlite-bind-parameter-index ( statement name -- index )
sqlite3_bind_parameter_index ;
: sqlite-bind-text-by-name ( statement name text -- )
>r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
: sqlite-finalize ( statement -- )
#! Clean up all resources related to a statement. Once called
#! the statement cannot be used. All statements must be finalized
#! before closing the database.
sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( statement -- )
#! Reset a statement so it can be called again, possibly with
#! different parameters.
sqlite3_reset sqlite-check-result ;
: column-count ( statement -- int )
#! Given a prepared statement, return the number of
#! columns in each row of the result set of that statement.
sqlite3_column_count ;
: column-text ( statement index -- string )
#! Return the value of the given column, indexed
#! from zero, as a string.
sqlite3_column_text ;
: step-complete? ( step-result -- bool )
#! Return true if the result of a sqlite3_step is
#! such that the iteration has completed (ie. it is
#! SQLITE_DONE). Throw an error if an error occurs.
dup SQLITE_ROW = [
drop f
] [
dup SQLITE_DONE = [
drop t
] [
sqlite-check-result t
] if
] if ;
: sqlite-each ( statement quot -- )
#! Execute the SQL statement, and call the quotation for
#! each row returned from executing the statement with the
#! statement on the top of the stack.
over sqlite3_step step-complete? [
2drop
] [
[ call ] 2keep sqlite-each
] if ; inline
! For comparison, here is the linrec implementation of sqlite-each
! [ drop sqlite3_step step-complete? ]
! [ 2drop ]
! [ 2dup 2slip ]
! [ ] linrec ;
DEFER: (sqlite-map)
: (sqlite-map) ( statement quot seq -- )
pick sqlite3_step step-complete? [
2nip
] [
>r 2dup call r> swap add (sqlite-map)
] if ;
: sqlite-map ( statement quot -- seq )
{ } (sqlite-map) ;
: with-sqlite ( path quot -- )
[
>r sqlite-open db set r>
[ db get sqlite-close ] [ ] cleanup
] with-scope ;

3
extra/sqlite/test.txt
View File

@ -1,3 +0,0 @@
create table test (name varchar(30), address varchar(30));
insert into test values('John', 'America');
insert into test values('Jane', 'New Zealand');

1
extra/sqlite/tuple-db/authors.txt
View File

@ -1 +0,0 @@
Chris Double

131
extra/sqlite/tuple-db/tuple-db-docs.factor
View File

@ -1,131 +0,0 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help sqlite help.syntax help.markup ;
IN: sqlite.tuple-db
ARTICLE: { "sqlite" "tuple-db-loading" } "Loading"
"The quickest way to get up and running with this library is to use the vocabulary:"
{ $code "USING: sqlite sqlite.tuple-db ;\n" }
"Some simple tests can be run to check that everything is working ok:"
{ $code "\"libs/sqlite\" test-module" } ;
ARTICLE: { "sqlite" "tuple-db-usage" } "Basic Usage"
"This library can be used for storing simple Factor tuples in a sqlite database. In its current form the tuples must not contain references to other tuples and should not have a delegate set."
$nl
"This document will use the following tuple for demonstration purposes:"
{ $code "TUPLE: person name surname phone ;" }
"The sqlite database to store tuples must be created, or an existing one opened. This is done using the " { $link sqlite-open } " word. If the database does not exist then it is created. The examples in this document store the database pointer in a variable called 'db':"
{ $code "SYMBOL: db\n\"example.db\" sqlite-open db set-global" } ;
ARTICLE: { "sqlite" "tuple-db-mappings" } "Tuple Mappings"
"Each tuple has a 'mapping' tuple associated with it. The 'mapping' stores information about what table the tuple will be stored in, the datatypes of the tuple slots, etc. A mapping must be created before a tuple can be stored in a database. A default mapping is easily created using " { $link default-mapping } ". Given the tuple class, this will use reflection to get the slots of it, assume that all slots are of database type 'text', and store the tuple objects in a table with the same name as the tuple."
$nl
"The following shows how to create the default mapping for the 'person' tuple, and how to register that mapping so the 'tuple-db' system can know how to handle 'person' instances:"
{ $code "person default-mapping set-mapping" } ;
ARTICLE: { "sqlite" "tuple-db-create" } "Creating the table"
"The table used to store tuple instances may need to be created. This can be done manually using the external sqlite program or via " { $link create-tuple-table } ":"
{ $code "db get person create-tuple-table" }
"The SQL used to create the table is produced internally by " { $link create-sql } ". This is a generic word dispatched on the mapping object, and could be specialised if needed. If you wish to see the SQL used to create the table, use the following code:"
{ $code "person get-mapping create-sql .\n => \"create table person (name text,surname text,phone text);\"" } ;
ARTICLE: { "sqlite" "tuple-db-insert" } "Inserting instances"
"The " { $link insert-tuple } " word will store instances of a tuple into the database table defined by its mapping object:"
{ $code "db get \"John\" \"Smith\" \"123-456-789\" <person> insert-tuple" }
{ $link insert-tuple } " internally uses the " { $link insert-sql } " word to produce the SQL used to store the tuple. Like " { $link create-sql } ", it is a generic word specialized on the mapping object. You can call it directly to see what SQL is generated:"
{ $code "person get-mapping insert-sql .\n => \"insert into person values(:name,:surname,:phone);\"" }
"Notice that the SQL uses named parameters. These parameters are bound to the values stored in the tuple object when the SQL is compiled. This helps prevent SQL injection techniques."
$nl
"When " { $link insert-sql } " is run, it adds a delegate to the tuple being stored. The delegate is of type 'persistent' and holds the row id of the tuple in its 'key' slot. This way the exact record can be updated or retrieved later. The following demonstates this fact:"
{ $code "\"Mandy\" \"Jones\" \"987-654-321\" <person> dup .\n => T{ person f \"Mandy\" \"Jones\" \"987-654-321\" }\ndb get over insert-tuple .\n => T{ person T{ persistent ... 2 } \"Mandy\" \"Jones\" \"987-654-321\" }" }
"The '2' in the above example is the row id of the record inserted. We can go into the 'sqlite' command and view this record:"
{ $code " $ sqlite3 example.db\n SQLite version 3.0.8\n Enter \".help\" for instructions\n sqlite> select ROWID,* from person;\n 1|John|Smith|123-456-789\n 2|Mandy|Jones|987-654-321\n sqlite>" } ;
ARTICLE: { "sqlite" "tuple-db-finding" } "Finding instances"
"The " { $link find-tuples } " word is used to return tuples populated with data already existing in the database. As well as the database objcet, it takes a tuple that should be populated only with the fields that should be matched in the database. All fields you do not wish to match against should be set to 'f':"
{ $code "db get f \"Smith\" f <person> find-tuples .\n => { T{ person # \"John\" \"Smith\" \"123-456-789\" } }\ndb get \"Mandy\" f f <person> find-tuples .\n => { T{ person # \"Mandy\" \"Jones\" \"987-654-321\" } }\ndb get \"Joe\" f f <person> find-tuples .\n => { }" }
"Notice that if no matching tuples are found then an empty sequence is returned. The returned tuples also have their delegate set to 'persistent' with the correct row id set as the key. This can be used to later update the tuples with new information and store them in the database." ;
ARTICLE: { "sqlite" "tuple-db-updating" } "Updating instances"
"Given a tuple that has the 'persistent' delegate with the row id set as the key, you can update this specific record using " { $link update-tuple } ":"
{ $code "db get f \"Smith\" f <person> find-tuples dup .\n => { T{ person # \"John\" \"Smith\" \"123-456-789\" } }\nfirst { \"999-999-999\" swap set-person-phone ] keep dup .\n => T{ person T{ persistent f # \"1\" } \"John\" \"Smith\" \"999-999-999\" ...\n db get swap update-tuple" }
"Using the 'sqlite' command from the system shell you can see the record was updated:"
{ $code " $ sqlite3 example.db\n SQLite version 3.0.8\n Enter \".help\" for instructions\n sqlite> select ROWID,* from person;\n 1|John|Smith|999-999-999\n 2|Mandy|Jones|987-654-321\n sqlite>" } ;
ARTICLE: { "sqlite" "tuple-db-inserting-or-updating" } "Inserting or Updating instances"
"The " { $link save-tuple } " word can be used to insert a tuple if it has not already been stored in the database, or update it if it already exists. Whether to insert or update is decided by the existance of the 'persistent' delegate:"
{ $code "\"Mary\" \"Smith\" \"111-111-111\" <person> dup .\n => T{ person f \"Mary\" \"Smith\" \"111-111-111\" }\n! This will insert the tuple\ndb get over save-tuple dup .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"111-111-111\" ...\n[ \"222-222-222\" swap set-person-phone ] keep dup .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"222-222-222\" ...\n! This will update the tuple\ndb get over save-tuple .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"222-222-222\" ..." } ;
ARTICLE: { "sqlite" "tuple-db-deleting" } "Deleting instances"
"Given a tuple with the delegate set to 'persistent' (ie. One already stored in the database) you can delete it from the database with " { $link delete-tuple } ":"
{ $code "db get f \"Smith\" f <person> find-tuples [ db get swap delete-tuple ] each" } ;
ARTICLE: { "sqlite" "tuple-db-closing" } "Closing the database"
"It's important to close the sqlite database when you've finished using it. The word for this is " { $link sqlite-close } ":"
{ $code "db get sqlite-close" } ;
ARTICLE: { "sqlite" "tuple-db" } "Tuple Database Library"
"The version of sqlite required by this library is version 3 or greater. This library allows storing Factor tuples in a sqlite database. It provides words to create, read update and delete these entries as well as simple searching."
$nl
"The library is in a very early state and is likely to change quite a bit in the near future. Its most notable omission is it cannot currently handle relationships between tuples."
{ $subsection { "sqlite" "tuple-db-loading" } }
{ $subsection { "sqlite" "tuple-db-usage" } }
{ $subsection { "sqlite" "tuple-db-mappings" } }
{ $subsection { "sqlite" "tuple-db-create" } }
{ $subsection { "sqlite" "tuple-db-insert" } }
{ $subsection { "sqlite" "tuple-db-finding" } }
{ $subsection { "sqlite" "tuple-db-updating" } }
{ $subsection { "sqlite" "tuple-db-inserting-or-updating" } }
{ $subsection { "sqlite" "tuple-db-deleting" } }
{ $subsection { "sqlite" "tuple-db-closing" } }
;
HELP: default-mapping
{ $values { "class" "symbol for the tuple class" }
{ "mapping" "a mapping object" }
}
{ $description "Given a tuple class, create a default mappings object. This is used to associate field names in the tuple with SQL statement field names, etc." }
{ $see-also { "sqlite" "tuple-db" } set-mapping } ;
HELP: set-mapping
{ $values { "mapping" "a mapping object" }
}
{ $description "Store a database mapping so that the tuple-db system knows how to store instances of the tuple in the database." }
{ $see-also { "sqlite" "tuple-db" } default-mapping } ;
HELP: create-tuple-table
{ $values { "db" "a database object" } { "class" "symbol for the tuple class" }
}
{ $description "Create the database table to store intances of the given tuple." }
{ $see-also { "sqlite" "tuple-db" } default-mapping get-mapping } ;
HELP: insert-tuple
{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" }
}
{ $description "Insert the tuple instance into the database. It is assumed that this tuple does not currently exist in the database." }
{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ;
HELP: find-tuples
{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } { "seq" "a sequence of tuples" } }
{ $description "Return a sequence of all tuples in the database that match the tuple provided as a template. All fields in the tuple must match the entries in the database, except for those set to 'f'." }
{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ;
HELP: update-tuple
{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" }
}
{ $description "Update the database record for this tuple instance. The tuple must have previously been obtained from the database, or inserted into it. It must have a delegate of 'persistent' with the key field set (which is done by the find and insert operations)." }
{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ;
HELP: save-tuple
{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" }
}
{ $description "Insert or Update the tuple instance depending on whether it has a persistent delegate." }
{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ;
HELP: delete-tuple
{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" }
}
{ $description "Delete this tuple instance from the database. The tuple must have previously been obtained from the database, or inserted into it. It must have a delegate of 'persistent' with the key field set (which is done by the find and insert operations)." }
{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ;
ABOUT: { "sqlite" "tuple-db" }

39
extra/sqlite/tuple-db/tuple-db-tests.factor
View File

@ -1,39 +0,0 @@
! Copyright (C) 2005 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
IN: temporary
USING: io io.files kernel sequences namespaces
hashtables sqlite sqlite.tuple-db math words tools.test ;
TUPLE: testdata one two ;
C: <testdata> testdata
testdata default-mapping set-mapping
"libs/sqlite/test.db" resource-path [
db get testdata create-tuple-table
[ "two" { } ] [
db get "one" "two" <testdata> insert-tuple
db get "one" f <testdata> find-tuples
first [ testdata-two ] keep
db get swap delete-tuple
db get "one" f <testdata> find-tuples
] unit-test
[ "junk" ] [
db get "one" "two" <testdata> insert-tuple
db get "one" f <testdata> find-tuples
first
"junk" over set-testdata-two
db get swap update-tuple
db get "one" f <testdata> find-tuples
first [ testdata-two ] keep
db get swap delete-tuple
] unit-test
db get testdata drop-tuple-table
] with-sqlite

270
extra/sqlite/tuple-db/tuple-db.factor
View File

@ -1,270 +0,0 @@
! Copyright (C) 2005 Chris Double.
!
! A tuple that is persistent has its delegate set as 'persistent'.
! 'persistent' holds the numeric rowid for that tuple in its table.
IN: sqlite.tuple-db
USING: io kernel sequences namespaces slots classes slots.private
assocs math words generic sqlite math.parser ;
! Each slot in a tuple that is storable in the database has
! an instance of a db-field object the gives the name of the
! database table and slot number in the tuple object of that field.
TUPLE: db-field name bind-name slot type ;
C: <db-field> db-field
! The mapping tuple holds information on how the slots of
! a tuple are mapped to the fields of a sqlite database.
TUPLE: mapping tuple table fields one-to-one one-to-many ;
C: <mapping> mapping
: sanitize ( string -- string )
#! Convert a string so it can be used as a table or field name.
clone
H{ { CHAR: - CHAR: _ } { CHAR: ? CHAR: p } }
over substitute ;
: tuple-fields ( class -- seq )
#! Given a tuple class return a list of the fields
#! within that tuple. Ignores the delegate field.
"slots" word-prop 1 tail [
[ slot-spec-name sanitize dup ":" swap append ] keep
slot-spec-offset
"text"
<db-field>
] map ;
: default-mapping ( class -- mapping )
#! Given a tuple class, create a default mappings object. It assumes
#! there are no one-to-one or one-to-many relationships.
dup [ word-name sanitize ] keep tuple-fields f f <mapping> ;
! The mappings variable holds a hashtable mapping the tuple symbol
! to the mapping object, describing how that tuple is stored
! in the database.
SYMBOL: mappings
: init-mappings ( -- )
H{ } mappings set-global ;
: get-mappings ( -- hashtable )
mappings get-global ;
: set-mapping ( mapping -- )
#! Store a database mapping so that the persistence system
#! knows how to store instances of the relevant tuple in the database.
dup mapping-tuple get-mappings set-at ;
: get-mapping ( class -- mapping )
#! Return the database mapping for the given tuple class.
get-mappings at ;
! The 'persistent' tuple will be set to the delegate of any tuple
! instance stored in the database. It contains the database key
! of the row in the database table for the instance or 'f' if it has
! not yet been stored in the database. It also contains the 'mapping'
! object used to translate the fields of the tuple to the database fields.
TUPLE: persistent mapping key ;
: <persistent> ( tuple -- persistent )
persistent construct-empty
>r class get-mapping r>
[ set-persistent-mapping ] keep ;
: make-persistent ( tuple -- tuple )
#! Convert the tuple into something that can be stored
#! into a database by setting its delegate to 'persistent'.
[ <persistent> ] keep
[ set-delegate ] keep ;
: comma-fields ( mapping quot -- string )
#! Given a mapping, call quot on each field in
#! the mapping. The contents of quot should call ',' or '%'
#! to generate output. The output of each quot call
#! seperated by commas is returned as a string. 'quot' should be
#! stack effect ( field -- ).
>r mapping-fields r> [ "" make ] curry map "," join ; inline
GENERIC: create-sql ( mapping -- string )
M: mapping create-sql ( mapping -- string )
#! Return the SQL used to create a table for storing this type of tuple.
[
"create table " % dup mapping-table %
" (" %
[ dup db-field-name % " " % db-field-type % ] comma-fields %
");" %
] "" make ;
GENERIC: drop-sql ( mapping -- string )
M: mapping drop-sql ( mapping -- string )
#! Return the SQL used to drop the table for storing this type of tuple.
[
"drop table " % mapping-table % ";" %
] "" make ;
GENERIC: insert-sql ( mapping -- string )
M: mapping insert-sql ( mapping -- string )
#! Return the SQL used to insert a tuple into a table
[
"insert into " % dup mapping-table %
" values(" %
[ db-field-bind-name % ] comma-fields %
");" %
] "" make ;
GENERIC: delete-sql ( mapping -- string )
M: mapping delete-sql ( mapping -- string )
#! Return the SQL used to delete a tuple from a table
[
"delete from " % mapping-table %
" where ROWID=:rowid;" %
] "" make ;
GENERIC: update-sql ( mapping -- string )
M: mapping update-sql ( mapping -- string )
#! Return the SQL used to update the tuple
[
"update " % dup mapping-table %
" set " %
[ dup db-field-name % "=" % db-field-bind-name % ] comma-fields %
" where ROWID=:rowid;" %
] "" make ;
GENERIC: select-sql ( tuple mapping -- select )
M: mapping select-sql ( tuple mapping -- select )
#! Return the SQL used to select a series of tuples from the database. It
#! will select based on only the filled in fields of the tuple (ie. all non-f).
[
"select ROWID,* from " % dup mapping-table %
mapping-fields [ ! tuple field
swap over db-field-slot slot ! field value
[
[ dup db-field-name % "=" % db-field-bind-name % ] "" make
] [
drop f
] if
] with map [ ] subset dup length 0 > [
" where " %
" and " join %
] [
drop
] if
";" %
] "" make ;
: execute-update-sql ( db string -- )
#! Execute the SQL, which should contain a database update
#! statement (update, insert, create, etc). Ignore the result.
sqlite-prepare dup [ drop ] sqlite-each sqlite-finalize ;
: create-tuple-table ( db class -- )
#! Create the table for the tuple class.
get-mapping create-sql execute-update-sql ;
: drop-tuple-table ( db class -- )
#! Create the table for the tuple class.
get-mapping drop-sql execute-update-sql ;
: bind-for-insert ( statement tuple -- )
#! Bind the fields in the tuple to the fields in the
#! prepared insert statement.
dup class get-mapping mapping-fields [ ! statement tuple field
[ db-field-slot slot ] keep ! statement value field
db-field-bind-name swap ! statement name value
>r dupd r> sqlite-bind-text-by-name
] with each drop ;
: bind-for-select ( statement tuple -- )
#! Bind the fields in the tuple to the fields in the
#! prepared select statement.
dup class get-mapping mapping-fields [ ! statement tuple field
[ db-field-slot slot ] keep ! statement value field
over [
db-field-bind-name swap ! statement name value
>r dupd r> sqlite-bind-text-by-name
] [
2drop
] if
] with each drop ;
: bind-for-update ( statement tuple -- )
#! Bind the fields in the tuple to the fields in the
#! prepared update statement.
2dup bind-for-insert
>r ":rowid" r> persistent-key sqlite-bind-text-by-name ;
: bind-for-delete ( statement tuple -- )
#! Bind the fields in the tuple to the fields in the
#! prepared delete statement.
>r ":rowid" r> persistent-key sqlite-bind-text-by-name ;
: (insert-tuple) ( db tuple -- )
#! Insert this tuple instance into the database. Note that
#! it inserts only this instance, and not any one-to-one or
#! one-to-many fields.
dup class get-mapping insert-sql ! db tuple sql
swapd sqlite-prepare swap ! statement tuple
dupd bind-for-insert ! statement
dup [ drop ] sqlite-each
sqlite-finalize ;
: insert-tuple ( db tuple -- )
#! Insert this tuple instance into the database and
#! update the rowid of the insert in the tuple.
[ (insert-tuple) ] 2keep
>r sqlite-last-insert-rowid number>string r> make-persistent set-persistent-key ;
: update-tuple ( db tuple -- )
#! Update this tuple instance in the database. The tuple should have
#! a delegate of 'persistent' with the key field set.
dup class get-mapping update-sql ! db tuple sql
swapd sqlite-prepare swap ! statement tuple
dupd bind-for-update ! statement
dup [ drop ] sqlite-each
sqlite-finalize ;
: save-tuple ( db tuple -- )
#! Insert or Update the tuple instance depending on whether it
#! has a persistent delegate.
dup delegate [ update-tuple ] [ insert-tuple ] if ;
: delete-tuple ( db tuple -- )
#! Delete this tuple instance from the database. The tuple should have
#! a delegate of 'persistent' with the key field set.
dup class get-mapping delete-sql ! db tuple sql
swapd sqlite-prepare swap ! statement tuple
dupd bind-for-delete ! statement
dup [ drop ] sqlite-each
sqlite-finalize ;
: restore-tuple ( statement tuple -- tuple )
#! Using 'tuple' as a template, clone it and
#! return the clone with fields set to the values from the
#! database.
clone dup class get-mapping mapping-fields 1 swap
[ ! statement tuple index field )
over 1+ >r ! statement tuple index field r: index+1
db-field-slot >r ! statement tuple index r: index+1 slot
pick swap column-text ! statement tuple value r: index+1 slot
over r> set-slot r> ! statement tuple index+1
] each ! statement tuple index
drop make-persistent swap 0 column-text swap [ set-persistent-key ] keep ;
: find-tuples ( db tuple -- seq )
#! Return a sequence of all tuples in the database that
#! match the tuple provided as a template. All fields in the
#! tuple must match the entries in the database, except for
#! those set to 'f'.
dup class get-mapping dupd select-sql ! db tuple sql
swapd sqlite-prepare swap ! statement tuple
2dup bind-for-select ! statement tuple
[
over [ ! tuple statement
over restore-tuple ,
] sqlite-each
] { } make nip ! statement tuple accum
swap sqlite-finalize ;
get-mappings [ init-mappings ] unless

2
extra/state-parser/state-parser.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: io io.streams.string kernel math namespaces sequences
strings circular prettyprint debugger ;
strings circular prettyprint debugger unicode.categories ;
IN: state-parser
! * Basic underlying words

7
extra/tar/tar.factor
View File

@ -1,6 +1,7 @@
USING: combinators io io.files io.streams.duplex continuations
io.streams.string kernel math math.parser
namespaces pack prettyprint sequences strings system hexdump ;
USING: combinators io io.files io.streams.duplex
io.streams.string kernel math math.parser continuations
namespaces pack prettyprint sequences strings system
hexdump tools.interpreter ;
IN: tar
: zero-checksum 256 ;

9
extra/ui/tools/interactor/interactor.factor
View File

@ -3,9 +3,10 @@
USING: arrays assocs combinators continuations documents
ui.tools.workspace hashtables io io.styles kernel math
math.vectors models namespaces parser prettyprint quotations
sequences strings threads listener tuples ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
ui.gestures definitions ;
sequences sequences.lib strings threads listener tuples
ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
definitions ;
IN: ui.tools.interactor
TUPLE: interactor
@ -97,7 +98,7 @@ M: interactor model-changed
[ set-interactor-continuation stop ] curry callcc1 ;
M: interactor stream-readln
[ interactor-yield ] keep interactor-finish first ;
[ interactor-yield ] keep interactor-finish ?first ;
: interactor-call ( quot interactor -- )
dup interactor-busy? [

4
extra/ui/tools/listener/listener.factor
View File

@ -77,7 +77,7 @@ M: listener-operation invoke-command ( target command -- )
[ [ run-file ] each ] curry call-listener
] if ;
: com-EOF ( listener -- )
: com-end ( listener -- )
listener-gadget-input interactor-eof ;
: clear-output ( listener -- )
@ -154,7 +154,7 @@ listener-gadget "toolbar" f {
{ f restart-listener }
{ T{ key-down f f "CLEAR" } clear-output }
{ T{ key-down f { C+ } "CLEAR" } clear-stack }
{ T{ key-down f { C+ } "d" } com-EOF }
{ T{ key-down f { C+ } "d" } com-end }
{ T{ key-down f f "F1" } listener-help }
} define-command-map

4
extra/ui/tools/search/search.factor
View File

@ -39,8 +39,8 @@ TUPLE: search-field ;
search-field H{
{ T{ key-down f f "UP" } [ find-search-list select-previous ] }
{ T{ key-down f f "DOWN" } [ find-search-list select-next ] }
{ T{ key-down f f "PAGE_UP" } [ find-search-list list-page-up ] }
{ T{ key-down f f "PAGE_DOWN" } [ find-search-list list-page-down ] }
{ T{ key-down f f "PAGE_UP" } [ find-search-list list-page-up ] }
{ T{ key-down f f "PAGE_DOWN" } [ find-search-list list-page-down ] }
{ T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
} set-gestures

15
extra/unicode/case/case.factor
View File

@ -1,5 +1,6 @@
USING: kernel unicode.data sequences sequences.next namespaces assocs.lib
unicode.normalize math unicode.categories combinators assocs ;
USING: kernel unicode.data sequences sequences.next namespaces
assocs.lib unicode.normalize math unicode.categories combinators
assocs ;
IN: unicode.case
: ch>lower ( ch -- lower ) simple-lower at-default ;
@ -20,7 +21,7 @@ SYMBOL: locale ! Just casing locale, or overall?
[ swap dot-over = over "ij" member? and swap , ] if ;
: lithuanian>upper ( string -- lower )
[ f swap [ lithuanian-ch>upper ] each-next drop ] "" make* ;
[ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ;
: mark-above? ( ch -- ? )
combining-class 230 = ;
@ -32,14 +33,14 @@ SYMBOL: locale ! Just casing locale, or overall?
dup , "IJ" member? swap mark-above? and [ dot-over , ] when ;
: lithuanian>lower ( string -- lower )
[ [ lithuanian-ch>lower ] each-next ] "" make* ;
[ [ lithuanian-ch>lower ] each-next ] "" make ;
: turk-ch>upper ( ch -- )
dup CHAR: i =
[ drop CHAR: I , dot-over , ] [ , ] if ;
: turk>upper ( string -- upper-i )
[ [ turk-ch>upper ] each ] "" make* ;
[ [ turk-ch>upper ] each ] "" make ;
: turk-ch>lower ( ? next ch -- ? )
{
@ -52,7 +53,7 @@ SYMBOL: locale ! Just casing locale, or overall?
} cond ;
: turk>lower ( string -- lower-i )
[ f swap [ turk-ch>lower ] each-next drop ] "" make* ;
[ f swap [ turk-ch>lower ] each-next drop ] "" make ;
: word-boundary ( prev char -- new ? )
dup non-starter? [ drop dup ] when
@ -76,7 +77,7 @@ SYMBOL: locale ! Just casing locale, or overall?
[ -rot nip call , ] ?if
] 2keep
] each 2drop
] "" make* ; inline
] "" make ; inline
: >lower ( string -- lower )
i-dot? [ turk>lower ] when

11
extra/unicode/normalize/normalize.factor
View File

@ -2,17 +2,6 @@ USING: sequences namespaces unicode.data kernel combinators.lib
math arrays ;
IN: unicode.normalize
! Utility word--probably unnecessary
: make* ( seq quot exemplar -- newseq )
! quot has access to original seq on stack
! this just makes the new-resizable the same length as seq
[
[
pick length swap new-resizable
[ building set call ] keep
] keep like
] with-scope ; inline
! Conjoining Jamo behavior
: hangul-base HEX: ac00 ; inline

26
extra/unix/linux/fs/fs.factor
View File

@ -3,19 +3,19 @@ USING: alien.syntax ;
IN: unix.linux.fs
: MS_RDONLY 1 ; ! Mount read-only.
: MS_NOSUID 2 ; ! Ignore suid and sgid bits.
: MS_NODEV 4 ; ! Disallow access to device special files.
: MS_NOEXEC 8 ; ! Disallow program execution.
: MS_SYNCHRONOUS 16 ; ! Writes are synced at once.
: MS_REMOUNT 32 ; ! Alter flags of a mounted FS.
: MS_MANDLOCK 64 ; ! Allow mandatory locks on an FS.
: S_WRITE 128 ; ! Write on file/directory/symlink.
: S_APPEND 256 ; ! Append-only file.
: S_IMMUTABLE 512 ; ! Immutable file.
: MS_NOATIME 1024 ; ! Do not update access times.
: MS_NODIRATIME 2048 ; ! Do not update directory access times.
: MS_BIND 4096 ; ! Bind directory at different place.
: MS_RDONLY 1 ; ! Mount read-only.
: MS_NOSUID 2 ; ! Ignore suid and sgid bits.
: MS_NODEV 4 ; ! Disallow access to device special files.
: MS_NOEXEC 8 ; ! Disallow program execution.
: MS_SYNCHRONOUS 16 ; ! Writes are synced at once.
: MS_REMOUNT 32 ; ! Alter flags of a mounted FS.
: MS_MANDLOCK 64 ; ! Allow mandatory locks on an FS.
: S_WRITE 128 ; ! Write on file/directory/symlink.
: S_APPEND 256 ; ! Append-only file.
: S_IMMUTABLE 512 ; ! Immutable file.
: MS_NOATIME 1024 ; ! Do not update access times.
: MS_NODIRATIME 2048 ; ! Do not update directory access times.
: MS_BIND 4096 ; ! Bind directory at different place.
FUNCTION: int mount
( char* special_file, char* dir, char* fstype, ulong options, void* data ) ;

50
extra/unix/linux/inotify/inotify.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
IN: unix.linux.inotify
C-STRUCT: inotify-event
{ "int" "wd" } ! watch descriptor
{ "uint" "mask" } ! watch mask
{ "uint" "cookie" } ! cookie to synchronize two events
{ "uint" "len" } ! length (including nulls) of name
{ "char[1]" "name" } ! stub for possible name
;
: IN_ACCESS HEX: 1 ; inline ! File was accessed
: IN_MODIFY HEX: 2 ; inline ! File was modified
: IN_ATTRIB HEX: 4 ; inline ! Metadata changed
: IN_CLOSE_WRITE HEX: 8 ; inline ! Writtable file was closed
: IN_CLOSE_NOWRITE HEX: 10 ; inline ! Unwrittable file closed
: IN_OPEN HEX: 20 ; inline ! File was opened
: IN_MOVED_FROM HEX: 40 ; inline ! File was moved from X
: IN_MOVED_TO HEX: 80 ; inline ! File was moved to Y
: IN_CREATE HEX: 100 ; inline ! Subfile was created
: IN_DELETE HEX: 200 ; inline ! Subfile was deleted
: IN_DELETE_SELF HEX: 400 ; inline ! Self was deleted
: IN_MOVE_SELF HEX: 800 ; inline ! Self was moved
: IN_UNMOUNT HEX: 2000 ; inline ! Backing fs was unmounted
: IN_Q_OVERFLOW HEX: 4000 ; inline ! Event queued overflowed
: IN_IGNORED HEX: 8000 ; inline ! File was ignored
: IN_CLOSE IN_CLOSE_WRITE IN_CLOSE_NOWRITE bitor ; inline ! close
: IN_MOVE IN_MOVED_FROM IN_MOVED_TO bitor ; inline ! moves
: IN_ONLYDIR HEX: 1000000 ; inline ! only watch the path if it is a directory
: IN_DONT_FOLLOW HEX: 2000000 ; inline ! don't follow a sym link
: IN_MASK_ADD HEX: 20000000 ; inline ! add to the mask of an already existing watch
: IN_ISDIR HEX: 40000000 ; inline ! event occurred against dir
: IN_ONESHOT HEX: 80000000 ; inline ! only send event once
: IN_ALL_EVENTS
{
IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE
IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF
IN_MOVE_SELF
} flags ; foldable
FUNCTION: int inotify_init ( void ) ;
FUNCTION: int inotify_add_watch ( int fd, char* name, u32 mask ) ;
FUNCTION: int inotify_rm_watch ( int fd, u32 wd ) ;

6
extra/unix/linux/swap/swap.factor
View File

@ -3,9 +3,9 @@ USING: alien.syntax ;
IN: unix.linux.swap
: SWAP_FLAG_PREFER HEX: 8000 ; ! Set if swap priority is specified.
: SWAP_FLAG_PRIO_MASK HEX: 7fff ;
: SWAP_FLAG_PRIO_SHIFT 0 ;
: SWAP_FLAG_PREFER HEX: 8000 ; ! Set if swap priority is specified.
: SWAP_FLAG_PRIO_MASK HEX: 7fff ;
: SWAP_FLAG_PRIO_SHIFT 0 ;
FUNCTION: int swapon ( char* path, int flags ) ;

33
extra/webapps/article-manager/article-manager-docs.factor
View File

@ -1,33 +0,0 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax webapps.article-manager.database ;
IN: webapps.article-manager
ARTICLE: { "article-manager" "loading" } "Loading Article Manager"
"To start an instance of the article-manager furnace application:"
{ $example "\"webapps.article-manager\" run" }
"The article-manager database needs to be opened before it can be accessed."
{ $example "open-db" } ;
ARTICLE: { "article-manager" "security" } "Article Manager Security"
"To setup an article manager site you need to authenticate under the basic-authentication realm called \"article-manager-site\". To add and edit articles you need to authenticate under the realm \"article-manager-article\". The following sets up an 'admin' user under these two realms with a password of 'password'."
{ $example "H{ { \"admin\" \"5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8\" } } \"article-manager-site\" add-realm\nH{ { \"admin\" \"5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8\" } } \"article-manager-article\" add-realm " }
"Multiple users can be added with different passwords under these realms." ;
ARTICLE: { "article-manager" "setup" } "Article Manager Setup"
"A site must first be setup before it can be accessed by the user. This can be access via the URL " { $url "http://site-name/responder/article-manager/setup-site/" } "\n\n"
"The 'hostname' is the hostname portion of the URL used to access the site. The 'title' is what appears in the title bar. 'footer' appears at the bottom of the pages in the site and can be used for a copyright notice, etc. 'Introduction' Should be Wiky code and will appear on the first index page of the site. 'HTML' will be appended to every page just before the closing of the 'body' HTML tag. It can be used to put HTML for counters, user tracking, etc.\n\n"
"The 'Ad Block' sections are used for entering HTML and Javascript code for ads that will appear in the article pages. 'Ad Block 1' appears in the left hand navigation area underneat the menu and above the 'tags' list. The other two ad blocks appear at the top of articles randomly split between either no ad and one of those two blocks." ;
ARTICLE: { "article-manager" "articles" } "Adding or Editing Articles"
"Articles are added or edited using the URL " { $url "http://site-name/responder/article-manager/edit-article/article-name" } ". This will bring up a form with information about the article.\n\n'Publication Date' is the date you want to appear next to the article. You can click the button next to it to select it using a popup calendar. 'Title' is the title of the article.\n\n'Status' can be 'Draft' or 'Published'. 'Draft' articles do not appear in the main index page or list of tags. They can still be accessed via the direct URL however. Note that editing an existing article will default this to 'Draft' automatically, so you'll need to change it back to 'Published' if you want it to appear.\n\n'Tags' is a space-separated list of tag names that can be used for finding articles.\n\n'Body' is the text of the article. It is in Wiky format and shows a preview below it. For more on the Wiky syntax see " { $url "http://goessner.net/articles/wiky/WikyBox.html" } " or Google for 'Wikybox'."
;
ARTICLE: { "article-manager" "article-manager" } "Article Manager"
"The article-manager is a Furnace application used to manage and display a tagged set of articles. Each instance of the article-manager responder can run multiple sites containing different articles. Follow these instructions to set up an article manager instance."
{ $subsection { "article-manager" "loading" } }
{ $subsection { "article-manager" "security" } }
{ $subsection { "article-manager" "setup" } }
{ $subsection { "article-manager" "articles" } } ;
ABOUT: { "article-manager" "article-manager" }

165
extra/webapps/article-manager/article-manager.factor
View File

@ -1,165 +0,0 @@
! Copyright (C) 2007 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel furnace sqlite.tuple-db webapps.article-manager.database
sequences namespaces math arrays assocs quotations io.files
http.server http.basic-authentication http.server.responders
webapps.file html html.elements io ;
IN: webapps.article-manager
: current-site ( -- site )
host get-site* ;
: render-titled-page* ( model body-template head-template title -- )
[
[ render-component ] swap [ <title> write </title> f rot render-component ] curry html-document
] serve-html ;
TUPLE: template-args arg1 ;
C: <template-args> template-args
: setup-site ( -- )
"article-manager-site" [
current-site "setup-site" "edit-head" "Setup Site" render-titled-page*
] with-basic-authentication ;
\ setup-site { } define-action
: site-index ( -- )
host get-site [
current-site "index" "head" pick site-title render-titled-page*
] [
"404" "Unknown Site" httpd-error
] if ;
! An action called 'site-index'
\ site-index { } define-action
: requested-article-path ( action -- url )
length "responder-url" get length 1 + + "request" get swap tail ;
: requested-article-url ( action -- url )
requested-article-path CHAR: / over index dup [
head
] [
drop
] if ;
: requested-article-filename ( action -- url )
requested-article-path CHAR: / over last-index 1+ tail ;
: tag ( -- )
current-site
"tag" requested-article-url host swap get-tag dup >r
2array <template-args> "tag" "head" r> tag-title render-titled-page* ;
! An action for tags
\ tag { } define-action
: article ( -- )
current-site
"article" requested-article-url host swap article-by-url dup >r
2array <template-args>
"article" "head" r> article-title render-titled-page* ;
! An action for articles
\ article { } define-action
: edit-article ( -- )
"article-manager-article" [
"edit-article" requested-article-url host swap article-by-url*
"edit-article" "edit-head" "Edit" render-titled-page*
] with-basic-authentication ;
! An action for articles
\ edit-article { } define-action
: update-article ( pubdate title status tags body url -- )
"article-manager-article" [
host swap article-by-url*
[ set-article-body ] keep
[ set-article-tags ] keep
[ set-article-status ] keep
[ set-article-title ] keep
[ set-article-pubdate ] keep
[ save-article ] keep
article-url "responder-url" get "article/" rot 3append "/" append permanent-redirect
] with-basic-authentication ;
\ update-article { { "pubdate" } { "title" } { "status" } { "tags" } { "body" } { "url" } } define-action
: update-article-link ( -- link )
"responder-url" get "update-article" append ;
: remove-article ( url -- )
"article-manager-article" [
host swap article-by-url [ remove-article ] when*
"responder-url" get permanent-redirect
] with-basic-authentication ;
\ remove-article { { "url" } } define-action
: update-site ( ad3 ad2 ad1 html title intro footer hostname -- )
"article-manager-site" [
dup get-site*
[ set-site-hostname ] keep
[ set-site-footer ] keep
[ set-site-intro ] keep
[ set-site-title ] keep
[ set-site-html ] keep
[ set-site-ad1 ] keep
[ set-site-ad2 ] keep
[ set-site-ad3 ] keep
get-db swap save-tuple
"responder-url" get permanent-redirect
] with-basic-authentication ;
\ update-site { { "ad3" } { "ad2" } { "ad1" } { "html" } { "title" } { "intro" } { "footer" } { "hostname" } } define-action
: update-site-link ( -- link )
"responder-url" get "update-site" append ;
SYMBOL: redirections
: redirector ( url quot -- )
over redirections get H{ } or at dup [
2nip permanent-redirect
] [
drop call
] if ;
: install-redirector ( hash responder host -- )
vhost [ responder ] bind [
"post" get [ redirector ] curry "post" set
"get" get [ redirector ] curry "get" set
redirections set
] bind ;
: get-redirections ( responder host -- hash )
vhost [ responder ] bind [ redirections get ] bind ;
: article-manager-web-app ( -- )
! Create the web app, providing access
! under '/responder/article-manager' which calls the
! 'site-index' action.
"article-manager" "site-index" "extra/webapps/article-manager/furnace/" web-app
! An URL to the javascript and css resource files
"article-manager-resources" [
[
"extra/webapps/article-manager/resources/" resource-path "doc-root" set
file-responder
] with-scope
] add-simple-responder ;
MAIN: article-manager-web-app
! Just for testing. Password is 'password'
! H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "article-manager-site" add-realm
! H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "article-manager-article" add-realm

1
extra/webapps/article-manager/authors.txt
View File

@ -1 +0,0 @@
Chris Double

1
extra/webapps/article-manager/database/authors.txt
View File

@ -1 +0,0 @@
Chris Double

118
extra/webapps/article-manager/database/database.factor
View File

@ -1,118 +0,0 @@
! Copyright (C) 2007 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel sqlite sqlite.tuple-db io.files sequences splitting
hashtables ;
IN: webapps.article-manager.database
TUPLE: site hostname title intro footer html ad1 ad2 ad3 ;
C: <site> site
TUPLE: article hostname url pubdate title status body tags ;
C: <article> article
TUPLE: tag hostname name title description ;
C: <tag> tag
site default-mapping set-mapping
article default-mapping set-mapping
tag default-mapping set-mapping
: db ( -- object )
{ f } ;
: set-db ( value -- )
0 db set-nth ;
: get-db ( -- value )
0 db nth ;
: db-filename ( -- name )
"extra/webapps/article-manager/article-manager.db" resource-path ;
: open-db ( -- )
get-db [ sqlite-close ] when*
db-filename exists? [
db-filename sqlite-open set-db
] [
db-filename sqlite-open dup set-db
dup article create-tuple-table
dup site create-tuple-table
tag create-tuple-table
] if ;
: close-db ( -- )
get-db [ sqlite-close ] when*
f set-db ;
: all-sites ( -- sites )
get-db f f f f f f f f <site> find-tuples ;
: get-site ( hostname -- site )
f f f f f f f <site> get-db swap find-tuples dup empty? [
drop f
] [
first
] if ;
: get-site* ( hostname -- site )
f f f f f f f <site> dup get-db swap find-tuples dup empty? [
drop site-hostname dup "" "" "" "" "" "" <site>
] [
nip first
] if ;
: get-tag ( hostname name -- tag )
f f <tag> dup get-db swap find-tuples dup empty? [
drop
[ dup tag-name swap set-tag-title ] keep
[ "" swap set-tag-description ] keep
] [
nip first
] if ;
: add-article ( article -- )
get-db swap insert-tuple ;
: remove-article ( article -- )
get-db swap delete-tuple ;
: save-article ( article -- )
get-db swap save-tuple ;
: all-articles ( hostname -- seq )
f f f "published" f f <article> get-db swap find-tuples ;
: article-by-url ( hostname url -- article )
f f f f f <article> get-db swap find-tuples dup empty? [
drop f
] [
first
] if ;
: article-by-url* ( hostname url -- article )
f f f f f <article> dup get-db swap find-tuples dup empty? [
drop
[ "" swap set-article-pubdate ] keep
[ "" swap set-article-title ] keep
[ "draft" swap set-article-status ] keep
[ "" swap set-article-body ] keep
[ "" swap set-article-tags ] keep
] [
nip first
] if ;
: tags-for-article ( article -- seq )
article-tags " " split [ empty? not ] subset ;
: all-tags ( hostname -- seq )
all-articles [ tags-for-article ] map concat prune ;
: articles-for-tag ( tag -- seq )
[ tag-name ] keep tag-hostname all-articles [
tags-for-article member?
] with subset ;

13
extra/webapps/article-manager/furnace/article.furnace
View File

@ -1,13 +0,0 @@
<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %>
<div id="banner"><h1><% "arg1" get second article-title write %></h1></div>
<% "navigation" render-template %>
<div id="article">
<% 100 random 25 > [ "arg1" get first 100 random 50 > [ site-ad2 ] [ site-ad3 ] if write-html ] when %>
<% "arg1" get second article-body write-html %>
<h1>Tags</h1>
<% "arg1" get second tags-for-article <template-args> "tags" render-component %>
</div>
<p class="footer"></p>
<p id="copyright"><% "arg1" get first site-footer write %></p>
<% "arg1" get first site-html write-html %>

41
extra/webapps/article-manager/furnace/edit-article.furnace
View File

@ -1,41 +0,0 @@
<% USING: kernel io namespaces furnace webapps.article-manager html.elements ; %>
<script type="text/javascript">
function transformWiky() {
var wiky = $('#wiky').get(0).value;
var html = Wiky.toHtml(wiky);
$('#html').get(0).value = html;
$('#preview').html(html);
}
function transformHtml() {
var html = $('#preview').get(0).innerHTML;
var wiky = Wiky.toWiki(html);
$('#wiky').get(0).value = wiky;
$('#html').get(0).value = html;
}
</script>
<form method="post" action="<% update-article-link write %>">
<table>
<tr><td>URL:</td><td><input type="hidden" name="url" value="<% "url" get write %>"/><input type="text" name="readonlyurl" disabled="disabled" value="<% "url" get write %>"/></td></tr>
<tr><td>Publication Date:</td><td><input id="pubdate" type="text" name="pubdate" value="<% "pubdate" get write %>"/> <button id="calendar">[c]</button></td></tr>
<tr><td>Title:</td><td><input type="text" name="title" value="<% "title" get write %>"/></td></tr>
<tr><td>Status:</td><td><select name="status">
<option value="draft">Draft</option>
<option value="published">Published</option>
</td></tr>
<tr><td>Tags:</td><td><input type="text" name="tags" value="<% "tags" get write %>"/></td></tr>
<tr><td>Body:</td><td><textarea id='wiky' onkeyup="transformWiky();" rows="10" cols="80" name="wiky"></textarea></td></tr>
<tr><td>Preview:</td><td><input id="html" type='hidden' name="body" value=""/><div id="preview"><% "body" get write-html %></div></td></tr>
<tr><td colspan="2"><input type="submit" name="post" value="Post"/></td></tr>
</form>
<script type="text/javascript">
transformHtml();
Calendar.setup(
{
inputField: "pubdate",
ifFormat : "%Y/%m/%d %H:%M",
showsTime : true,
timeFormat: "24",
button: "calendar"
});
</script>

12
extra/webapps/article-manager/furnace/edit-head.furnace
View File

@ -1,12 +0,0 @@
<link rel="stylesheet" type="text/css" href="/responder/article-manager-resources/style.css"/>
<link rel="stylesheet" type="text/css" href="/responder/article-manager-resources/wiky.css"/>
<link rel="stylesheet" type="text/css" href="/responder/article-manager-resources/wiky.lang.css"/>
<link rel="stylesheet" type="text/css" href="/responder/article-manager-resources/wiky.math.css"/>
<link rel="stylesheet" type="text/css" href="/responder/article-manager-resources/jscalendar-1.0/calendar-win2k-1.css"/>
<script type="text/javascript" src="/responder/article-manager-resources/jquery.js"></script>
<script type="text/javascript" src="/responder/article-manager-resources/wiky.js"></script>
<script type="text/javascript" src="/responder/article-manager-resources/wiky.lang.js"></script>
<script type="text/javascript" src="/responder/article-manager-resources/wiky.math.js"></script>
<script type="text/javascript" src="/responder/article-manager-resources/jscalendar-1.0/calendar.js"></script>
<script type="text/javascript" src="/responder/article-manager-resources/jscalendar-1.0/lang/calendar-en.js"></script>
<script type="text/javascript" src="/responder/article-manager-resources/jscalendar-1.0/calendar-setup.js"></script>

4
extra/webapps/article-manager/furnace/head.furnace
View File

@ -1,4 +0,0 @@
<link rel="stylesheet" type="text/css" href="/responder/article-manager-resources/style.css"/>
<link rel="stylesheet" type="text/css" href="/responder/article-manager-resources/wiky.css"/>
<link rel="stylesheet" type="text/css" href="/responder/article-manager-resources/wiky.lang.css"/>
<link rel="stylesheet" type="text/css" href="/responder/article-manager-resources/wiky.math.css"/>

32
extra/webapps/article-manager/furnace/index.furnace
View File

@ -1,32 +0,0 @@
<% USING: kernel sequences furnace webapps.article-manager webapps.article-manager.database io namespaces http.server sorting html.elements math ; %>
<html>
<head>
<title><% "title" get write %></title>
<link rel="stylesheet" type="text/css" href="/responder/article-manager-resources/style.css">
</head>
<body>
<div id="banner"><h1><% "title" get write %></h1></div>
<% "navigation" render-template %>
<div id="article">
<% "intro" get write-html %>
<h1>Recent Articles</h1>
<ul>
<% host all-articles [ >r article-pubdate r> article-pubdate swap <=> ] sort [ %>
<li><a href="article/<% dup article-url write "/" write %>"><% dup article-title write %></a> (<% article-pubdate write %>)</li>
<% ] each %>
</ul>
<h1>Tags</h1>
<p>The information in this site is 'tagged'. By searching or
selecting one of the tags below you can find information about
that area. A search facility will be added soon
but in the meantime, Google is likely to provide
reasonable results.
</p>
<% host all-tags <template-args> "tags" render-component %>
</div>
<p class="footer"></p>
<p id="copyright"><% "footer" get write %></p>
<% "html" get write-html %>
</body>
</html>

9
extra/webapps/article-manager/furnace/navigation.furnace
View File

@ -1,9 +0,0 @@
<% USING: kernel furnace webapps.article-manager webapps.article-manager.database io namespaces http.server html.elements ; %>
<div id="navigation">
<ul>
<li><a href="<% "responder-url" get write %>">Home</a></li>
</ul>
<% current-site site-ad1 write-html %>
<h1>Tags</h1>
<% host all-tags <template-args> "tags" render-component %>
</div>

33
extra/webapps/article-manager/furnace/setup-site.furnace
View File

@ -1,33 +0,0 @@
<% USING: kernel io namespaces furnace webapps.article-manager html.elements ; %>
<script type="text/javascript">
function transformWiky() {
var wiky = $('#wiky').get(0).value;
var html = Wiky.toHtml(wiky);
$('#html').get(0).value = html;
$('#preview').html(html);
}
function transformHtml() {
var html = $('#preview').get(0).innerHTML;
var wiky = Wiky.toWiki(html);
$('#wiky').get(0).value = wiky;
$('#html').get(0).value = html;
}
</script>
<h1>Setup New Site</h1>
<form method="post" action="<% update-site-link write %>">
<table>
<tr><td>Hostname:</td><td><input type="text" name="hostname" value="<% "hostname" get write %>"/></td></tr>
<tr><td>Title:</td><td><input type="text" name="title" value="<% "title" get write %>"/></td></tr>
<tr><td>footer:</td><td><input type="text" name="footer" value="<% "footer" get write %>"/></td></tr>
<tr><td>Introduction:</td><td><textarea id='wiky' onkeyup="transformWiky();" rows="10" cols="80"></textarea></td></tr>
<tr><td>Preview:</td><td><input id="html" type="hidden" name="intro" value=""/><div id="preview"><% "intro" get write-html %></div></td></tr>
<tr><td>HTML:</td><td><textarea name="html" rows="10" cols="80"><% "html" get write %></textarea></td></tr>
<tr><td>Ad Block 1:</td><td><textarea name="ad1" rows="10" cols="80"><% "ad1" get write %></textarea></td></tr>
<tr><td>Ad Block 2:</td><td><textarea name="ad2" rows="10" cols="80"><% "ad2" get write %></textarea></td></tr>
<tr><td>Ad Block 3:</td><td><textarea name="ad3" rows="10" cols="80"><% "ad3" get write %></textarea></td></tr>
<tr><td colspan="2"><input type="submit" name="post" value="Post"/></td></tr>
</form>
<script type="text/javascript">
transformHtml();
</script>

16
extra/webapps/article-manager/furnace/tag.furnace
View File

@ -1,16 +0,0 @@
<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %>
<div id="banner"><h1><% "arg1" get second tag-title write %></h1></div>
<% "navigation" render-component %>
<div id="article">
<h1><% "arg1" get second tag-title write %></h1>
<% "arg1" get second tag-description write-html %>
<ul>
<% "arg1" get second articles-for-tag [ %>
<li><a href="<% "responder-url" get write "article/" write dup article-url write "/" write %>"><% dup article-title write %></a> (<% article-pubdate write %>)</li></a></li>
<% ] each %>
</ul>
</div>
<p class="footer"></p>
<p id="copyright"><% "arg1" get first site-footer write %></p>
<% "arg1" get first site-html write-html %>

Some files were not shown because too many files have changed in this diff Show More