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

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

db4
Bruno Deferrari 2008-05-15 20:41:29 -03:00
parent c1a5eeb432 a68f50c183
commit 29d96bde8f
218 changed files with 3903 additions and 3802 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
core/alien/c-types/c-types-docs.factor
View File

@ -1,7 +1,7 @@
IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private
byte-arrays math strings hashtables alien.syntax
bit-arrays float-arrays debugger ;
bit-arrays float-arrays debugger destructors ;
HELP: <c-type>
{ $values { "type" hashtable } }
@ -222,6 +222,9 @@ $nl
{ $subsection realloc }
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsection free }
"Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":"
{ $subsection &free }
{ $subsection |free }
"You can unsafely copy a range of bytes from one memory location to another:"
{ $subsection memcpy }
"You can copy a range of bytes from memory into a byte array:"

2
core/alien/c-types/c-types.factor
View File

@ -382,4 +382,6 @@ M: long-long-type box-return ( type -- )
"double" define-primitive-type
os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit

5
core/bootstrap/primitives.factor
View File

@ -160,11 +160,6 @@ bootstrapping? on
"tuple-layout" "classes.tuple.private" create register-builtin
! Catch-all class for providing a default method.
! "object" "kernel" create
! [ f builtins get [ ] filter f union-class define-class ]
! [ [ drop t ] "predicate" set-word-prop ]
! bi
"object" "kernel" create
[ f f { } intersection-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]

2
core/bootstrap/stage2.factor
View File

@ -23,7 +23,7 @@ SYMBOL: bootstrap-time
: load-components ( -- )
"include" "exclude"
[ get-global " " split [ empty? not ] filter ] bi@
[ get-global " " split harvest ] bi@
diff
[ "bootstrap." prepend require ] each ;

7
core/boxes/boxes-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax kernel ;
IN: boxes
HELP: box
{ $class-description "A data type holding a single value in the " { $link box-value } " slot. The " { $link box-full? } " slot indicates if the value is set." } ;
{ $class-description "A data type holding a single value in the " { $snippet "value" } " slot. The " { $snippet "occupied" } " slot indicates if the value is set." } ;
HELP: <box>
{ $values { "box" box } }
@ -27,12 +27,11 @@ ARTICLE: "boxes" "Boxes"
{ $subsection box }
"Creating an empty box:"
{ $subsection <box> }
"Testing if a box is full:"
{ $subsection box-full? }
"Storing a value and removing a value from a box:"
{ $subsection >box }
{ $subsection box> }
"Safely removing a value:"
{ $subsection ?box } ;
{ $subsection ?box }
"Testing if a box is full can be done by reading the " { $snippet "occupied" } " slot." ;
ABOUT: "boxes"

8
core/boxes/boxes-tests.factor
View File

@ -1,17 +1,17 @@
IN: boxes.tests
USING: boxes namespaces tools.test ;
USING: boxes namespaces tools.test accessors ;
[ ] [ <box> "b" set ] unit-test
[ ] [ 3 "b" get >box ] unit-test
[ t ] [ "b" get box-full? ] unit-test
[ t ] [ "b" get occupied>> ] unit-test
[ 4 "b" >box ] must-fail
[ 3 ] [ "b" get box> ] unit-test
[ f ] [ "b" get box-full? ] unit-test
[ f ] [ "b" get occupied>> ] unit-test
[ "b" get box> ] must-fail
@ -21,4 +21,4 @@ USING: boxes namespaces tools.test ;
[ 12 t ] [ "b" get ?box ] unit-test
[ f ] [ "b" get box-full? ] unit-test
[ f ] [ "b" get occupied>> ] unit-test

20
core/boxes/boxes.factor
View File

@ -1,24 +1,26 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ;
USING: kernel accessors ;
IN: boxes
TUPLE: box value full? ;
TUPLE: box value occupied ;
: <box> ( -- box ) box new ;
ERROR: box-full box ;
: >box ( value box -- )
dup box-full? [ "Box already has a value" throw ] when
t over set-box-full?
set-box-value ;
dup occupied>>
[ box-full ] [ t >>occupied (>>value) ] if ;
ERROR: box-empty box ;
: box> ( box -- value )
dup box-full? [ "Box empty" throw ] unless
dup box-value f pick set-box-value
f rot set-box-full? ;
dup occupied>>
[ [ f ] change-value f >>occupied drop ] [ box-empty ] if ;
: ?box ( box -- value/f ? )
dup box-full? [ box> t ] [ drop f f ] if ;
dup occupied>> [ box> t ] [ drop f f ] if ;
: if-box? ( box quot -- )
>r ?box r> [ drop ] if ; inline

5
core/checksums/checksums-docs.factor
View File

@ -49,4 +49,7 @@ $nl
{ $vocab-subsection "MD5 checksum" "checksums.md5" }
{ $vocab-subsection "SHA1 checksum" "checksums.sha1" }
{ $vocab-subsection "SHA2 checksum" "checksums.sha2" }
{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" } ;
{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" }
{ $vocab-subsection "OpenSSL checksums" "checksums.openssl" } ;
ABOUT: "checksums"

23
core/continuations/continuations-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private
continuations.private parser vectors arrays namespaces
assocs words quotations io ;
assocs words quotations ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
@ -28,13 +28,7 @@ $nl
{ $heading "Anti-pattern #3: Dropping and rethrowing" }
"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
{ $heading "Anti-pattern #4: Logging and rethrowing" }
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information."
{ $heading "Anti-pattern #5: Leaking external resources" }
"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
{ $code
"<external-resource> ... do stuff ... dispose"
}
"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ;
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
ARTICLE: "errors" "Error handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
@ -88,19 +82,6 @@ $nl
ABOUT: "continuations"
HELP: dispose
{ $values { "object" "a disposable object" } }
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
$nl
"No further operations can be performed on a disposable object after this call."
$nl
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." }
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
HELP: with-disposal
{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
HELP: catchstack*
{ $values { "catchstack" "a vector of continuations" } }
{ $description "Outputs the current catchstack." } ;

19
core/continuations/continuations-tests.factor
View File

@ -101,21 +101,6 @@ SYMBOL: error-counter
[ 1 ] [ error-counter get ] unit-test
] with-scope
TUPLE: dispose-error ;
M: dispose-error dispose 3 throw ;
TUPLE: dispose-dummy disposed? ;
M: dispose-dummy dispose t >>disposed? drop ;
T{ dispose-error } "a" set
T{ dispose-dummy } "b" set
[ f ] [ "b" get disposed?>> ] unit-test
[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
[ t ] [ "b" get disposed?>> ] unit-test
[ ] [ [ return ] with-return ] unit-test
[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with

22
core/continuations/continuations.factor
View File

@ -139,20 +139,16 @@ SYMBOL: thread-error-hook
over >r compose [ dip rethrow ] curry
recover r> call ; inline
ERROR: attempt-all-error ;
: attempt-all ( seq quot -- obj )
[
[ [ , f ] compose [ , drop t ] recover ] curry all?
] { } make peek swap [ rethrow ] when ; inline
GENERIC: dispose ( object -- )
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
] { } make dup empty? [ drop ] [ peek rethrow ] if ;
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
over empty? [
attempt-all-error
] [
[
[ [ , f ] compose [ , drop t ] recover ] curry all?
] { } make peek swap [ rethrow ] when
] if ; inline
TUPLE: condition error restarts continuation ;

2
core/cpu/x86/64/64.factor
View File

@ -184,7 +184,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split [ empty? not ] filter ;
] { } make { t } split harvest ;
: flatten-large-struct ( type -- )
heap-size cell align

2
core/debugger/debugger.factor
View File

@ -298,6 +298,8 @@ M: immutable-slot summary drop "Slot is immutable" ;
M: bad-create summary drop "Bad parameters to create" ;
M: attempt-all-error summary drop "Nothing to attempt" ;
<PRIVATE
: init-debugger ( -- )

0
extra/destructors/authors.txt → core/destructors/authors.txt
View File

71
core/destructors/destructors-docs.factor Executable file
View File

@ -0,0 +1,71 @@
USING: help.markup help.syntax libc kernel continuations io ;
IN: destructors
HELP: dispose
{ $values { "disposable" "a disposable object" } }
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
$nl
"No further operations can be performed on a disposable object after this call."
$nl
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
$nl
"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ;
HELP: dispose*
{ $values { "disposable" "a disposable object" } }
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." }
{ $notes
"This word should not be called directly. It can be implemented on objects with a " { $snippet "disposable" } " slot to ensure that the object is only disposed once."
} ;
HELP: with-disposal
{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } }
{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ;
HELP: with-destructors
{ $values { "quot" "a quotation" } }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $notes
"Destructors generalize " { $link with-disposal } ". The following two lines are equivalent, except that the second line establishes a new dynamic scope:"
{ $code
"[ X ] with-disposal"
"[ &dispose X ] with-destructors"
}
}
{ $examples
{ $code "[ 10 malloc &free ] with-destructors" }
} ;
HELP: &dispose
{ $values { "disposable" "a disposable object" } }
{ $description "Marks the object for unconditional disposal at the end of the current " { $link with-destructors } " scope." } ;
HELP: |dispose
{ $values { "disposable" "a disposable object" } }
{ $description "Marks the object for disposal in the event of an error at the end of the current " { $link with-destructors } " scope." } ;
ARTICLE: "destructors-anti-patterns" "Resource disposal anti-patterns"
"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
{ $code
"<external-resource> ... do stuff ... dispose"
}
"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ;
ARTICLE: "destructors" "Deterministic resource disposal"
"Operating system resources such as streams, memory mapped files, and so on are not managed by Factor's garbage collector and must be released when you are done with them. Failing to release a resource can lead to reduced performance and instability."
$nl
"Disposable object protocol:"
{ $subsection dispose }
{ $subsection dispose* }
"Utility word for scoped disposal:"
{ $subsection with-disposal }
"Utility word for disposing multiple objects:"
{ $subsection dispose-each }
"Utility words for more complex disposal patterns:"
{ $subsection with-destructors }
{ $subsection &dispose }
{ $subsection |dispose }
{ $subsection "destructors-anti-patterns" } ;
ABOUT: "destructors"

24
extra/destructors/destructors-tests.factor → core/destructors/destructors-tests.factor
View File

@ -1,6 +1,24 @@
USING: destructors kernel tools.test continuations ;
USING: destructors kernel tools.test continuations accessors
namespaces sequences ;
IN: destructors.tests
TUPLE: dispose-error ;
M: dispose-error dispose 3 throw ;
TUPLE: dispose-dummy disposed? ;
M: dispose-dummy dispose t >>disposed? drop ;
T{ dispose-error } "a" set
T{ dispose-dummy } "b" set
[ f ] [ "b" get disposed?>> ] unit-test
[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
[ t ] [ "b" get disposed?>> ] unit-test
TUPLE: dummy-obj destroyed? ;
: <dummy-obj> dummy-obj new ;
@ -13,10 +31,10 @@ M: dummy-destructor dispose ( obj -- )
dummy-destructor-obj t swap set-dummy-obj-destroyed? ;
: destroy-always
<dummy-destructor> add-always-destructor ;
<dummy-destructor> &dispose drop ;
: destroy-later
<dummy-destructor> add-error-destructor ;
<dummy-destructor> |dispose drop ;
[ t ] [
[

56
core/destructors/destructors.factor Executable file
View File

@ -0,0 +1,56 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel namespaces
sequences vectors ;
IN: destructors
TUPLE: disposable disposed ;
GENERIC: dispose* ( disposable -- )
ERROR: already-disposed disposable ;
: check-disposed ( disposable -- )
dup disposed>> [ already-disposed ] [ drop ] if ; inline
GENERIC: dispose ( disposable -- )
M: object dispose
dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
] { } make dup empty? [ drop ] [ peek rethrow ] if ;
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
<PRIVATE
SYMBOL: always-destructors
SYMBOL: error-destructors
: do-always-destructors ( -- )
always-destructors get <reversed> dispose-each ;
: do-error-destructors ( -- )
error-destructors get <reversed> dispose-each ;
PRIVATE>
: &dispose ( disposable -- disposable )
dup always-destructors get push ; inline
: |dispose ( disposable -- disposable )
dup error-destructors get push ; inline
: with-destructors ( quot -- )
[
V{ } clone always-destructors set
V{ } clone error-destructors set
[ do-always-destructors ]
[ do-error-destructors ]
cleanup
] with-scope ; inline

0
extra/destructors/summary.txt → core/destructors/summary.txt
View File

4
core/inference/backend/backend.factor
View File

@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ;
: balanced? ( in out -- ? )
[ dup [ length - ] [ 2drop f ] if ] 2map
[ ] filter all-equal? ;
sift all-equal? ;
TUPLE: unbalanced-branches-error quots in out ;
@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ;
2dup balanced? [
over supremum -rot
[ >r dupd r> unify-inputs ] 2map
[ ] filter unify-stacks
sift unify-stacks
rot drop
] [
unbalanced-branches-error

2
core/inference/inference-tests.factor
View File

@ -5,7 +5,7 @@ sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions
prettyprint io inspector classes.tuple classes.union
classes.predicate debugger threads.private io.streams.string
io.timeouts io.thread sequences.private ;
io.timeouts io.thread sequences.private destructors ;
IN: inference.tests
[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test

2
core/inference/known-words/known-words.factor
View File

@ -356,7 +356,7 @@ M: object infer-call
\ setenv { object fixnum } { } <effect> set-primitive-effect
\ exists? { string } { object } <effect> set-primitive-effect
\ (exists?) { string } { object } <effect> set-primitive-effect
\ (directory) { string } { array } <effect> set-primitive-effect

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

@ -1,9 +1,9 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces growable
strings io classes continuations combinators io.styles
io.streams.plain splitting byte-arrays sequences.private
accessors ;
strings io classes continuations destructors combinators
io.styles io.streams.plain splitting byte-arrays
sequences.private accessors ;
IN: io.encodings
! The encoding descriptor protocol

4
core/io/files/files-docs.factor
View File

@ -300,8 +300,8 @@ HELP: exists?
{ $description "Tests if the file named by " { $snippet "path" } " exists." } ;
HELP: directory?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "path" } " names a directory." } ;
{ $values { "file-info" file-info } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "file-info" } " is a directory." } ;
HELP: (directory)
{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } }

7
core/io/files/files-tests.factor
View File

@ -1,11 +1,14 @@
IN: io.files.tests
USING: tools.test io.files io.files.private io threads kernel
continuations io.encodings.ascii io.files.unique sequences
strings accessors io.encodings.utf8 math ;
strings accessors io.encodings.utf8 math destructors ;
\ exists? must-infer
\ (exists?) must-infer
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
[ t ] [ "blahblah" temp-file directory? ] unit-test
[ t ] [ "blahblah" temp-file file-info directory? ] unit-test
[ t ] [
[ temp-directory "loldir" append-path delete-directory ] ignore-errors

12
core/io/files/files.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
io.encodings.binary init accessors math.order ;
system combinators splitting sbufs continuations destructors
io.encodings io.encodings.binary init accessors math.order ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@ -172,11 +172,9 @@ SYMBOL: +socket+
SYMBOL: +unknown+
! File metadata
: exists? ( path -- ? )
normalize-path (exists?) ;
: exists? ( path -- ? ) normalize-path (exists?) ;
: directory? ( path -- ? )
file-info file-info-type +directory+ = ;
: directory? ( file-info -- ? ) type>> +directory+ = ;
<PRIVATE
@ -232,7 +230,7 @@ HOOK: make-directory io-backend ( path -- )
: fixup-directory ( path seq -- newseq )
[
dup string?
[ tuck append-path directory? 2array ] [ nip ] if
[ tuck append-path file-info directory? 2array ] [ nip ] if
] with map
[ first { "." ".." } member? not ] filter ;

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

@ -1,5 +1,5 @@
USING: help.markup help.syntax quotations hashtables kernel
classes strings continuations ;
classes strings continuations destructors ;
IN: io
ARTICLE: "stream-protocol" "Stream protocol"

3
core/io/io.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces sequences
continuations assocs io.styles ;
continuations destructors assocs io.styles ;
IN: io
GENERIC: stream-readln ( stream -- str/f )
@ -39,6 +39,7 @@ SYMBOL: error-stream
: read1 ( -- ch/f ) input-stream get stream-read1 ;
: read ( n -- str/f ) input-stream get stream-read ;
: read-until ( seps -- str/f sep/f ) input-stream get stream-read-until ;
: read-partial ( n -- str/f ) input-stream get stream-read-partial ;
: write1 ( ch -- ) output-stream get stream-write1 ;
: write ( str -- ) output-stream get stream-write ;

28
core/io/streams/c/c.factor
View File

@ -2,37 +2,37 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces io io.encodings
sequences math generic threads.private classes io.backend
io.files continuations byte-arrays ;
io.files continuations destructors byte-arrays accessors ;
IN: io.streams.c
TUPLE: c-writer handle ;
TUPLE: c-writer handle disposed ;
C: <c-writer> c-writer
: <c-writer> ( handle -- stream ) f c-writer boa ;
M: c-writer stream-write1
c-writer-handle fputc ;
handle>> fputc ;
M: c-writer stream-write
c-writer-handle fwrite ;
handle>> fwrite ;
M: c-writer stream-flush
c-writer-handle fflush ;
handle>> fflush ;
M: c-writer dispose
c-writer-handle fclose ;
M: c-writer dispose*
handle>> fclose ;
TUPLE: c-reader handle ;
TUPLE: c-reader handle disposed ;
C: <c-reader> c-reader
: <c-reader> ( handle -- stream ) f c-reader boa ;
M: c-reader stream-read
c-reader-handle fread ;
handle>> fread ;
M: c-reader stream-read-partial
stream-read ;
M: c-reader stream-read1
c-reader-handle fgetc ;
handle>> fgetc ;
: read-until-loop ( stream delim -- ch )
over stream-read1 dup [
@ -45,8 +45,8 @@ M: c-reader stream-read-until
[ swap read-until-loop ] B{ } make swap
over empty? over not and [ 2drop f f ] when ;
M: c-reader dispose
c-reader-handle fclose ;
M: c-reader dispose*
handle>> fclose ;
M: object init-io ;

2
core/io/streams/nested/nested.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel namespaces strings
quotations io continuations accessors sequences ;
quotations io continuations destructors accessors sequences ;
IN: io.streams.nested
TUPLE: filter-writer stream ;

4
core/io/streams/string/string.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces sequences sbufs strings
generic splitting growable continuations io.streams.plain
io.encodings math.order ;
generic splitting growable continuations destructors
io.streams.plain io.encodings math.order ;
IN: io.streams.string
M: growable dispose drop ;

29
core/kernel/kernel-docs.factor
View File

@ -148,7 +148,7 @@ $nl
{ $subsection "spread-shuffle-equivalence" } ;
ARTICLE: "apply-combinators" "Apply combinators"
"The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application."
"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
$nl
"Two quotations:"
{ $subsection bi@ }
@ -179,6 +179,7 @@ ARTICLE: "compositional-combinators" "Compositional combinators"
{ $subsection with }
{ $subsection compose }
{ $subsection 3compose }
{ $subsection prepose }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
ARTICLE: "implementing-combinators" "Implementing combinators"
@ -717,17 +718,21 @@ $nl
HELP: unless*
{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } }
{ $description "Variant of " { $link if* } " with no true quotation."
$nl
{ $description "Variant of " { $link if* } " with no true quotation." }
{ $notes
"The following two lines are equivalent:"
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" }
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
{ $code "[ L ] unless*" "L or" } } ;
HELP: ?if
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } }
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack."
$nl
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." }
{ $notes
"The following two lines are equivalent:"
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" }
"The following two lines are equivalent:"
{ $code "[ ] [ ] ?if" "swap or" } } ;
HELP: die
{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." }
@ -835,8 +840,16 @@ HELP: compose ( quot1 quot2 -- compose )
"However, " { $link compose } " runs in constant time, and the optimizing compiler is able to compile code which calls composed quotations."
} ;
HELP: prepose
{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot2" } " followed by " { $snippet "quot1" } "." }
{ $notes "See " { $link compose } " for details." } ;
{ compose prepose } related-words
HELP: 3compose
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "curry" curry } }
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes
"The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"

4
core/kernel/kernel.factor
View File

@ -156,10 +156,10 @@ M: callstack clone (clone) ;
: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
: prepose ( quot1 quot2 -- curry )
: prepose ( quot1 quot2 -- compose )
swap compose ; inline
: 3compose ( quot1 quot2 quot3 -- curry )
: 3compose ( quot1 quot2 quot3 -- compose )
compose compose ; inline
! Booleans

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

@ -1,4 +1,4 @@
USING: help.markup help.syntax alien ;
USING: help.markup help.syntax alien destructors ;
IN: libc
HELP: malloc
@ -36,5 +36,13 @@ HELP: with-malloc
{ $values { "size" "a positive integer" } { "quot" "a quotation with stack effect " { $snippet "( c-ptr -- )" } } }
{ $description "Allocates a zeroed block of " { $snippet "n" } " bytes and passes it to the quotation. When the quotation returns, the block is freed." } ;
HELP: &free
{ $values { "alien" c-ptr } }
{ $description "Marks the block of memory for unconditional deallocation at the end of the current " { $link with-destructors } " scope." } ;
HELP: |free
{ $values { "alien" c-ptr } }
{ $description "Marks the object for deallocation in the event of an error at the end of the current " { $link with-destructors } " scope." } ;
! Defined in alien-docs.factor
ABOUT: "malloc"

11
core/libc/libc-tests.factor Executable file
View File

@ -0,0 +1,11 @@
IN: libc.tests
USING: libc libc.private tools.test namespaces assocs
destructors kernel ;
100 malloc "block" set
[ t ] [ "block" get mallocs get key? ] unit-test
[ ] [ [ "block" get &free drop ] with-destructors ] unit-test
[ f ] [ "block" get mallocs get key? ] unit-test

25
core/libc/libc.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2004, 2005 Mackenzie Straight
! Copyright (C) 2007 Slava Pestov
! Copyright (C) 2007 Doug Coleman
! Copyright (C) 2007, 2008 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: alien assocs continuations init kernel namespaces ;
USING: alien assocs continuations destructors init kernel
namespaces accessors ;
IN: libc
<PRIVATE
@ -73,3 +74,21 @@ PRIVATE>
: with-malloc ( size quot -- )
swap 1 calloc [ swap keep ] [ free ] [ ] cleanup ; inline
: strlen ( alien -- len )
"size_t" "libc" "strlen" { "char*" } alien-invoke ;
<PRIVATE
! Memory allocations
TUPLE: memory-destructor alien disposed ;
M: memory-destructor dispose* alien>> free ;
PRIVATE>
: &free ( alien -- alien )
dup f memory-destructor boa &dispose drop ; inline
: |free ( alien -- alien )
dup f memory-destructor boa |dispose drop ; inline

4
core/parser/parser.factor
View File

@ -207,7 +207,7 @@ SYMBOL: in
: add-use ( seq -- ) [ use+ ] each ;
: set-use ( seq -- )
[ vocab-words ] map [ ] filter >vector use set ;
[ vocab-words ] V{ } map-as sift use set ;
: check-vocab-string ( name -- name )
dup string?
@ -278,7 +278,7 @@ M: no-word-error summary
dup forward-reference? [
drop
use get
[ at ] with map [ ] filter
[ at ] with map sift
[ forward-reference? not ] find nip
] [
nip

2
core/prettyprint/sections/sections.factor
View File

@ -309,7 +309,7 @@ M: f section-end-group? drop f ;
2dup 1+ swap ?nth next set
swap nth dup split-before dup , split-after
] with each
] { } make { t } split [ empty? not ] filter ;
] { } make { t } split harvest ;
: break-group? ( seq -- ? )
[ first section-fits? ] [ peek section-fits? not ] bi and ;

6
core/sequences/sequences.factor
View File

@ -445,6 +445,12 @@ PRIVATE>
: remove ( obj seq -- newseq )
[ = not ] with filter ;
: sift ( seq -- newseq )
[ ] filter ;
: harvest ( seq -- newseq )
[ empty? not ] filter ;
: cache-nth ( i seq quot -- elt )
2over ?nth dup [
>r 3drop r>

2
core/slots/deprecated/deprecated.factor
View File

@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
{ [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] }
} cond
] 2map [ ] filter nip ;
] 2map sift nip ;
: slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ;

2
core/vocabs/vocabs.factor
View File

@ -76,7 +76,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
: words-named ( str -- seq )
dictionary get values
[ vocab-words at ] with map
[ ] filter ;
sift ;
: child-vocab? ( prefix name -- ? )
2dup = pick empty? or

3
extra/benchmark/sockets/sockets.factor
View File

@ -1,6 +1,7 @@
USING: io.sockets io kernel math threads io.encodings.ascii
io.streams.duplex debugger tools.time prettyprint
concurrency.count-downs namespaces arrays continuations ;
concurrency.count-downs namespaces arrays continuations
destructors ;
IN: benchmark.sockets
SYMBOL: counter

9
extra/bootstrap/image/download/download.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.image.download
USING: http.client checksums checksums.md5 splitting assocs
USING: http.client checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io ;
: url "http://factorcode.org/images/latest/" ;
@ -12,8 +12,11 @@ kernel io.files bootstrap.image sequences io ;
: need-new-image? ( image -- ? )
dup exists?
[ [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ]
[ drop t ] if ;
[
[ openssl-md5 checksum-file hex-string ]
[ download-checksums at ]
bi = not
] [ drop t ] if ;
: download-image ( arch -- )
boot-image-name dup need-new-image? [

6
extra/bootstrap/image/upload/upload.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.client checksums checksums.md5 splitting assocs
USING: checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io namespaces
io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload
@ -19,7 +19,9 @@ SYMBOL: upload-images-destination
: compute-checksums ( -- )
checksums ascii [
boot-image-names [
[ write bl ] [ md5 checksum-file hex-string print ] bi
[ write bl ]
[ openssl-md5 checksum-file hex-string print ]
bi
] each
] with-file-writer ;

4
extra/bunny/bunny.factor
View File

@ -4,7 +4,7 @@ opengl.glu shuffle http.client vectors namespaces ui.gadgets
ui.gadgets.canvas ui.render ui splitting combinators tools.time
system combinators.lib float-arrays continuations
opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
bunny.cel-shaded bunny.outlined bunny.model accessors ;
bunny.cel-shaded bunny.outlined bunny.model accessors destructors ;
IN: bunny
TUPLE: bunny-gadget model geom draw-seq draw-n ;
@ -33,7 +33,7 @@ M: bunny-gadget graft* ( gadget -- )
[ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ]
[ <bunny-outlined> ] tri 3array
[ ] filter >>draw-seq
sift >>draw-seq
0 >>draw-n
drop ;

5
extra/bunny/cel-shaded/cel-shaded.factor
View File

@ -1,5 +1,6 @@
USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders
opengl.capabilities opengl.gl sequences sequences.lib accessors ;
USING: arrays bunny.model continuations destructors kernel
multiline opengl opengl.shaders opengl.capabilities opengl.gl
sequences sequences.lib accessors ;
IN: bunny.cel-shaded
STRING: vertex-shader-source

2
extra/bunny/fixed-pipeline/fixed-pipeline.factor
View File

@ -1,4 +1,4 @@
USING: alien.c-types continuations kernel
USING: alien.c-types continuations destructors kernel
opengl opengl.gl bunny.model ;
IN: bunny.fixed-pipeline

5
extra/bunny/model/model.factor
View File

@ -2,11 +2,12 @@ USING: alien alien.c-types arrays sequences math math.vectors
math.matrices math.parser io io.files kernel opengl opengl.gl
opengl.glu io.encodings.ascii opengl.capabilities shuffle
http.client vectors splitting tools.time system combinators
float-arrays continuations namespaces sequences.lib accessors ;
float-arrays continuations destructors namespaces sequences.lib
accessors ;
IN: bunny.model
: numbers ( str -- seq )
" " split [ string>number ] map [ ] filter ;
" " split [ string>number ] map sift ;
: (parse-model) ( vs is -- vs is )
readln [

8
extra/bunny/outlined/outlined.factor
View File

@ -1,7 +1,7 @@
USING: arrays bunny.model bunny.cel-shaded continuations kernel
math multiline opengl opengl.shaders opengl.framebuffers
opengl.gl opengl.capabilities sequences ui.gadgets combinators
accessors ;
USING: arrays bunny.model bunny.cel-shaded continuations
destructors kernel math multiline opengl opengl.shaders
opengl.framebuffers opengl.gl opengl.capabilities sequences
ui.gadgets combinators accessors ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source

7
extra/cairo/cairo-tests.factor
View File

@ -1,7 +0,0 @@
USING: cairo math.parser kernel sequences tools.test ;
IN: cairo.tests
[ t ] [ ! apply a little pressure to cairo_version
cairo_version number>string CHAR: 0 swap remove
CHAR: . cairo_version_string remove =
] unit-test

984
extra/cairo/cairo.factor Normal file → Executable file
View File

@ -1,968 +1,36 @@
! Copyright (c) 2007 Sampo Vuori
! Copyright (c) 2008 Matthew Willis
!
! Adapted from cairo.h, version 1.5.14
! License: http://factorcode.org/license.txt
USING: system combinators alien alien.syntax kernel
alien.c-types accessors sequences arrays ui.gadgets ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: cairo.ffi kernel accessors sequences
namespaces fry continuations destructors ;
IN: cairo
<< "cairo" {
{ [ os winnt? ] [ "libcairo-2.dll" ] }
{ [ os macosx? ] [ "libcairo.dylib" ] }
{ [ os unix? ] [ "libcairo.so.2" ] }
} cond "cdecl" add-library >>
LIBRARY: cairo
TUPLE: cairo-t alien ;
C: <cairo-t> cairo-t
M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
FUNCTION: int cairo_version ( ) ;
FUNCTION: char* cairo_version_string ( ) ;
TUPLE: cairo-surface-t alien ;
C: <cairo-surface-t> cairo-surface-t
M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
TYPEDEF: int cairo_bool_t
: check-cairo ( cairo_status_t -- )
dup CAIRO_STATUS_SUCCESS = [ drop ]
[ cairo_status_to_string "Cairo error: " prepend throw ] if ;
! I am leaving these and other void* types as opaque structures
TYPEDEF: void* cairo_t
TYPEDEF: void* cairo_surface_t
SYMBOL: cairo
: cr ( -- cairo ) cairo get ;
C-STRUCT: cairo_matrix_t
{ "double" "xx" }
{ "double" "yx" }
{ "double" "xy" }
{ "double" "yy" }
{ "double" "x0" }
{ "double" "y0" } ;
TYPEDEF: void* cairo_pattern_t
TYPEDEF: void* cairo_destroy_func_t
: cairo-destroy-func ( quot -- callback )
>r "void" { "void*" } "cdecl" r> alien-callback ; inline
! See cairo.h for details
C-STRUCT: cairo_user_data_key_t
{ "int" "unused" } ;
TYPEDEF: int cairo_status_t
C-ENUM:
CAIRO_STATUS_SUCCESS
CAIRO_STATUS_NO_MEMORY
CAIRO_STATUS_INVALID_RESTORE
CAIRO_STATUS_INVALID_POP_GROUP
CAIRO_STATUS_NO_CURRENT_POINT
CAIRO_STATUS_INVALID_MATRIX
CAIRO_STATUS_INVALID_STATUS
CAIRO_STATUS_NULL_POINTER
CAIRO_STATUS_INVALID_STRING
CAIRO_STATUS_INVALID_PATH_DATA
CAIRO_STATUS_READ_ERROR
CAIRO_STATUS_WRITE_ERROR
CAIRO_STATUS_SURFACE_FINISHED
CAIRO_STATUS_SURFACE_TYPE_MISMATCH
CAIRO_STATUS_PATTERN_TYPE_MISMATCH
CAIRO_STATUS_INVALID_CONTENT
CAIRO_STATUS_INVALID_FORMAT
CAIRO_STATUS_INVALID_VISUAL
CAIRO_STATUS_FILE_NOT_FOUND
CAIRO_STATUS_INVALID_DASH
CAIRO_STATUS_INVALID_DSC_COMMENT
CAIRO_STATUS_INVALID_INDEX
CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
CAIRO_STATUS_TEMP_FILE_ERROR
CAIRO_STATUS_INVALID_STRIDE ;
TYPEDEF: int cairo_content_t
: CAIRO_CONTENT_COLOR HEX: 1000 ;
: CAIRO_CONTENT_ALPHA HEX: 2000 ;
: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
TYPEDEF: void* cairo_write_func_t
: cairo-write-func ( quot -- callback )
>r "cairo_status_t" { "void*" "uchar*" "int" }
"cdecl" r> alien-callback ; inline
TYPEDEF: void* cairo_read_func_t
: cairo-read-func ( quot -- callback )
>r "cairo_status_t" { "void*" "uchar*" "int" }
"cdecl" r> alien-callback ; inline
! Functions for manipulating state objects
FUNCTION: cairo_t*
cairo_create ( cairo_surface_t* target ) ;
FUNCTION: cairo_t*
cairo_reference ( cairo_t* cr ) ;
FUNCTION: void
cairo_destroy ( cairo_t* cr ) ;
FUNCTION: uint
cairo_get_reference_count ( cairo_t* cr ) ;
FUNCTION: void*
cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
FUNCTION: void
cairo_save ( cairo_t* cr ) ;
FUNCTION: void
cairo_restore ( cairo_t* cr ) ;
FUNCTION: void
cairo_push_group ( cairo_t* cr ) ;
FUNCTION: void
cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ;
FUNCTION: cairo_pattern_t*
cairo_pop_group ( cairo_t* cr ) ;
FUNCTION: void
cairo_pop_group_to_source ( cairo_t* cr ) ;
! Modify state
TYPEDEF: int cairo_operator_t
C-ENUM:
CAIRO_OPERATOR_CLEAR
CAIRO_OPERATOR_SOURCE
CAIRO_OPERATOR_OVER
CAIRO_OPERATOR_IN
CAIRO_OPERATOR_OUT
CAIRO_OPERATOR_ATOP
CAIRO_OPERATOR_DEST
CAIRO_OPERATOR_DEST_OVER
CAIRO_OPERATOR_DEST_IN
CAIRO_OPERATOR_DEST_OUT
CAIRO_OPERATOR_DEST_ATOP
CAIRO_OPERATOR_XOR
CAIRO_OPERATOR_ADD
CAIRO_OPERATOR_SATURATE ;
FUNCTION: void
cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ;
FUNCTION: void
cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ;
FUNCTION: void
cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ;
FUNCTION: void
cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ;
FUNCTION: void
cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ;
FUNCTION: void
cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
TYPEDEF: int cairo_antialias_t
C-ENUM:
CAIRO_ANTIALIAS_DEFAULT
CAIRO_ANTIALIAS_NONE
CAIRO_ANTIALIAS_GRAY
CAIRO_ANTIALIAS_SUBPIXEL ;
FUNCTION: void
cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
TYPEDEF: int cairo_fill_rule_t
C-ENUM:
CAIRO_FILL_RULE_WINDING
CAIRO_FILL_RULE_EVEN_ODD ;
FUNCTION: void
cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
FUNCTION: void
cairo_set_line_width ( cairo_t* cr, double width ) ;
TYPEDEF: int cairo_line_cap_t
C-ENUM:
CAIRO_LINE_CAP_BUTT
CAIRO_LINE_CAP_ROUND
CAIRO_LINE_CAP_SQUARE ;
FUNCTION: void
cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
TYPEDEF: int cairo_line_join_t
C-ENUM:
CAIRO_LINE_JOIN_MITER
CAIRO_LINE_JOIN_ROUND
CAIRO_LINE_JOIN_BEVEL ;
FUNCTION: void
cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ;
FUNCTION: void
cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ;
FUNCTION: void
cairo_set_miter_limit ( cairo_t* cr, double limit ) ;
FUNCTION: void
cairo_translate ( cairo_t* cr, double tx, double ty ) ;
FUNCTION: void
cairo_scale ( cairo_t* cr, double sx, double sy ) ;
FUNCTION: void
cairo_rotate ( cairo_t* cr, double angle ) ;
FUNCTION: void
cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_identity_matrix ( cairo_t* cr ) ;
FUNCTION: void
cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ;
FUNCTION: void
cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ;
FUNCTION: void
cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ;
FUNCTION: void
cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
! Path creation functions
FUNCTION: void
cairo_new_path ( cairo_t* cr ) ;
FUNCTION: void
cairo_move_to ( cairo_t* cr, double x, double y ) ;
FUNCTION: void
cairo_new_sub_path ( cairo_t* cr ) ;
FUNCTION: void
cairo_line_to ( cairo_t* cr, double x, double y ) ;
FUNCTION: void
cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ;
FUNCTION: void
cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
FUNCTION: void
cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
FUNCTION: void
cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ;
FUNCTION: void
cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ;
FUNCTION: void
cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ;
FUNCTION: void
cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ;
FUNCTION: void
cairo_close_path ( cairo_t* cr ) ;
FUNCTION: void
cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
! Painting functions
FUNCTION: void
cairo_paint ( cairo_t* cr ) ;
FUNCTION: void
cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ;
FUNCTION: void
cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ;
FUNCTION: void
cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ;
FUNCTION: void
cairo_stroke ( cairo_t* cr ) ;
FUNCTION: void
cairo_stroke_preserve ( cairo_t* cr ) ;
FUNCTION: void
cairo_fill ( cairo_t* cr ) ;
FUNCTION: void
cairo_fill_preserve ( cairo_t* cr ) ;
FUNCTION: void
cairo_copy_page ( cairo_t* cr ) ;
FUNCTION: void
cairo_show_page ( cairo_t* cr ) ;
! Insideness testing
FUNCTION: cairo_bool_t
cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
FUNCTION: cairo_bool_t
cairo_in_fill ( cairo_t* cr, double x, double y ) ;
! Rectangular extents
FUNCTION: void
cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
FUNCTION: void
cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
! Clipping
FUNCTION: void
cairo_reset_clip ( cairo_t* cr ) ;
FUNCTION: void
cairo_clip ( cairo_t* cr ) ;
FUNCTION: void
cairo_clip_preserve ( cairo_t* cr ) ;
FUNCTION: void
cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
C-STRUCT: cairo_rectangle_t
{ "double" "x" }
{ "double" "y" }
{ "double" "width" }
{ "double" "height" } ;
: <cairo-rect> ( x y width height -- cairo_rectangle_t )
"cairo_rectangle_t" <c-object> dup
{
[ set-cairo_rectangle_t-height ] [ set-cairo_rectangle_t-width ]
[ set-cairo_rectangle_t-y ] [ set-cairo_rectangle_t-x ]
} cleave ;
: (with-cairo) ( cairo-t quot -- )
>r alien>> cairo r> [ cr cairo_status check-cairo ]
compose with-variable ; inline
: rect>cairo ( rect -- cairo_rectangle_t )
[ loc>> ] [ dim>> ] bi [ [ first ] [ second ] bi ] bi@
<cairo-rect> ;
: with-cairo ( cairo quot -- )
>r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
: cairo>rect ( cairo_rectangle_t -- rect )
{
[ cairo_rectangle_t-x ] [ cairo_rectangle_t-y ]
[ cairo_rectangle_t-width ] [ cairo_rectangle_t-height ]
} cleave
[ 2array ] 2bi@ <rect> ;
C-STRUCT: cairo_rectangle_list_t
{ "cairo_status_t" "status" }
{ "cairo_rectangle_t*" "rectangles" }
{ "int" "num_rectangles" } ;
: (with-surface) ( cairo-surface-t quot -- )
>r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
FUNCTION: cairo_rectangle_list_t*
cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
: with-surface ( cairo_surface quot -- )
>r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
FUNCTION: void
cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ;
! Font/Text functions
TYPEDEF: void* cairo_scaled_font_t
TYPEDEF: void* cairo_font_face_t
C-STRUCT: cairo_glyph_t
{ "ulong" "index" }
{ "double" "x" }
{ "double" "y" } ;
C-STRUCT: cairo_text_extents_t
{ "double" "x_bearing" }
{ "double" "y_bearing" }
{ "double" "width" }
{ "double" "height" }
{ "double" "x_advance" }
{ "double" "y_advance" } ;
C-STRUCT: cairo_font_extents_t
{ "double" "ascent" }
{ "double" "descent" }
{ "double" "height" }
{ "double" "max_x_advance" }
{ "double" "max_y_advance" } ;
TYPEDEF: int cairo_font_slant_t
C-ENUM:
CAIRO_FONT_SLANT_NORMAL
CAIRO_FONT_SLANT_ITALIC
CAIRO_FONT_SLANT_OBLIQUE ;
TYPEDEF: int cairo_font_weight_t
C-ENUM:
CAIRO_FONT_WEIGHT_NORMAL
CAIRO_FONT_WEIGHT_BOLD ;
TYPEDEF: int cairo_subpixel_order_t
C-ENUM:
CAIRO_SUBPIXEL_ORDER_DEFAULT
CAIRO_SUBPIXEL_ORDER_RGB
CAIRO_SUBPIXEL_ORDER_BGR
CAIRO_SUBPIXEL_ORDER_VRGB
CAIRO_SUBPIXEL_ORDER_VBGR ;
TYPEDEF: int cairo_hint_style_t
C-ENUM:
CAIRO_HINT_STYLE_DEFAULT
CAIRO_HINT_STYLE_NONE
CAIRO_HINT_STYLE_SLIGHT
CAIRO_HINT_STYLE_MEDIUM
CAIRO_HINT_STYLE_FULL ;
TYPEDEF: int cairo_hint_metrics_t
C-ENUM:
CAIRO_HINT_METRICS_DEFAULT
CAIRO_HINT_METRICS_OFF
CAIRO_HINT_METRICS_ON ;
TYPEDEF: void* cairo_font_options_t
FUNCTION: cairo_font_options_t*
cairo_font_options_create ( ) ;
FUNCTION: cairo_font_options_t*
cairo_font_options_copy ( cairo_font_options_t* original ) ;
FUNCTION: void
cairo_font_options_destroy ( cairo_font_options_t* options ) ;
FUNCTION: cairo_status_t
cairo_font_options_status ( cairo_font_options_t* options ) ;
FUNCTION: void
cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
FUNCTION: cairo_bool_t
cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
FUNCTION: ulong
cairo_font_options_hash ( cairo_font_options_t* options ) ;
FUNCTION: void
cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ;
FUNCTION: cairo_antialias_t
cairo_font_options_get_antialias ( cairo_font_options_t* options ) ;
FUNCTION: void
cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ;
FUNCTION: cairo_subpixel_order_t
cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ;
FUNCTION: void
cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ;
FUNCTION: cairo_hint_style_t
cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ;
FUNCTION: void
cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ;
FUNCTION: cairo_hint_metrics_t
cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
! This interface is for dealing with text as text, not caring about the
! font object inside the the cairo_t.
FUNCTION: void
cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
FUNCTION: void
cairo_set_font_size ( cairo_t* cr, double size ) ;
FUNCTION: void
cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
FUNCTION: void
cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
FUNCTION: void
cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ;
FUNCTION: cairo_font_face_t*
cairo_get_font_face ( cairo_t* cr ) ;
FUNCTION: void
cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ;
FUNCTION: cairo_scaled_font_t*
cairo_get_scaled_font ( cairo_t* cr ) ;
FUNCTION: void
cairo_show_text ( cairo_t* cr, char* utf8 ) ;
FUNCTION: void
cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
FUNCTION: void
cairo_text_path ( cairo_t* cr, char* utf8 ) ;
FUNCTION: void
cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
FUNCTION: void
cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
FUNCTION: void
cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
FUNCTION: void
cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ;
! Generic identifier for a font style
FUNCTION: cairo_font_face_t*
cairo_font_face_reference ( cairo_font_face_t* font_face ) ;
FUNCTION: void
cairo_font_face_destroy ( cairo_font_face_t* font_face ) ;
FUNCTION: uint
cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
FUNCTION: cairo_status_t
cairo_font_face_status ( cairo_font_face_t* font_face ) ;
TYPEDEF: int cairo_font_type_t
C-ENUM:
CAIRO_FONT_TYPE_TOY
CAIRO_FONT_TYPE_FT
CAIRO_FONT_TYPE_WIN32
CAIRO_FONT_TYPE_QUARTZ ;
FUNCTION: cairo_font_type_t
cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
FUNCTION: void*
cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
! Portable interface to general font features.
FUNCTION: cairo_scaled_font_t*
cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ;
FUNCTION: cairo_scaled_font_t*
cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: void
cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: uint
cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: cairo_status_t
cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: cairo_font_type_t
cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: void*
cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
FUNCTION: void
cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
FUNCTION: void
cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
FUNCTION: void
cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
FUNCTION: cairo_font_face_t*
cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: void
cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ;
FUNCTION: void
cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ;
FUNCTION: void
cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ;
! Query functions
FUNCTION: cairo_operator_t
cairo_get_operator ( cairo_t* cr ) ;
FUNCTION: cairo_pattern_t*
cairo_get_source ( cairo_t* cr ) ;
FUNCTION: double
cairo_get_tolerance ( cairo_t* cr ) ;
FUNCTION: cairo_antialias_t
cairo_get_antialias ( cairo_t* cr ) ;
FUNCTION: cairo_bool_t
cairo_has_current_point ( cairo_t* cr ) ;
FUNCTION: void
cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ;
FUNCTION: cairo_fill_rule_t
cairo_get_fill_rule ( cairo_t* cr ) ;
FUNCTION: double
cairo_get_line_width ( cairo_t* cr ) ;
FUNCTION: cairo_line_cap_t
cairo_get_line_cap ( cairo_t* cr ) ;
FUNCTION: cairo_line_join_t
cairo_get_line_join ( cairo_t* cr ) ;
FUNCTION: double
cairo_get_miter_limit ( cairo_t* cr ) ;
FUNCTION: int
cairo_get_dash_count ( cairo_t* cr ) ;
FUNCTION: void
cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ;
FUNCTION: void
cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
FUNCTION: cairo_surface_t*
cairo_get_target ( cairo_t* cr ) ;
FUNCTION: cairo_surface_t*
cairo_get_group_target ( cairo_t* cr ) ;
TYPEDEF: int cairo_path_data_type_t
C-ENUM:
CAIRO_PATH_MOVE_TO
CAIRO_PATH_LINE_TO
CAIRO_PATH_CURVE_TO
CAIRO_PATH_CLOSE_PATH ;
! NEED TO DO UNION HERE
C-STRUCT: cairo_path_data_t-point
{ "double" "x" }
{ "double" "y" } ;
C-STRUCT: cairo_path_data_t-header
{ "cairo_path_data_type_t" "type" }
{ "int" "length" } ;
C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
C-STRUCT: cairo_path_t
{ "cairo_status_t" "status" }
{ "cairo_path_data_t*" "data" }
{ "int" "num_data" } ;
FUNCTION: cairo_path_t*
cairo_copy_path ( cairo_t* cr ) ;
FUNCTION: cairo_path_t*
cairo_copy_path_flat ( cairo_t* cr ) ;
FUNCTION: void
cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ;
FUNCTION: void
cairo_path_destroy ( cairo_path_t* path ) ;
! Error status queries
FUNCTION: cairo_status_t
cairo_status ( cairo_t* cr ) ;
FUNCTION: char*
cairo_status_to_string ( cairo_status_t status ) ;
! Surface manipulation
FUNCTION: cairo_surface_t*
cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ;
FUNCTION: cairo_surface_t*
cairo_surface_reference ( cairo_surface_t* surface ) ;
FUNCTION: void
cairo_surface_finish ( cairo_surface_t* surface ) ;
FUNCTION: void
cairo_surface_destroy ( cairo_surface_t* surface ) ;
FUNCTION: uint
cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
FUNCTION: cairo_status_t
cairo_surface_status ( cairo_surface_t* surface ) ;
TYPEDEF: int cairo_surface_type_t
C-ENUM:
CAIRO_SURFACE_TYPE_IMAGE
CAIRO_SURFACE_TYPE_PDF
CAIRO_SURFACE_TYPE_PS
CAIRO_SURFACE_TYPE_XLIB
CAIRO_SURFACE_TYPE_XCB
CAIRO_SURFACE_TYPE_GLITZ
CAIRO_SURFACE_TYPE_QUARTZ
CAIRO_SURFACE_TYPE_WIN32
CAIRO_SURFACE_TYPE_BEOS
CAIRO_SURFACE_TYPE_DIRECTFB
CAIRO_SURFACE_TYPE_SVG
CAIRO_SURFACE_TYPE_OS2
CAIRO_SURFACE_TYPE_WIN32_PRINTING
CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ;
FUNCTION: cairo_surface_type_t
cairo_surface_get_type ( cairo_surface_t* surface ) ;
FUNCTION: cairo_content_t
cairo_surface_get_content ( cairo_surface_t* surface ) ;
FUNCTION: cairo_status_t
cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
FUNCTION: cairo_status_t
cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
FUNCTION: void*
cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
FUNCTION: void
cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ;
FUNCTION: void
cairo_surface_flush ( cairo_surface_t* surface ) ;
FUNCTION: void
cairo_surface_mark_dirty ( cairo_surface_t* surface ) ;
FUNCTION: void
cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ;
FUNCTION: void
cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ;
FUNCTION: void
cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ;
FUNCTION: void
cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ;
FUNCTION: void
cairo_surface_copy_page ( cairo_surface_t* surface ) ;
FUNCTION: void
cairo_surface_show_page ( cairo_surface_t* surface ) ;
! Image-surface functions
TYPEDEF: int cairo_format_t
C-ENUM:
CAIRO_FORMAT_ARGB32
CAIRO_FORMAT_RGB24
CAIRO_FORMAT_A8
CAIRO_FORMAT_A1
CAIRO_FORMAT_RGB16_565 ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create ( cairo_format_t format, int width, int height ) ;
FUNCTION: int
cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
FUNCTION: uchar*
cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
FUNCTION: cairo_format_t
cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
FUNCTION: int
cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
FUNCTION: int
cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
FUNCTION: int
cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_from_png ( char* filename ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
! Pattern creation functions
FUNCTION: cairo_pattern_t*
cairo_pattern_create_rgb ( double red, double green, double blue ) ;
FUNCTION: cairo_pattern_t*
cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ;
FUNCTION: cairo_pattern_t*
cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ;
FUNCTION: cairo_pattern_t*
cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ;
FUNCTION: cairo_pattern_t*
cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ;
FUNCTION: cairo_pattern_t*
cairo_pattern_reference ( cairo_pattern_t* pattern ) ;
FUNCTION: void
cairo_pattern_destroy ( cairo_pattern_t* pattern ) ;
FUNCTION: uint
cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ;
FUNCTION: cairo_status_t
cairo_pattern_status ( cairo_pattern_t* pattern ) ;
FUNCTION: void*
cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
TYPEDEF: int cairo_pattern_type_t
C-ENUM:
CAIRO_PATTERN_TYPE_SOLID
CAIRO_PATTERN_TYPE_SURFACE
CAIRO_PATTERN_TYPE_LINEAR
CAIRO_PATTERN_TYPE_RADIA ;
FUNCTION: cairo_pattern_type_t
cairo_pattern_get_type ( cairo_pattern_t* pattern ) ;
FUNCTION: void
cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ;
FUNCTION: void
cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ;
FUNCTION: void
cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
TYPEDEF: int cairo_extend_t
C-ENUM:
CAIRO_EXTEND_NONE
CAIRO_EXTEND_REPEAT
CAIRO_EXTEND_REFLECT
CAIRO_EXTEND_PAD ;
FUNCTION: void
cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
FUNCTION: cairo_extend_t
cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
TYPEDEF: int cairo_filter_t
C-ENUM:
CAIRO_FILTER_FAST
CAIRO_FILTER_GOOD
CAIRO_FILTER_BEST
CAIRO_FILTER_NEAREST
CAIRO_FILTER_BILINEAR
CAIRO_FILTER_GAUSSIAN ;
FUNCTION: void
cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ;
FUNCTION: cairo_filter_t
cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ;
! Matrix functions
FUNCTION: void
cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ;
FUNCTION: void
cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
FUNCTION: void
cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
FUNCTION: void
cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ;
FUNCTION: void
cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
FUNCTION: void
cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
FUNCTION: void
cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ;
FUNCTION: cairo_status_t
cairo_matrix_invert ( cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ;
FUNCTION: void
cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ;
FUNCTION: void
cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ;
! Functions to be used while debugging (not intended for use in production code)
FUNCTION: void
cairo_debug_reset_static_data ( ) ;
: with-cairo-from-surface ( cairo_surface quot -- )
'[ cairo_create , with-cairo ] with-surface ; inline

1080
extra/cairo/ffi/ffi.factor
View File

File diff suppressed because it is too large Load Diff

2
extra/cairo/gadgets/gadgets.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
USING: cairo cairo.lib ui.render kernel opengl.gl opengl
USING: cairo cairo.ffi ui.render kernel opengl.gl opengl
math byte-arrays ui.gadgets accessors arrays
namespaces io.backend ;

36
extra/cairo/lib/lib.factor
View File

@ -1,36 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: cairo kernel accessors sequences
namespaces fry continuations ;
IN: cairo.lib
TUPLE: cairo-t alien ;
C: <cairo-t> cairo-t
M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
TUPLE: cairo-surface-t alien ;
C: <cairo-surface-t> cairo-surface-t
M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
: check-cairo ( cairo_status_t -- )
dup CAIRO_STATUS_SUCCESS = [ drop ]
[ cairo_status_to_string "Cairo error: " prepend throw ] if ;
SYMBOL: cairo
: cr ( -- cairo ) cairo get ;
: (with-cairo) ( cairo-t quot -- )
>r alien>> cairo r> [ cr cairo_status check-cairo ]
compose with-variable ; inline
: with-cairo ( cairo quot -- )
>r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
: (with-surface) ( cairo-surface-t quot -- )
>r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
: with-surface ( cairo_surface quot -- )
>r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
: with-cairo-from-surface ( cairo_surface quot -- )
'[ cairo_create , with-cairo ] with-surface ; inline

11
extra/cairo/samples/samples.factor
View File

@ -3,7 +3,7 @@
!
! these samples are a subset of the samples on
! http://cairographics.org/samples/
USING: cairo cairo.lib locals math.constants math
USING: cairo cairo.ffi locals math.constants math
io.backend kernel alien.c-types libc namespaces ;
IN: cairo.samples
@ -137,4 +137,11 @@ IN: cairo.samples
cr 0 256 cairo_rel_line_to
cr 0 128 cairo_move_to
cr 256 0 cairo_rel_line_to
cr cairo_stroke ;
cr cairo_stroke ;
USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
: samples ( -- )
{ arc clip clip-image dash gradient text utf8 }
[ 256 256 rot 1quotation <cached-cairo> gadget. ] each ;
MAIN: samples

2
extra/checksums/adler-32/adler-32-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
IN: checksums.adler-32
HELP: adler-32
{ $description "Adler-32 checksum algorithm." } ;
{ $class-description "Adler-32 checksum algorithm." } ;
ARTICLE: "checksums.adler-32" "Adler-32 checksum"
"The Adler-32 checksum algorithm implements simple and fast checksum. It is used in zlib and rsync."

2
extra/checksums/md5/md5-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
IN: checksums.md5
HELP: md5
{ $description "MD5 checksum algorithm." } ;
{ $class-description "MD5 checksum algorithm." } ;
ARTICLE: "checksums.md5" "MD5 checksum"
"The MD5 checksum algorithm implements a one-way hash function. While it is widely used, many weaknesses are known and it should not be used in new applications (" { $url "http://www.schneier.com/blog/archives/2005/03/more_hash_funct.html" } ")."

35
extra/checksums/openssl/openssl-docs.factor Normal file
View File

@ -0,0 +1,35 @@
IN: checksums.openssl
USING: help.syntax help.markup ;
HELP: openssl-checksum
{ $class-description "The class of checksum algorithms implemented by OpenSSL. The exact set of algorithms supported depends on how the OpenSSL library was compiled; " { $snippet "md5" } " and " { $snippet "sha1" } " should be universally available." } ;
HELP: <openssl-checksum> ( name -- checksum )
{ $values { "name" "an EVP message digest name" } { "checksum" openssl-checksum } }
{ $description "Creates a new OpenSSL checksum object." } ;
HELP: openssl-md5
{ $description "The OpenSSL MD5 message digest implementation." } ;
HELP: openssl-sha1
{ $description "The OpenSSL SHA1 message digest implementation." } ;
HELP: unknown-digest
{ $error-description "Thrown by checksum words if they are passed an " { $link openssl-checksum } " naming a message digest not supported by OpenSSL." } ;
ARTICLE: "checksums.openssl" "OpenSSL checksums"
"The OpenSSL library provides a large number of efficient checksum (message digest) algorithms which may be used independently of its SSL functionality."
{ $subsection openssl-checksum }
"Constructing a checksum from a known name:"
{ $subsection <openssl-checksum> }
"Two utility words:"
{ $subsection openssl-md5 }
{ $subsection openssl-sha1 }
"An error thrown if the digest name is unrecognized:"
{ $subsection unknown-digest }
"An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:"
{ $example "USING: byte-arrays checksums checksums.openssl prettyprint ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" }
"If we use the Factor implementation, we get the same result, just slightly slower:"
{ $example "USING: byte-arrays checksums checksums.sha1 prettyprint ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
ABOUT: "checksums.openssl"

28
extra/checksums/openssl/openssl-tests.factor Normal file
View File

@ -0,0 +1,28 @@
IN: checksums.openssl.tests
USING: byte-arrays checksums.openssl checksums tools.test
accessors kernel system ;
[
B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 }
]
[
"Hello world from the openssl binding" >byte-array
"md5" <openssl-checksum> checksum-bytes
] unit-test
[
B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49 82 115 0 }
]
[
"Hello world from the openssl binding" >byte-array
"sha1" <openssl-checksum> checksum-bytes
] unit-test
[
"Bad checksum test" >byte-array
"no such checksum" <openssl-checksum>
checksum-bytes
] [ [ unknown-digest? ] [ name>> "no such checksum" = ] bi and ]
must-fail-with
[ ] [ image openssl-sha1 checksum-file drop ] unit-test

63
extra/checksums/openssl/openssl.factor Normal file
View File

@ -0,0 +1,63 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types kernel continuations
destructors sequences io openssl openssl.libcrypto checksums ;
IN: checksums.openssl
ERROR: unknown-digest name ;
TUPLE: openssl-checksum name ;
: openssl-md5 T{ openssl-checksum f "md5" } ;
: openssl-sha1 T{ openssl-checksum f "sha1" } ;
INSTANCE: openssl-checksum checksum
C: <openssl-checksum> openssl-checksum
<PRIVATE
TUPLE: evp-md-context handle ;
: <evp-md-context> ( -- ctx )
"EVP_MD_CTX" <c-object>
dup EVP_MD_CTX_init evp-md-context boa ;
M: evp-md-context dispose
handle>> EVP_MD_CTX_cleanup drop ;
: with-evp-md-context ( quot -- )
maybe-init-ssl >r <evp-md-context> r> with-disposal ; inline
: digest-named ( name -- md )
dup EVP_get_digestbyname
[ ] [ unknown-digest ] ?if ;
: set-digest ( name ctx -- )
handle>> swap digest-named f EVP_DigestInit_ex ssl-error ;
: checksum-loop ( ctx -- )
dup handle>>
4096 read-partial dup [
dup length EVP_DigestUpdate ssl-error
checksum-loop
] [ 3drop ] if ;
: digest-value ( ctx -- value )
handle>>
EVP_MAX_MD_SIZE <byte-array> 0 <int>
[ EVP_DigestFinal_ex ssl-error ] 2keep
*int memory>byte-array ;
PRIVATE>
M: openssl-checksum checksum-stream
name>> swap [
[
[ set-digest ]
[ checksum-loop ]
[ digest-value ]
tri
] with-evp-md-context
] with-input-stream ;

2
extra/checksums/sha1/sha1-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
IN: checksums.sha1
HELP: sha1
{ $description "SHA1 checksum algorithm." } ;
{ $class-description "SHA1 checksum algorithm." } ;
ARTICLE: "checksums.sha1" "SHA1 checksum"
"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")."

2
extra/checksums/sha2/sha2-docs.factor
View File

@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
IN: checksums.sha2
HELP: sha-256
{ $description "SHA-256 checksum algorithm." } ;
{ $class-description "SHA-256 checksum algorithm." } ;
ARTICLE: "checksums.sha2" "SHA2 checksum"
"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong."

7
extra/combinators/lib/lib-tests.factor
View File

@ -19,6 +19,13 @@ IN: combinators.lib.tests
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
[ [ dup 2^ 2array ] 5 napply ] must-infer
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
[ { "foo" "xbarx" } ]
[
{ "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
] unit-test
! &&
[ t ] [

16
extra/combinators/lib/lib.factor
View File

@ -4,7 +4,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators fry namespaces quotations hashtables
sequences assocs arrays inference effects math math.ranges
arrays.lib shuffle macros bake continuations ;
arrays.lib shuffle macros continuations locals ;
IN: combinators.lib
@ -20,17 +20,15 @@ MACRO: nslip ( n -- ) dup saver [ call ] rot restorer 3append ;
MACRO: nkeep ( n -- )
[ ] [ 1+ ] [ ] tri
[ [ , ndup ] dip , -nrot , nslip ]
bake ;
'[ [ , ndup ] dip , -nrot , nslip ] ;
: 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline
MACRO: ncurry ( n -- ) [ curry ] n*quot ;
MACRO: nwith ( quot n -- )
tuck 1+ dup
[ , -nrot [ , nrot , call ] , ncurry ]
bake ;
MACRO:: nwith ( quot n -- )
[let | n' [ n 1+ ] |
[ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;
MACRO: napply ( n -- )
2 [a,b]
@ -110,8 +108,8 @@ MACRO: switch ( quot -- )
! : pcall ( seq quots -- seq ) [ call ] 2map ;
MACRO: parallel-call ( quots -- )
[ [ unclip % r> dup >r push ] bake ] map concat
[ V{ } clone >r % drop r> >array ] bake ;
[ '[ [ unclip @ ] dip [ push ] keep ] ] map concat
'[ V{ } clone @ nip >array ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! map-call and friends

2
extra/concurrency/distributed/distributed-tests.factor
View File

@ -13,7 +13,7 @@ concurrency.messaging continuations ;
[ ] [ test-node dup 1array swap (start-node) ] unit-test
[ ] [ yield ] unit-test
[ ] [ 100 sleep ] unit-test
[ ] [
[

12
extra/concurrency/exchangers/exchangers.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel threads boxes ;
USING: kernel threads boxes accessors ;
IN: concurrency.exchangers
! Motivated by
@ -12,10 +12,10 @@ TUPLE: exchanger thread object ;
<box> <box> exchanger boa ;
: exchange ( obj exchanger -- newobj )
dup exchanger-thread box-full? [
dup exchanger-object box>
>r exchanger-thread box> resume-with r>
dup thread>> occupied>> [
dup object>> box>
>r thread>> box> resume-with r>
] [
[ exchanger-object >box ] keep
[ exchanger-thread >box ] curry "exchange" suspend
[ object>> >box ] keep
[ thread>> >box ] curry "exchange" suspend
] if ;

2
extra/concurrency/mailboxes/mailboxes-tests.factor
View File

@ -1,7 +1,7 @@
IN: concurrency.mailboxes.tests
USING: concurrency.mailboxes concurrency.count-downs vectors
sequences threads tools.test math kernel strings namespaces
continuations calendar ;
continuations calendar destructors ;
[ V{ 1 2 3 } ] [
0 <vector>

16
extra/concurrency/mailboxes/mailboxes.factor
View File

@ -1,17 +1,13 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: concurrency.mailboxes
USING: dlists threads sequences continuations
USING: dlists threads sequences continuations destructors
namespaces random math quotations words kernel arrays assocs
init system concurrency.conditions accessors debugger ;
TUPLE: mailbox threads data closed ;
TUPLE: mailbox threads data disposed ;
: check-closed ( mailbox -- )
closed>> [ "Mailbox closed" throw ] when ; inline
M: mailbox dispose
t >>closed threads>> notify-all ;
M: mailbox dispose* threads>> notify-all ;
: <mailbox> ( -- mailbox )
<dlist> <dlist> f mailbox boa ;
@ -27,7 +23,7 @@ M: mailbox dispose
>r threads>> r> "mailbox" wait ;
: block-unless-pred ( mailbox timeout pred -- )
pick check-closed
pick check-disposed
pick data>> over dlist-contains? [
3drop
] [
@ -35,7 +31,7 @@ M: mailbox dispose
] if ; inline
: block-if-empty ( mailbox timeout -- mailbox )
over check-closed
over check-disposed
over mailbox-empty? [
2dup wait-for-mailbox block-if-empty
] [
@ -75,7 +71,7 @@ M: mailbox dispose
f swap mailbox-get-timeout? ; inline
: wait-for-close-timeout ( mailbox timeout -- )
over closed>>
over disposed>>
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
: wait-for-close ( mailbox -- )

21
extra/core-foundation/fsevents/fsevents.factor
View File

@ -3,7 +3,7 @@
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces assocs init accessors continuations
combinators core-foundation core-foundation.run-loop
io.encodings.utf8 ;
io.encodings.utf8 destructors ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
@ -187,7 +187,7 @@ SYMBOL: event-stream-callbacks
dup [ call drop ] [ 3drop ] if
] alien-callback ;
TUPLE: event-stream info handle closed ;
TUPLE: event-stream info handle disposed ;
: <event-stream> ( quot paths latency flags -- event-stream )
>r >r >r
@ -197,13 +197,10 @@ TUPLE: event-stream info handle closed ;
dup enable-event-stream
f event-stream boa ;
M: event-stream dispose
dup closed>> [ drop ] [
t >>closed
{
[ info>> remove-event-source-callback ]
[ handle>> disable-event-stream ]
[ handle>> FSEventStreamInvalidate ]
[ handle>> FSEventStreamRelease ]
} cleave
] if ;
M: event-stream dispose*
{
[ info>> remove-event-source-callback ]
[ handle>> disable-event-stream ]
[ handle>> FSEventStreamInvalidate ]
[ handle>> FSEventStreamRelease ]
} cleave ;

4
extra/db/db.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
USING: arrays assocs classes continuations destructors kernel math
namespaces sequences sequences.lib classes.tuple words strings
tools.walker accessors combinators.lib ;
IN: db
@ -25,7 +25,7 @@ GENERIC: make-db* ( seq class -- db )
GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- )
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
: dispose-statements ( assoc -- ) values dispose-each ;
: dispose-db ( db -- )
dup db [

4
extra/db/mysql/mysql.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for license.
USING: alien continuations io kernel prettyprint sequences
db db.mysql.ffi ;
USING: alien continuations destructors io kernel prettyprint
sequences db db.mysql.ffi ;
IN: db.mysql
TUPLE: mysql-db handle host user password db port ;

2
extra/db/pooling/pooling.factor
View File

@ -40,4 +40,4 @@ M: return-connection dispose
[ db>> ] [ pool>> ] bi return-connection ;
: return-connection-later ( db pool -- )
\ return-connection boa add-always-destructor ;
\ return-connection boa &dispose drop ;

1
extra/db/postgresql/ffi/ffi.factor
View File

@ -52,7 +52,6 @@ IN: db.postgresql.ffi
: InvalidOid 0 ; inline
TYPEDEF: int size_t
TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType
TYPEDEF: int PostgresPollingStatusType

12
extra/db/postgresql/lib/lib.factor
View File

@ -67,12 +67,10 @@ M: postgresql-result-null summary ( obj -- str )
in-params>> [ type>> type>oid ] map >c-uint-array ;
: malloc-byte-array/length
[ malloc-byte-array dup free-always ] [ length ] bi ;
[ malloc-byte-array &free ] [ length ] bi ;
: default-param-value
number>string* dup [
utf8 malloc-string dup free-always
] when 0 ;
number>string* dup [ utf8 malloc-string &free ] when 0 ;
: param-values ( statement -- seq seq2 )
[ bind-params>> ] [ in-params>> ] bi
@ -128,8 +126,8 @@ C: <postgresql-malloc-destructor> postgresql-malloc-destructor
M: postgresql-malloc-destructor dispose ( obj -- )
alien>> PQfreemem ;
: postgresql-free-always ( alien -- )
<postgresql-malloc-destructor> add-always-destructor ;
: &postgresql-free ( alien -- alien )
dup <postgresql-malloc-destructor> &dispose drop ; inline
: pq-get-blob ( handle row column -- obj/f )
[ PQgetvalue ] 3keep 3dup PQgetlength
@ -142,7 +140,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
PQunescapeBytea dup zero? [
postgresql-result-error-message throw
] [
dup postgresql-free-always
&postgresql-free
] if
] keep
*uint memory>byte-array

2
extra/db/postgresql/postgresql.factor
View File

@ -5,7 +5,7 @@ kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
namespaces.lib accessors random db.queries ;
namespaces.lib accessors random db.queries destructors ;
USE: tools.walker
IN: db.postgresql

2
extra/db/sqlite/sqlite.factor
View File

@ -6,7 +6,7 @@ prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators math.intervals
io namespaces.lib accessors vectors math.ranges random
math.bitfields.lib db.queries ;
math.bitfields.lib db.queries destructors ;
USE: tools.walker
IN: db.sqlite

2
extra/db/tuples/tuples.factor
View File

@ -3,7 +3,7 @@
USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
mirrors sequences.lib combinators.lib ;
destructors mirrors sequences.lib combinators.lib ;
IN: db.tuples
: define-persistent ( class table columns -- )

30
extra/destructors/destructors-docs.factor
View File

@ -1,30 +0,0 @@
USING: help.markup help.syntax libc kernel continuations ;
IN: destructors
HELP: free-always
{ $values { "alien" "alien returned by malloc" } }
{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " ends." }
{ $see-also free-later } ;
HELP: free-later
{ $values { "alien" "alien returned by malloc" } }
{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " errors or else the object will persist and manual cleanup is required later." }
{ $see-also free-always } ;
HELP: close-always
{ $values { "handle" "an OS-dependent handle" } }
{ $description "Adds a destructor that will close the system resource upon reaching the end of the quotation passed to " { $link with-destructors } "." }
{ $see-also close-later } ;
HELP: close-later
{ $values { "handle" "an OS-dependent handle" } }
{ $description "Adds a destructor that will close the system resource if an error occurs in the quotation passed to " { $link with-destructors } ". Otherwise, manual cleanup of the resource is required later." }
{ $see-also close-always } ;
HELP: with-destructors
{ $values { "quot" "a quotation" } }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $notes "Destructors are not allowed to throw exceptions. No exceptions." }
{ $examples
{ $code "[ 10 malloc free-always ] with-destructors" }
} ;

85
extra/destructors/destructors.factor
View File

@ -1,85 +0,0 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations io.backend io.nonblocking libc kernel
namespaces sequences system vectors ;
IN: destructors
SYMBOL: error-destructors
SYMBOL: always-destructors
TUPLE: destructor object destroyed? ;
M: destructor dispose
dup destructor-destroyed? [
drop
] [
dup destructor-object dispose
t swap set-destructor-destroyed?
] if ;
: <destructor> ( obj -- newobj )
f destructor boa ;
: add-error-destructor ( obj -- )
<destructor> error-destructors get push ;
: add-always-destructor ( obj -- )
<destructor> always-destructors get push ;
: do-always-destructors ( -- )
always-destructors get <reversed> dispose-each ;
: do-error-destructors ( -- )
error-destructors get <reversed> dispose-each ;
: with-destructors ( quot -- )
[
V{ } clone always-destructors set
V{ } clone error-destructors set
[ do-always-destructors ]
[ do-error-destructors ] cleanup
] with-scope ; inline
! Memory allocations
TUPLE: memory-destructor alien ;
C: <memory-destructor> memory-destructor
M: memory-destructor dispose ( obj -- )
memory-destructor-alien free ;
: free-always ( alien -- )
<memory-destructor> add-always-destructor ;
: free-later ( alien -- )
<memory-destructor> add-error-destructor ;
! Handles
TUPLE: handle-destructor alien ;
C: <handle-destructor> handle-destructor
M: handle-destructor dispose ( obj -- )
handle-destructor-alien close-handle ;
: close-always ( handle -- )
<handle-destructor> add-always-destructor ;
: close-later ( handle -- )
<handle-destructor> add-error-destructor ;
! Sockets
TUPLE: socket-destructor alien ;
C: <socket-destructor> socket-destructor
HOOK: destruct-socket io-backend ( obj -- )
M: socket-destructor dispose ( obj -- )
socket-destructor-alien destruct-socket ;
: close-socket-always ( handle -- )
<socket-destructor> add-always-destructor ;
: close-socket-later ( handle -- )
<socket-destructor> add-error-destructor ;

208
extra/ftp/client/client.factor
View File

@ -1,138 +1,164 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.singleton combinators continuations
io io.encodings.binary io.encodings.ascii io.files io.sockets
kernel math math.parser sequences splitting namespaces strings ;
USING: accessors arrays classes.singleton combinators
continuations io io.encodings.binary io.encodings.ascii
io.files io.sockets kernel io.streams.duplex math
math.parser sequences splitting namespaces strings fry ftp ;
IN: ftp.client
TUPLE: ftp-client host port stream user password mode ;
TUPLE: ftp-response n strings ;
SINGLETON: active
SINGLETON: passive
: <ftp-response> ( -- ftp-response )
ftp-response new
V{ } clone >>strings ;
: <ftp-client> ( host -- ftp-client )
ftp-client new
swap >>host
21 >>port
"anonymous" >>user
"factor-ftp@factorcode.org" >>password ;
: add-response-line ( ftp-response string -- ftp-response )
over strings>> push ;
: (ftp-response-code) ( str -- n )
3 head string>number ;
: ftp-response-code ( string -- n/f )
dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ;
: last-code ( ftp-response -- n )
strings>> peek (ftp-response-code) ;
: read-response-until ( stream ftp-response n -- ftp-response )
>r over stream-readln
: read-response-loop ( ftp-response -- ftp-response )
readln
[ add-response-line ] [ ftp-response-code ] bi
r> tuck = [ drop nip ] [ read-response-until ] if ;
over n>> = [ read-response-loop ] unless ;
: read-response ( stream -- ftp-response )
<ftp-response>
over stream-readln
[ add-response-line ] [ fourth CHAR: - = ] bi
[ dup last-code read-response-until ]
[ nip ] if dup last-code >>n ;
: read-response ( -- ftp-response )
<ftp-response> readln
[ (ftp-response-code) >>n ]
[ add-response-line ]
[ fourth CHAR: - = ] tri
[ read-response-loop ] when ;
: ftp-read ( ftp-client -- ftp-response )
stream>> read-response ;
: ftp-send ( str ftp-client -- )
stream>>
[ stream-write ]
[ "\r\n" swap stream-write ]
[ stream-flush ] tri ;
: ftp-command ( string ftp-client -- ftp-response )
[ ftp-send ] [ ftp-read ] bi ;
: ftp-command ( string -- ftp-response )
ftp-send read-response ;
: ftp-user ( ftp-client -- ftp-response )
[ user>> "USER " prepend ] [ ftp-command ] bi ;
user>> "USER " prepend ftp-command ;
: ftp-password ( ftp-client -- ftp-response )
[ password>> "PASS " prepend ] [ ftp-command ] bi ;
password>> "PASS " prepend ftp-command ;
: ftp-set-binary ( ftp-client -- ftp-response )
>r "TYPE I" r> ftp-command ;
: ftp-set-binary ( -- ftp-response )
"TYPE I" ftp-command ;
: ftp-pwd ( ftp-client -- ftp-response )
>r "PWD" r> ftp-command ;
: ftp-pwd ( -- ftp-response )
"PWD" ftp-command ;
: ftp-list ( ftp-client -- ftp-response )
>r "LIST" r> ftp-command ;
: ftp-list ( -- ftp-response )
"LIST" ftp-command ;
: ftp-quit ( ftp-client -- ftp-response )
>r "QUIT" r> ftp-command ;
: ftp-quit ( -- ftp-response )
"QUIT" ftp-command ;
: ftp-cwd ( directory ftp-client -- ftp-response )
>r "CWD " prepend r> ftp-command ;
: ftp-cwd ( directory -- ftp-response )
"CWD " prepend ftp-command ;
: ftp-retr ( filename ftp-client -- ftp-response )
>r "RETR " prepend r> ftp-command ;
: ftp-retr ( filename -- ftp-response )
"RETR " prepend ftp-command ;
: parse-epsv ( ftp-response -- port )
strings>> first
"|" split 2 tail* first string>number ;
: ftp-epsv ( ftp-client -- ftp-response )
>r "EPSV" r> ftp-command ;
TUPLE: remote-file
type permissions links owner group size month day time year name ;
M: ftp-client dispose ( ftp-client -- )
[ ftp-quit drop ] [ stream>> dispose ] bi ;
: <remote-file> ( -- remote-file ) remote-file new ;
: parse-permissions ( remote-file str -- remote-file )
[ first ch>type >>type ] [ rest >>permissions ] bi ;
: parse-list-9 ( lines -- seq )
[
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
[ 2 swap nth >>owner ]
[ 3 swap nth >>group ]
[ 4 swap nth string>number >>size ]
[ 5 swap nth >>month ]
[ 6 swap nth >>day ]
[ 7 swap nth >>time ]
[ 8 swap nth >>name ]
} cleave
] map ;
: parse-list-8 ( lines -- seq )
[
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
[ 2 swap nth >>owner ]
[ 3 swap nth >>size ]
[ 4 swap nth >>month ]
[ 5 swap nth >>day ]
[ 6 swap nth >>time ]
[ 7 swap nth >>name ]
} cleave
] map ;
: parse-list-3 ( lines -- seq )
[
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
[ 2 swap nth >>name ]
} cleave
] map ;
: parse-list ( ftp-response -- ftp-response )
dup strings>>
[ " " split harvest ] map
dup length {
{ 9 [ parse-list-9 ] }
{ 8 [ parse-list-8 ] }
{ 3 [ parse-list-3 ] }
[ drop ]
} case >>parsed ;
: ftp-epsv ( -- ftp-response )
"EPSV" ftp-command ;
ERROR: ftp-error got expected ;
: ftp-assert ( ftp-response n -- )
2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
: ftp-connect ( ftp-client -- )
dup
[ host>> ] [ port>> ] bi <inet> ascii <client>
>>stream drop ;
: ftp-login ( ftp-client -- )
{
[ ftp-connect ]
[ ftp-read 220 ftp-assert ]
[ ftp-user 331 ftp-assert ]
[ ftp-password 230 ftp-assert ]
[ ftp-set-binary 200 ftp-assert ]
} cleave ;
read-response 220 ftp-assert
[ ftp-user 331 ftp-assert ]
[ ftp-password 230 ftp-assert ] bi
ftp-set-binary 200 ftp-assert ;
: start-2nd ( ftp-client -- port )
ftp-epsv [ 229 ftp-assert ] [ parse-epsv ] bi ;
: open-remote-port ( -- port )
ftp-epsv
[ 229 ftp-assert ] [ parse-epsv ] bi ;
: list ( ftp-client -- ftp-response )
dup [ host>> ] [ start-2nd ] bi <inet> ascii <client>
over ftp-list 150 ftp-assert
lines <ftp-response> swap >>strings
>r ftp-read 226 ftp-assert r> ;
host>> open-remote-port <inet> ascii <client>
ftp-list 150 ftp-assert
lines
<ftp-response> swap >>strings
read-response 226 ftp-assert
parse-list ;
: ftp-get ( filename ftp-client -- ftp-response )
dup [ host>> ] [ start-2nd ] bi <inet> binary <client>
rot tuck
[ over ftp-retr 150 ftp-assert ]
[ binary <file-writer> stream-copy ] 2bi*
ftp-read dup 226 ftp-assert ;
host>> open-remote-port <inet> binary <client>
swap
[ ftp-retr 150 ftp-assert drop ]
[ binary <file-writer> stream-copy ] 2bi
read-response dup 226 ftp-assert ;
: ftp-connect ( ftp-client -- stream )
[ host>> ] [ port>> ] bi <inet> ascii <client> ;
GENERIC: ftp-download ( path obj -- )
: with-ftp-client ( ftp-client quot -- )
dupd '[
, [ ftp-login ] [ @ ] bi
ftp-quit drop
] >r ftp-connect r> with-stream ; inline
M: ftp-client ftp-download ( path ftp-client -- )
dup ftp-login
[ >r parent-directory r> ftp-cwd drop ]
[ >r file-name r> ftp-get drop ]
[ dispose drop ] 2tri ;
[
[ drop parent-directory ftp-cwd drop ]
[ >r file-name r> ftp-get drop ] 2bi
] with-ftp-client ;
M: string ftp-download ( path string -- )
<ftp-client> ftp-download ;

62
extra/ftp/ftp.factor Normal file
View File

@ -0,0 +1,62 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators io io.files kernel
math.parser sequences strings ;
IN: ftp
SINGLETON: active
SINGLETON: passive
TUPLE: ftp-client host port user password mode state ;
: <ftp-client> ( host -- ftp-client )
ftp-client new
swap >>host
21 >>port
"anonymous" >>user
"ftp@my.org" >>password ;
: reset-ftp-client ( ftp-client -- )
f >>user
f >>password
drop ;
TUPLE: ftp-response n strings parsed ;
: <ftp-response> ( -- ftp-response )
ftp-response new
V{ } clone >>strings ;
: add-response-line ( ftp-response string -- ftp-response )
over strings>> push ;
: ftp-send ( string -- ) write "\r\n" write flush ;
: ftp-ipv4 1 ; inline
: ftp-ipv6 2 ; inline
: ch>type ( ch -- type )
{
{ CHAR: d [ +directory+ ] }
{ CHAR: l [ +symbolic-link+ ] }
{ CHAR: - [ +regular-file+ ] }
[ drop +unknown+ ]
} case ;
: type>ch ( type -- string )
{
{ +directory+ [ CHAR: d ] }
{ +symbolic-link+ [ CHAR: l ] }
{ +regular-file+ [ CHAR: - ] }
[ drop CHAR: - ]
} case ;
: file-info>string ( file-info name -- string )
>r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ]
[ size>> number>string 15 CHAR: \s pad-left ] bi r>
3array " " join ;
: directory-list ( -- seq )
"" directory keys
[ [ link-info ] keep file-info>string ] map ;

174
extra/ftp/server/server.factor Normal file
View File

@ -0,0 +1,174 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.8-bit
io.files io.server io.sockets kernel math.parser
namespaces sequences ftp io.unix.launcher.parser
unicode.case splitting assocs ;
IN: ftp.server
SYMBOL: client
SYMBOL: stream
TUPLE: ftp-command raw tokenized ;
: <ftp-command> ( -- obj )
ftp-command new ;
: read-command ( -- ftp-command )
<ftp-command> readln
[ >>raw ] [ tokenize-command >>tokenized ] bi ;
: (send-response) ( n string separator -- )
rot number>string write write ftp-send ;
: send-response ( ftp-response -- )
[ n>> ] [ strings>> ] bi
[ but-last-slice [ "-" (send-response) ] with each ]
[ first " " (send-response) ] 2bi ;
: server-response ( n string -- )
<ftp-response>
swap add-response-line
swap >>n
send-response ;
: send-banner ( -- )
220 "Welcome to " host-name append server-response ;
: send-PASS-request ( -- )
331 "Please specify the password." server-response ;
: anonymous-only ( -- )
530 "This FTP server is anonymous only." server-response ;
: parse-USER ( ftp-command -- )
tokenized>> second client get swap >>user drop ;
: send-login-response ( -- )
! client get
230 "Login successful" server-response ;
: parse-PASS ( ftp-command -- )
tokenized>> second client get swap >>password drop ;
: send-quit-response ( ftp-command -- )
drop 221 "Goodbye." server-response ;
: ftp-error ( string -- )
500 "Unrecognized command: " rot append server-response ;
: send-type-error ( -- )
"TYPE is binary only" ftp-error ;
: send-type-success ( string -- )
200 "Switching to " rot " mode" 3append server-response ;
: parse-TYPE ( obj -- )
tokenized>> second >upper {
{ "IMAGE" [ "Binary" send-type-success ] }
{ "I" [ "Binary" send-type-success ] }
[ drop send-type-error ]
} case ;
: pwd-response ( -- )
257 current-directory get "\"" swap "\"" 3append server-response ;
! : random-local-inet ( -- spec )
! remote-address get class new 0 >>port ;
! : handle-LIST ( -- )
! random-local-inet ascii <server> ;
: handle-STOR ( obj -- )
;
! EPRT |2|::1|62138|
! : handle-EPRT ( obj -- )
! tokenized>> second "|" split harvest ;
! : handle-EPSV ( obj -- )
! 229 "Entering Extended Passive Mode (|||"
! random-local-inet ! get port number>string
! "|)" 3append server-response ;
! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
: handle-LPRT ( obj -- )
tokenized>> "," split ;
: start-directory ( -- )
150 "Here comes the directory listing." server-response ;
: finish-directory ( -- )
226 "Directory send OK." server-response ;
: send-directory-list ( stream -- )
[ directory-list write ] with-output-stream ;
: unrecognized-command ( obj -- ) raw>> ftp-error ;
: handle-client-loop ( -- )
<ftp-command> readln
[ >>raw ]
[ tokenize-command >>tokenized ] bi
dup tokenized>> first >upper {
{ "USER" [ parse-USER send-PASS-request t ] }
{ "PASS" [ parse-PASS send-login-response t ] }
{ "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
! { "CWD" [ ] }
! { "CDUP" [ ] }
! { "SMNT" [ ] }
! { "REIN" [ drop client get reset-ftp-client t ] }
{ "QUIT" [ send-quit-response f ] }
! { "PORT" [ ] }
! { "PASV" [ ] }
! { "MODE" [ ] }
{ "TYPE" [ parse-TYPE t ] }
! { "STRU" [ ] }
! { "ALLO" [ ] }
! { "REST" [ ] }
! { "STOR" [ handle-STOR t ] }
! { "STOU" [ ] }
! { "RETR" [ ] }
! { "LIST" [ drop handle-LIST t ] }
! { "NLST" [ ] }
! { "APPE" [ ] }
! { "RNFR" [ ] }
! { "RNTO" [ ] }
! { "DELE" [ ] }
! { "RMD" [ ] }
! { "MKD" [ ] }
{ "PWD" [ drop pwd-response t ] }
! { "ABOR" [ ] }
! { "SYST" [ drop ] }
! { "STAT" [ ] }
! { "HELP" [ ] }
! { "SITE" [ ] }
! { "NOOP" [ ] }
! { "EPRT" [ handle-eprt ] }
! { "LPRT" [ handle-lprt ] }
! { "EPSV" [ drop handle-epsv t ] }
! { "LPSV" [ drop handle-lpsv t ] }
[ drop unrecognized-command t ]
} case [ handle-client-loop ] when ;
: handle-client ( -- )
"" [
host-name <ftp-client> client set
send-banner handle-client-loop
] with-directory ;
: ftpd ( port -- )
internet-server "ftp.server"
latin1 [ handle-client ] with-server ;
: ftpd-main ( -- ) 2100 ftpd ;
MAIN: ftpd-main
! sudo tcpdump -i en1 -A -s 10000 tcp port 21

4
extra/hardware-info/linux/linux.factor
View File

@ -7,7 +7,7 @@ IN: hardware-info.linux
: uname ( -- seq )
65536 "char" <c-array> [ (uname) io-error ] keep
"\0" split [ empty? not ] filter [ >string ] map
"\0" split harvest [ >string ] map
6 "" pad-right ;
: sysname ( -- string ) uname first ;
@ -18,4 +18,4 @@ IN: hardware-info.linux
: domainname ( -- string ) uname 5 swap nth ;
: kernel-version ( -- seq )
release ".-" split [ ] filter 5 "" pad-right ;
release ".-" split harvest 5 "" pad-right ;

6
extra/help/handbook/handbook.factor
View File

@ -105,6 +105,7 @@ ARTICLE: "objects" "Objects"
"An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed."
{ $subsection "equality" }
{ $subsection "math.order" }
{ $subsection "destructors" }
{ $subsection "classes" }
{ $subsection "tuples" }
{ $subsection "generic" }
@ -207,7 +208,8 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.pipes" }
{ $heading "Other features" }
{ $subsection "io.timeouts" }
{ $subsection "checksums" } ;
{ $subsection "checksums" }
{ $see-also "destructors" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
@ -238,7 +240,7 @@ ARTICLE: "error-index" "Error index"
{ $index [ all-errors ] } ;
ARTICLE: "type-index" "Type index"
{ $index [ builtins get [ ] filter ] } ;
{ $index [ builtins get sift ] } ;
ARTICLE: "class-index" "Class index"
{ $index [ classes ] } ;

2
extra/help/help.factor
View File

@ -135,7 +135,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
":vars - list all variables at error time" print ;
: :help ( -- )
error get delegates [ error-help ] map [ ] filter
error get delegates [ error-help ] map sift
{
{ [ dup empty? ] [ (:help-none) ] }
{ [ dup length 1 = ] [ first help ] }

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.order math.parser namespaces
quotations assocs sequences strings words html.elements
xml.entities sbufs continuations ;
xml.entities sbufs continuations destructors ;
IN: html
GENERIC: browser-link-href ( presented -- href )

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

@ -77,12 +77,12 @@ IN: html.parser.analyzer
: find-by-attribute-key ( key vector -- vector )
>r >lower r>
[ tag-attributes at ] with filter
[ ] filter ;
sift ;
: find-by-attribute-key-value ( value key vector -- vector )
>r >lower r>
[ tag-attributes at over = ] with filter nip
[ ] filter ;
sift ;
: find-first-attribute-key-value ( value key vector -- i/f tag/f )
>r >lower r>

25
extra/http/client/client-tests.factor
View File

@ -1,9 +1,7 @@
USING: http.client http.client.private http tools.test
tuple-syntax namespaces ;
[ "localhost" 80 ] [ "localhost" parse-host ] unit-test
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test
@ -12,10 +10,11 @@ tuple-syntax namespaces ;
[
TUPLE{ request
protocol: http
method: "GET"
host: "www.apple.com"
path: "/index.html"
port: 80
path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } }
@ -26,3 +25,21 @@ tuple-syntax namespaces ;
<get-request>
] with-scope
] unit-test
[
TUPLE{ request
protocol: https
method: "GET"
host: "www.amazon.com"
port: 443
path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } }
}
] [
[
"https://www.amazon.com/index.html"
<get-request>
] with-scope
] unit-test

16
extra/http/client/client.factor
View File

@ -19,22 +19,8 @@ DEFER: http-request
<PRIVATE
: parse-url ( url -- resource host port )
"http://" ?head [ "Only http:// supported" throw ] unless
"/" split1 [ "/" prepend ] [ "/" ] if*
swap parse-host ;
: store-path ( request path -- request )
"?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
: request-with-url ( request url -- request )
parse-url >r >r store-path r> >>host r> >>port ;
SYMBOL: redirects
: absolute-url? ( url -- ? )
[ "http://" head? ] [ "https://" head? ] bi or ;
: do-redirect ( response data -- response data )
over code>> 300 399 between? [
drop
@ -42,7 +28,7 @@ SYMBOL: redirects
redirects get max-redirects < [
request get
swap "location" header dup absolute-url?
[ request-with-url ] [ store-path ] if
[ request-with-url ] [ request-with-path ] if
"GET" >>method http-request
] [
too-many-redirects

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

@ -45,6 +45,7 @@ blah
[
TUPLE{ request
protocol: http
port: 80
method: "GET"
path: "/bar"
@ -84,6 +85,7 @@ Host: www.sex.com
[
TUPLE{ request
protocol: http
port: 80
method: "HEAD"
path: "/bar"
@ -174,6 +176,8 @@ test-db [
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
yield
] with-scope
] unit-test

82
extra/http/http.factor
View File

@ -7,7 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format
io io.streams.string io.encodings.utf8 io.encodings.string
io.sockets
io.sockets io.sockets.secure
unicode.case unicode.categories qualified ;
@ -15,7 +15,31 @@ EXCLUDE: fry => , ;
IN: http
: http-port 80 ; inline
SINGLETON: http
SINGLETON: https
GENERIC: http-port ( protocol -- port )
M: http http-port drop 80 ;
M: https http-port drop 443 ;
GENERIC: protocol>string ( protocol -- string )
M: http protocol>string drop "http" ;
M: https protocol>string drop "https" ;
: string>protocol ( string -- protocol )
{
{ "http" [ http ] }
{ "https" [ https ] }
[ "Unknown protocol: " swap append throw ]
} case ;
: absolute-url? ( url -- ? )
[ "http://" head? ] [ "https://" head? ] bi or ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
@ -210,6 +234,7 @@ TUPLE: cookie name value path domain expires max-age http-only ;
[ unparse-cookie ] map concat "; " join ;
TUPLE: request
protocol
host
port
method
@ -227,7 +252,7 @@ cookies ;
: <request>
request new
"1.1" >>version
http-port >>port
http >>protocol
H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies
@ -240,6 +265,7 @@ cookies ;
pick query>> set-at ;
: chop-hostname ( str -- str' )
":" split1 "//" ?head drop nip
CHAR: / over index over length or tail
dup empty? [ drop "/" ] when ;
@ -247,7 +273,9 @@ cookies ;
#! Technically, only proxies are meant to support hostnames
#! in HTTP requests, but IE sends these sometimes so we
#! just chop the hostname part.
url-decode "http://" ?head [ chop-hostname ] when ;
url-decode
dup { "http://" "https://" } [ head? ] with contains?
[ chop-hostname ] when ;
: read-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless
@ -296,10 +324,11 @@ SYMBOL: max-post-request
: parse-host ( string -- host port )
"." ?tail drop ":" split1
[ string>number ] [ http-port ] if* ;
dup [ string>number ] when ;
: extract-host ( request -- request )
dup "host" header parse-host >r >>host r> >>port ;
dup [ "host" header parse-host ] keep protocol>> http-port or
[ >>host ] [ >>port ] bi* ;
: extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ;
@ -312,7 +341,7 @@ SYMBOL: max-post-request
dup "cookie" header [ parse-cookies >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
" " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ;
" " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
@ -351,12 +380,20 @@ SYMBOL: max-post-request
"application/x-www-form-urlencoded" >>post-data-type
] if ;
GENERIC: protocol-addr ( request protocol -- addr )
M: object protocol-addr
drop [ host>> ] [ port>> ] bi <inet> ;
M: https protocol-addr
call-next-method <ssl> ;
: request-addr ( request -- addr )
[ host>> ] [ port>> ] bi <inet> ;
dup protocol>> protocol-addr ;
: request-host ( request -- string )
[ host>> ] [ port>> ] bi
dup 80 = [ drop ] [ ":" swap number>string 3append ] if ;
[ host>> ] [ port>> ] bi dup http http-port =
[ drop ] [ ":" swap number>string 3append ] if ;
: write-request-header ( request -- request )
dup header>> >hashtable
@ -379,13 +416,32 @@ SYMBOL: max-post-request
flush
drop ;
: request-with-path ( request path -- request )
[ "/" prepend ] [ "/" ] if*
"?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ;
: request-with-url ( request url -- request )
":" split1
[ string>protocol >>protocol ]
[
"//" ?head [ "Invalid URL" throw ] unless
"/" split1
[
parse-host [ >>host ] [ >>port ] bi*
dup protocol>> http-port '[ , or ] change-port
]
[ request-with-path ]
bi*
] bi* ;
: request-url ( request -- url )
[
[
dup host>> [
[ "http://" write host>> url-encode write ]
[ ":" write port>> number>string write ]
bi
[ protocol>> protocol>string write "://" write ]
[ host>> url-encode write ":" write ]
[ [ port>> ] [ protocol>> http-port or ] bi number>string write ]
tri
] [ drop ] if
]
[ path>> "/" head? [ "/" write ] unless ]

2
extra/http/server/auth/login/login.factor
View File

@ -58,7 +58,7 @@ M: user-saver dispose
user>> dup changed?>> [ users update-user ] [ drop ] if ;
: save-user-after ( user -- )
<user-saver> add-always-destructor ;
<user-saver> &dispose drop ;
: login-template ( name -- template )
"resource:extra/http/server/auth/login/" swap ".xml"

1
extra/http/server/server-tests.factor
View File

@ -6,6 +6,7 @@ IN: http.server.tests
[
<request>
http >>protocol
"www.apple.com" >>host
"/xxx/bar" >>path
{ { "a" "b" } } >>query

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

@ -240,7 +240,7 @@ SYMBOL: exit-continuation
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
: split-path ( string -- path )
"/" split [ empty? not ] filter ;
"/" split harvest ;
: init-request ( -- )
H{ } clone base-paths set

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

@ -102,7 +102,7 @@ M: session-saver dispose
] [ drop ] if ;
: save-session-after ( session -- )
<session-saver> add-always-destructor ;
<session-saver> &dispose drop ;
: existing-session ( path session -- response )
[ session set ] [ save-session-after ] bi

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

@ -91,7 +91,7 @@ TUPLE: file-responder root hook special allow-listings ;
: serve-object ( filename -- response )
serving-path dup exists?
[ dup directory? [ serve-directory ] [ serve-file ] if ]
[ dup file-info directory? [ serve-directory ] [ serve-file ] if ]
[ drop <404> ]
if ;

3
extra/io/encodings/8-bit/8-bit.factor
View File

@ -37,8 +37,7 @@ IN: io.encodings.8-bit
2dup swap length <= [ tail ] [ drop ] if ;
: process-contents ( lines -- assoc )
[ "#" split1 drop ] map
[ empty? not ] filter
[ "#" split1 drop ] map harvest
[ "\t" split 2 head [ 2 tail-if hex> ] map ] map ;
: byte>ch ( assoc -- array )

2
extra/io/files/unique/unique-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io io.nonblocking kernel math
USING: help.markup help.syntax io io.ports kernel math
io.files.unique.private math.parser io.files ;
IN: io.files.unique

22
extra/io/launcher/launcher.factor
View File

@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
io.streams.duplex io.nonblocking ;
io.streams.duplex io.ports ;
IN: io.launcher
TUPLE: process < identity-tuple
@ -151,21 +151,21 @@ M: process timed-out kill-process ;
M: object run-pipeline-element
[ >process swap >>stdout swap >>stdin run-detached ]
[ drop [ [ close-handle ] when* ] bi@ ]
[ drop [ [ dispose ] when* ] bi@ ]
3bi
wait-for-process ;
: <process-reader*> ( process encoding -- process stream )
[
>r (pipe) {
[ add-error-destructor ]
[ |dispose drop ]
[
swap >process
[ swap out>> or ] change-stdout
run-detached
]
[ out>> close-handle ]
[ in>> <reader> ]
[ out>> dispose ]
[ in>> <input-port> ]
} cleave r> <decoder>
] with-destructors ;
@ -175,14 +175,14 @@ M: object run-pipeline-element
: <process-writer*> ( process encoding -- process stream )
[
>r (pipe) {
[ add-error-destructor ]
[ |dispose drop ]
[
swap >process
[ swap in>> or ] change-stdout
run-detached
]
[ in>> close-handle ]
[ out>> <writer> ]
[ in>> dispose ]
[ out>> <output-port> ]
} cleave r> <encoder>
] with-destructors ;
@ -192,15 +192,15 @@ M: object run-pipeline-element
: <process-stream*> ( process encoding -- process stream )
[
>r (pipe) (pipe) {
[ [ add-error-destructor ] bi@ ]
[ [ |dispose drop ] bi@ ]
[
rot >process
[ swap out>> or ] change-stdout
[ swap in>> or ] change-stdin
run-detached
]
[ [ in>> close-handle ] [ out>> close-handle ] bi* ]
[ [ in>> <reader> ] [ out>> <writer> ] bi* ]
[ [ out>> dispose ] [ in>> dispose ] bi* ]
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
} 2cleave r> <encoder-duplex>
] with-destructors ;

8
extra/io/mmap/mmap-docs.factor
View File

@ -1,4 +1,5 @@
USING: help.markup help.syntax alien math continuations ;
USING: help.markup help.syntax alien math continuations
destructors ;
IN: io.mmap
HELP: mapped-file
@ -15,6 +16,11 @@ HELP: <mapped-file>
{ $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: with-mapped-file
{ $values { "path" "a pathname string" } { "length" integer } { "quot" "a quotation with stack effect " { $snippet "( mmap -- )" } } }
{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: close-mapped-file
{ $values { "mmap" mapped-file } }
{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }

17
extra/io/mmap/mmap-tests.factor
View File

@ -2,11 +2,14 @@ USING: io io.mmap io.files kernel tools.test continuations
sequences io.encodings.ascii accessors ;
IN: io.mmap.tests
[ "resource:mmap-test-file.txt" delete-file ] ignore-errors
[ ] [ "12345" "resource:mmap-test-file.txt" ascii set-file-contents ] unit-test
[ ] [ "resource:mmap-test-file.txt" dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
[ 5 ] [ "resource:mmap-test-file.txt" dup file-info size>> [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "resource:mmap-test-file.txt" ascii file-contents ] unit-test
[ "resource:mmap-test-file.txt" delete-file ] ignore-errors
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
[ ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
[ ] [ "mmap-grow-test.txt" temp-file 100 [ drop ] with-mapped-file ] unit-test
[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test

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