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

Fix conflict

db4
U-SLAVA-DFB8FF805\Slava 2008-05-15 01:44:23 -05:00
parent 05466df1e0 46c76b8b1b
commit 667345e883
103 changed files with 635 additions and 728 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:"

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

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." } ;

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

@ -101,23 +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

10
core/continuations/continuations.factor
View File

@ -150,16 +150,6 @@ ERROR: attempt-all-error ;
] { } make peek swap [ rethrow ] when
] if ; 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
TUPLE: condition error restarts continuation ;
C: <condition> condition ( error restarts cc -- condition )

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"

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

@ -1,6 +1,23 @@
USING: destructors kernel tools.test continuations ;
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 +30,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

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

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" } }

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

@ -1,14 +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"

2
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 )

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 ;

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"

22
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
@ -76,3 +77,18 @@ PRIVATE>
: strlen ( alien -- len )
"size_t" "libc" "strlen" { "char*" } alien-invoke ;
<PRIVATE
! Memory allocations
TUPLE: memory-destructor alien ;
M: memory-destructor dispose* alien>> free ;
PRIVATE>
: &free ( alien -- alien )
dup memory-destructor boa &dispose drop ; inline
: |free ( alien -- alien )
dup memory-destructor boa |dispose drop ; inline

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

2
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.openssl 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

2
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 ;

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

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

@ -2,7 +2,8 @@ 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 )

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

2
extra/cairo/cairo.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: cairo.ffi kernel accessors sequences
namespaces fry continuations ;
namespaces fry continuations destructors ;
IN: cairo
TUPLE: cairo-t alien ;

2
extra/checksums/openssl/openssl.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays alien.c-types kernel continuations
sequences io openssl openssl.libcrypto checksums ;
destructors sequences io openssl openssl.libcrypto checksums ;
IN: checksums.openssl
ERROR: unknown-digest name ;

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 ;

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 -- )

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

@ -1,20 +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: 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" }
} ;

51
extra/destructors/destructors.factor
View File

@ -1,51 +0,0 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations io.backend libc
kernel namespaces sequences system vectors ;
IN: destructors
SYMBOL: error-destructors
SYMBOL: always-destructors
: add-error-destructor ( obj -- )
error-destructors get push ;
: add-always-destructor ( obj -- )
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
TUPLE: only-once object destroyed ;
M: only-once dispose
dup destroyed>> [ drop ] [
[ object>> dispose ] [ t >>destroyed drop ] bi
] if ;
: <only-once> f only-once boa ;
! Memory allocations
TUPLE: memory-destructor alien ;
C: <memory-destructor> memory-destructor
M: memory-destructor dispose ( obj -- )
alien>> free ;
: free-always ( alien -- )
<memory-destructor> <only-once> add-always-destructor ;
: free-later ( alien -- )
<memory-destructor> <only-once> add-error-destructor ;

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

@ -27,7 +27,6 @@ IN: ftp.client
: ftp-command ( string -- ftp-response )
ftp-send read-response ;
: ftp-user ( ftp-client -- ftp-response )
user>> "USER " prepend ftp-command ;
@ -56,21 +55,13 @@ IN: ftp.client
strings>> first
"|" split 2 tail* first string>number ;
: ch>attribute ( ch -- symbol )
{
{ CHAR: d [ +directory+ ] }
{ CHAR: l [ +symbolic-link+ ] }
{ CHAR: - [ +regular-file+ ] }
[ drop +unknown+ ]
} case ;
TUPLE: remote-file
type permissions links owner group size month day time year name ;
: <remote-file> ( -- remote-file ) remote-file new ;
: parse-permissions ( remote-file str -- remote-file )
[ first ch>attribute >>type ] [ rest >>permissions ] bi ;
[ first ch>type >>type ] [ rest >>permissions ] bi ;
: parse-list-9 ( lines -- seq )
[

37
extra/ftp/ftp.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel math.parser sequences ;
USING: accessors arrays assocs combinators io io.files kernel
math.parser sequences strings ;
IN: ftp
SINGLETON: active
@ -15,6 +16,11 @@ TUPLE: ftp-client host port user password mode state ;
"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 )
@ -25,3 +31,32 @@ TUPLE: ftp-response n strings parsed ;
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 ;

118
extra/ftp/server/server.factor
View File

@ -1,27 +1,30 @@
! 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 ;
unicode.case splitting assocs ;
IN: ftp.server
SYMBOL: client
SYMBOL: stream
TUPLE: ftp-client-command string tokenized ;
TUPLE: ftp-command raw tokenized ;
: <ftp-client-command> ( -- obj )
ftp-client-command new ;
: <ftp-command> ( -- obj )
ftp-command new ;
: read-client-command ( -- ftp-client-command )
<ftp-client-command> readln
[ >>string ] [ tokenize-command >>tokenized ] bi ;
: 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
2dup
but-last-slice [
[ number>string write "-" write ] [ ftp-send ] bi*
] with each
first [ number>string write bl ] [ ftp-send ] bi* ;
[ but-last-slice [ "-" (send-response) ] with each ]
[ first " " (send-response) ] 2bi ;
: server-response ( n string -- )
<ftp-response>
@ -35,72 +38,123 @@ TUPLE: ftp-client-command string tokenized ;
: send-PASS-request ( -- )
331 "Please specify the password." server-response ;
: parse-USER ( ftp-client-command -- )
: 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-client-command -- )
: parse-PASS ( ftp-command -- )
tokenized>> second client get swap >>password drop ;
: send-quit-response ( ftp-client-command -- )
: send-quit-response ( ftp-command -- )
drop 221 "Goodbye." server-response ;
: unimplemented-command ( ftp-client-command -- )
500 "Unimplemented command: " rot string>> append 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-client-command> readln
[ >>string ]
<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" [ ] }
{ "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
! { "CWD" [ ] }
! { "CDUP" [ ] }
! { "SMNT" [ ] }
! { "REIN" [ ] }
! { "REIN" [ drop client get reset-ftp-client t ] }
{ "QUIT" [ send-quit-response f ] }
! { "PORT" [ ] }
! { "PASV" [ ] }
! { "MODE" [ ] }
! { "TYPE" [ ] }
{ "TYPE" [ parse-TYPE t ] }
! { "STRU" [ ] }
! { "ALLO" [ ] }
! { "REST" [ ] }
! { "STOR" [ ] }
! { "STOR" [ handle-STOR t ] }
! { "STOU" [ ] }
! { "RETR" [ ] }
! { "LIST" [ ] }
! { "LIST" [ drop handle-LIST t ] }
! { "NLST" [ ] }
! { "LIST" [ ] }
! { "APPE" [ ] }
! { "RNFR" [ ] }
! { "RNTO" [ ] }
! { "DELE" [ ] }
! { "RMD" [ ] }
! { "MKD" [ ] }
! { "PWD" [ ] }
{ "PWD" [ drop pwd-response t ] }
! { "ABOR" [ ] }
! { "SYST" [ ] }
! { "SYST" [ drop ] }
! { "STAT" [ ] }
! { "HELP" [ ] }
! { "SITE" [ ] }
! { "NOOP" [ ] }
! { "EPRT" [ ] }
! { "LPRT" [ ] }
! { "EPSV" [ ] }
! { "LPSV" [ ] }
[ drop unimplemented-command t ]
! { "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 ( -- )

4
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" }

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 )

2
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"

4
extra/http/http.factor
View File

@ -265,7 +265,7 @@ cookies ;
pick query>> set-at ;
: chop-hostname ( str -- str' )
":" split1 nip
":" split1 "//" ?head drop nip
CHAR: / over index over length or tail
dup empty? [ drop "/" ] when ;
@ -440,7 +440,7 @@ M: https protocol-addr
dup host>> [
[ protocol>> protocol>string write "://" write ]
[ host>> url-encode write ":" write ]
[ port>> number>string write ]
[ [ port>> ] [ protocol>> http-port or ] bi number>string write ]
tri
] [ drop ] if
]

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/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 ;

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

@ -151,20 +151,20 @@ 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 ]
[ out>> dispose ]
[ in>> <input-port> ]
} cleave r> <decoder>
] with-destructors ;
@ -175,13 +175,13 @@ 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 ]
[ in>> dispose ]
[ out>> <output-port> ]
} cleave r> <encoder>
] with-destructors ;
@ -192,14 +192,14 @@ 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
]
[ [ out>> close-handle ] [ in>> close-handle ] bi* ]
[ [ out>> dispose ] [ in>> dispose ] bi* ]
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
} 2cleave r> <encoder-duplex>
] with-destructors ;

3
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

23
extra/io/mmap/mmap.factor
View File

@ -1,23 +1,19 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations io.backend kernel quotations sequences
system alien alien.accessors accessors sequences.private ;
USING: continuations destructors io.backend kernel quotations
sequences system alien alien.accessors accessors
sequences.private ;
IN: io.mmap
TUPLE: mapped-file address handle length closed ;
TUPLE: mapped-file address handle length disposed ;
: check-closed ( mapped-file -- mapped-file )
dup closed>> [
"Mapped file is closed" throw
] when ; inline
M: mapped-file length check-closed length>> ;
M: mapped-file length dup check-disposed length>> ;
M: mapped-file nth-unsafe
check-closed address>> swap alien-unsigned-1 ;
dup check-disposed address>> swap alien-unsigned-1 ;
M: mapped-file set-nth-unsafe
check-closed address>> swap set-alien-unsigned-1 ;
dup check-disposed address>> swap set-alien-unsigned-1 ;
INSTANCE: mapped-file sequence
@ -29,10 +25,7 @@ HOOK: (mapped-file) io-backend ( path length -- address handle )
HOOK: close-mapped-file io-backend ( mmap -- )
M: mapped-file dispose ( mmap -- )
dup closed>> [ drop ] [
t >>closed close-mapped-file
] if ;
M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
: with-mapped-file ( path length quot -- )
>r <mapped-file> r> with-disposal ; inline

2
extra/io/monitors/monitors-docs.factor
View File

@ -1,5 +1,5 @@
IN: io.monitors
USING: help.markup help.syntax continuations
USING: help.markup help.syntax continuations destructors
concurrency.mailboxes quotations ;
HELP: with-monitors

2
extra/io/monitors/monitors-tests.factor
View File

@ -1,7 +1,7 @@
IN: io.monitors.tests
USING: io.monitors tools.test io.files system sequences
continuations namespaces concurrency.count-downs kernel io
threads calendar prettyprint ;
threads calendar prettyprint destructors ;
os { winnt linux macosx } member? [
[

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

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend kernel continuations namespaces sequences
assocs hashtables sorting arrays threads boxes io.timeouts
accessors concurrency.mailboxes ;
USING: io.backend kernel continuations destructors namespaces
sequences assocs hashtables sorting arrays threads boxes
io.timeouts accessors concurrency.mailboxes ;
IN: io.monitors
HOOK: init-monitors io-backend ( -- )

3
extra/io/monitors/recursive/recursive-tests.factor
View File

@ -1,7 +1,6 @@
USING: accessors math kernel namespaces continuations
io.files io.monitors io.monitors.recursive io.backend
concurrency.mailboxes
tools.test ;
concurrency.mailboxes tools.test destructors ;
IN: io.monitors.recursive.tests
\ pump-thread must-infer

20
extra/io/monitors/recursive/recursive.factor
View File

@ -1,13 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences assocs arrays continuations combinators kernel
threads concurrency.messaging concurrency.mailboxes concurrency.promises
io.files io.monitors debugger ;
USING: accessors sequences assocs arrays continuations
destructors combinators kernel threads concurrency.messaging
concurrency.mailboxes concurrency.promises io.files io.monitors
debugger ;
IN: io.monitors.recursive
! Simulate recursive monitors on platforms that don't have them
TUPLE: recursive-monitor < monitor children thread ready ;
TUPLE: recursive-monitor < monitor children thread ready disposed ;
: notify? ( -- ? ) monitor tget ready>> promise-fulfilled? ;
@ -35,13 +36,10 @@ DEFER: add-child-monitor
: remove-child-monitor ( monitor -- )
monitor tget children>> delete-at* [ dispose ] [ drop ] if ;
M: recursive-monitor dispose
dup queue>> closed>> [
drop
] [
[ "stop" swap thread>> send-synchronous drop ]
[ queue>> dispose ] bi
] if ;
M: recursive-monitor dispose*
[ "stop" swap thread>> send-synchronous drop ]
[ queue>> dispose ]
bi ;
: stop-pump ( -- )
monitor tget children>> [ nip dispose ] assoc-each ;

2
extra/io/pipes/pipes-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax continuations io ;
USING: help.markup help.syntax continuations destructors io ;
IN: io.pipes
HELP: pipe

2
extra/io/pipes/pipes-tests.factor
View File

@ -1,6 +1,6 @@
USING: io io.pipes io.streams.string io.encodings.utf8
io.streams.duplex io.encodings io.timeouts namespaces
continuations tools.test kernel calendar ;
continuations tools.test kernel calendar destructors ;
IN: io.pipes.tests
[ "Hello" ] [

15
extra/io/pipes/pipes.factor
View File

@ -9,24 +9,21 @@ IN: io.pipes
TUPLE: pipe in out ;
M: pipe dispose ( pipe -- )
[ in>> close-handle ] [ out>> close-handle ] bi ;
[ in>> dispose ] [ out>> dispose ] bi ;
HOOK: (pipe) io-backend ( -- pipe )
: <pipe> ( encoding -- stream )
[
>r (pipe)
[ add-error-destructor ]
[ in>> <input-port> ]
[ out>> <output-port> ]
tri
>r (pipe) |dispose
[ in>> <input-port> ] [ out>> <output-port> ] bi
r> <encoder-duplex>
] with-destructors ;
<PRIVATE
: ?reader [ <input-port> dup add-always-destructor ] [ input-stream get ] if* ;
: ?writer [ <output-port> dup add-always-destructor ] [ output-stream get ] if* ;
: ?reader [ <input-port> &dispose ] [ input-stream get ] if* ;
: ?writer [ <output-port> &dispose ] [ output-stream get ] if* ;
GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
@ -38,7 +35,7 @@ M: callable run-pipeline-element
: <pipes> ( n -- pipes )
[
[ (pipe) dup add-error-destructor ] replicate
[ (pipe) |dispose ] replicate
T{ pipe } [ prefix ] [ suffix ] bi
2 <clumps>
] with-destructors ;

3
extra/io/ports/ports-docs.factor
View File

@ -1,5 +1,6 @@
USING: io io.buffers io.backend help.markup help.syntax kernel
byte-arrays sbufs words continuations byte-vectors classes ;
byte-arrays sbufs words continuations destructors
byte-vectors classes ;
IN: io.ports
ARTICLE: "io.ports" "Non-blocking I/O implementation"

53
extra/io/ports/ports.factor
View File

@ -10,7 +10,7 @@ IN: io.ports
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
TUPLE: port handle error timeout closed ;
TUPLE: port handle error timeout disposed ;
M: port timeout timeout>> ;
@ -18,21 +18,6 @@ M: port set-timeout (>>timeout) ;
GENERIC: init-handle ( handle -- )
GENERIC: close-handle ( handle -- )
TUPLE: handle-destructor handle ;
C: <handle-destructor> handle-destructor
M: handle-destructor dispose ( obj -- )
handle>> close-handle ;
: close-always ( handle -- )
<handle-destructor> <only-once> add-always-destructor ;
: close-later ( handle -- )
<handle-destructor> <only-once> add-error-destructor ;
: <port> ( handle class -- port )
new
swap dup init-handle >>handle ; inline
@ -40,14 +25,6 @@ M: handle-destructor dispose ( obj -- )
: pending-error ( port -- )
[ f ] change-error drop [ throw ] when* ;
ERROR: port-closed-error port ;
M: port-closed-error summary
drop "Port has been closed" ;
: check-closed ( port -- port )
dup closed>> [ port-closed-error ] when ;
TUPLE: buffered-port < port buffer ;
: <buffered-port> ( handle class -- port )
@ -69,7 +46,7 @@ HOOK: (wait-to-read) io-backend ( port -- )
[ f >>eof drop f ] r> if ; inline
M: input-port stream-read1
check-closed
dup check-disposed
dup wait-to-read [ buffer>> buffer-pop ] unless-eof ;
: read-step ( count port -- byte-array/f )
@ -77,7 +54,7 @@ M: input-port stream-read1
[ dupd buffer>> buffer-read ] unless-eof nip ;
M: input-port stream-read-partial ( max stream -- byte-array/f )
check-closed
dup check-disposed
>r 0 max >integer r> read-step ;
: read-loop ( count port accum -- )
@ -92,7 +69,7 @@ M: input-port stream-read-partial ( max stream -- byte-array/f )
] if ;
M: input-port stream-read
check-closed
dup check-disposed
>r 0 max >fixnum r>
2dup read-step dup [
pick over length > [
@ -115,12 +92,12 @@ TUPLE: output-port < buffered-port ;
tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
M: output-port stream-write1
check-closed
dup check-disposed
1 over wait-to-write
buffer>> byte>buffer ;
M: output-port stream-write
check-closed
dup check-disposed
over length over buffer>> buffer-size > [
[ buffer>> buffer-size <groups> ]
[ [ stream-write ] curry ] bi
@ -136,15 +113,13 @@ HOOK: (wait-to-write) io-backend ( port -- )
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: output-port stream-flush ( port -- )
check-closed
dup check-disposed
[ flush-port ] [ pending-error ] bi ;
GENERIC: close-port ( port -- )
M: output-port close-port
M: output-port dispose*
[ flush-port ] [ call-next-method ] bi ;
M: buffered-port close-port
M: buffered-port dispose*
[ call-next-method ]
[ [ [ buffer-free ] when* f ] change-buffer drop ]
bi ;
@ -153,14 +128,10 @@ HOOK: cancel-io io-backend ( port -- )
M: port timed-out cancel-io ;
M: port close-port
[ cancel-io ] [ handle>> close-handle ] bi ;
M: port dispose
dup closed>> [ drop ] [ t >>closed close-port ] if ;
M: port dispose* [ cancel-io ] [ handle>> dispose ] bi ;
: <ports> ( read-handle write-handle -- input-port output-port )
[
[ <input-port> dup add-error-destructor ]
[ <output-port> dup add-error-destructor ] bi*
[ <input-port> |dispose ]
[ <output-port> |dispose ] bi*
] with-destructors ;

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

@ -1,19 +1,19 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.sockets io.files io.streams.duplex logging
continuations kernel math math.parser namespaces parser
sequences strings prettyprint debugger quotations calendar
threads concurrency.combinators assocs fry ;
continuations destructors kernel math math.parser namespaces
parser sequences strings prettyprint debugger quotations
calendar threads concurrency.combinators assocs fry ;
IN: io.server
SYMBOL: servers
SYMBOL: remote-address
<PRIVATE
LOG: accepted-connection NOTICE
SYMBOL: remote-address
: with-connection ( client remote quot -- )
'[
, [ remote-address set ] [ accepted-connection ] bi

2
extra/io/sockets/secure/secure.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations
io.sockets sequences ;
destructors io.sockets sequences ;
IN: io.sockets.secure
SYMBOL: ssl-backend

2
extra/io/sockets/sockets-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.backend threads
strings byte-arrays continuations quotations ;
strings byte-arrays continuations destructors quotations ;
IN: io.sockets
ARTICLE: "network-addressing" "Address specifiers"

47
extra/io/sockets/sockets.factor
View File

@ -151,10 +151,12 @@ M: inet6 parse-sockaddr
M: f parse-sockaddr nip ;
GENERIC# (wait-to-connect) 1 ( client-out handle remote -- sockaddr )
GENERIC: (get-local-address) ( handle remote -- sockaddr )
: wait-to-connect ( client-out handle remote -- local )
[ (wait-to-connect) ] keep parse-sockaddr ;
: get-local-address ( handle remote -- local )
[ (get-local-address) ] keep parse-sockaddr ;
GENERIC: establish-connection ( client-out remote -- )
GENERIC: ((client)) ( remote -- handle )
@ -164,12 +166,13 @@ M: array (client) [ (client) 3array ] attempt-all first3 ;
M: object (client) ( remote -- client-in client-out local )
[
[ ((client)) ] keep
[
((client))
dup <ports>
2dup [ add-error-destructor ] bi@
dup dup handle>>
] keep wait-to-connect
>r dup <ports> [ |dispose ] bi@ dup r>
establish-connection
]
[ get-local-address ]
2bi
] with-destructors ;
: <client> ( remote encoding -- stream local )
@ -184,26 +187,26 @@ SYMBOL: local-address
TUPLE: server-port < port addr encoding ;
: check-server-port ( port -- port )
check-closed
dup check-disposed
dup server-port? [ "Not a server port" throw ] unless ; inline
GENERIC: (server) ( addrspec -- handle sockaddr )
GENERIC: (server) ( addrspec -- handle )
: <server> ( addrspec encoding -- server )
>r [ (server) ] keep parse-sockaddr
swap server-port <port>
swap >>addr
r> >>encoding ;
>r
[ (server) ] keep
[ drop server-port <port> ] [ get-local-address ] 2bi
>>addr r> >>encoding ;
GENERIC: (accept) ( server addrspec -- handle remote )
GENERIC: (accept) ( server addrspec -- handle )
: accept ( server -- client remote )
check-server-port
[ dup addr>> (accept) ] keep
tuck
[ [ dup <ports> ] [ encoding>> ] bi* <encoder-duplex> ]
[ addr>> parse-sockaddr ]
2bi* ;
[
dup addr>>
[ (accept) ] keep
[ drop dup <ports> ] [ get-local-address ] 2bi
-rot
] keep encoding>> <encoder-duplex> swap ;
TUPLE: datagram-port < port addr ;
@ -213,7 +216,7 @@ HOOK: (datagram) io-backend ( addr -- datagram )
dup (datagram) datagram-port <port> swap >>addr ;
: check-datagram-port ( port -- port )
check-closed
dup check-disposed
dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
HOOK: (receive) io-backend ( datagram -- packet addrspec )

3
extra/io/streams/duplex/duplex-docs.factor
View File

@ -18,9 +18,6 @@ HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
HELP: stream-closed-twice
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;
HELP: with-stream
{ $values { "stream" duplex-stream } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with both " { $link input-stream } " and " { $link output-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;

15
extra/io/streams/duplex/duplex-tests.factor
View File

@ -1,18 +1,13 @@
USING: io.streams.duplex io io.streams.string
kernel continuations tools.test ;
kernel continuations tools.test destructors accessors ;
IN: io.streams.duplex.tests
! Test duplex stream close behavior
TUPLE: closing-stream closed? ;
TUPLE: closing-stream < disposable ;
: <closing-stream> closing-stream new ;
M: closing-stream dispose
dup closing-stream-closed? [
"Closing twice!" throw
] [
t swap set-closing-stream-closed?
] if ;
M: closing-stream dispose* drop ;
TUPLE: unclosable-stream ;
@ -30,14 +25,14 @@ M: unclosable-stream dispose
<unclosable-stream> <closing-stream> [
<duplex-stream>
[ dup dispose ] [ 2drop ] recover
] keep closing-stream-closed?
] keep disposed>>
] unit-test
[ t ] [
<closing-stream> [ <unclosable-stream>
<duplex-stream>
[ dup dispose ] [ 2drop ] recover
] keep closing-stream-closed?
] keep disposed>>
] unit-test
[ "Hey" ] [

43
extra/io/streams/duplex/duplex.factor
View File

@ -1,50 +1,33 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations io io.encodings io.encodings.private
io.timeouts debugger inspector listener accessors delegate
delegate.protocols ;
USING: kernel continuations destructors io io.encodings
io.encodings.private io.timeouts debugger inspector listener
accessors delegate delegate.protocols ;
IN: io.streams.duplex
! We ensure that the stream can only be closed once, to preserve
! integrity of duplex I/O ports.
TUPLE: duplex-stream in out closed ;
TUPLE: duplex-stream in out ;
: <duplex-stream> ( in out -- stream )
f duplex-stream boa ;
C: <duplex-stream> duplex-stream
ERROR: stream-closed-twice ;
CONSULT: input-stream-protocol duplex-stream in>> ;
M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
<PRIVATE
: check-closed ( stream -- stream )
dup closed>> [ stream-closed-twice ] when ; inline
: in ( duplex -- stream ) check-closed in>> ;
: out ( duplex -- stream ) check-closed out>> ;
PRIVATE>
CONSULT: input-stream-protocol duplex-stream in ;
CONSULT: output-stream-protocol duplex-stream out ;
CONSULT: output-stream-protocol duplex-stream out>> ;
M: duplex-stream set-timeout
[ in set-timeout ] [ out set-timeout ] 2bi ;
[ in>> set-timeout ] [ out>> set-timeout ] 2bi ;
M: duplex-stream dispose
#! The output stream is closed first, in case both streams
#! are attached to the same file descriptor, the output
#! buffer needs to be flushed before we close the fd.
dup closed>> [
t >>closed
[ dup out>> dispose ]
[ dup in>> dispose ] [ ] cleanup
] unless drop ;
[
[ out>> &dispose drop ]
[ in>> &dispose drop ]
bi
] with-destructors ;
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
tuck re-encode >r re-decode r> <duplex-stream> ;

2
extra/io/streams/null/null.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.null
USING: kernel io io.timeouts io.streams.duplex continuations ;
USING: kernel io io.timeouts io.streams.duplex destructors ;
TUPLE: null-stream ;

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

@ -4,20 +4,18 @@ USING: alien generic assocs kernel kernel.private math
io.ports sequences strings structs sbufs threads unix
vectors io.buffers io.backend io.encodings math.parser
continuations system libc qualified namespaces io.timeouts
io.encodings.utf8 accessors inspector combinators ;
io.encodings.utf8 destructors accessors inspector combinators ;
QUALIFIED: io
IN: io.unix.backend
! I/O tasks
GENERIC: handle-fd ( handle -- fd )
TUPLE: fd fd closed ;
TUPLE: fd fd disposed ;
: <fd> ( n -- fd ) f fd boa ;
M: fd dispose
dup closed>>
[ drop ] [ t >>closed fd>> close-file ] if ;
M: fd dispose* fd>> close-file ;
M: fd handle-fd fd>> ;
@ -112,8 +110,6 @@ M: fd init-handle ( fd -- )
[ F_SETFL O_NONBLOCK fcntl drop ]
[ F_SETFD FD_CLOEXEC fcntl drop ] bi ;
M: fd close-handle ( fd -- ) dispose ;
! Readers
: eof ( reader -- )
dup buffer>> buffer-empty? [ t >>eof ] when drop ;

2
extra/io/unix/files/files.factor
View File

@ -33,7 +33,7 @@ M: unix (file-writer) ( path -- stream )
: open-append ( path -- fd )
[
append-flags file-mode open-file dup close-later
append-flags file-mode open-file |dispose
dup 0 SEEK_END lseek io-error
] with-destructors ;

2
extra/io/unix/files/unique/unique.factor
View File

@ -6,6 +6,6 @@ IN: io.unix.files.unique
{ O_RDWR O_CREAT O_EXCL } flags ;
M: unix (make-unique-file) ( path -- )
open-unique-flags file-mode open dup io-error close ;
open-unique-flags file-mode open-file close-file ;
M: unix temporary-path ( -- path ) "/tmp" ;

2
extra/io/unix/launcher/launcher-tests.factor
View File

@ -1,7 +1,7 @@
IN: io.unix.launcher.tests
USING: io.files tools.test io.launcher arrays io namespaces
continuations math io.encodings.binary io.encodings.ascii
accessors kernel sequences io.encodings.utf8 ;
accessors kernel sequences io.encodings.utf8 destructors ;
[ ] [
[ "launcher-test-1" temp-file delete-file ] ignore-errors

16
extra/io/unix/linux/monitors/monitors.factor
View File

@ -12,7 +12,7 @@ SYMBOL: watches
SYMBOL: inotify
TUPLE: linux-monitor < monitor wd inotify watches ;
TUPLE: linux-monitor < monitor wd inotify watches disposed ;
: <linux-monitor> ( wd path mailbox -- monitor )
linux-monitor new-monitor
@ -54,14 +54,12 @@ M: linux (monitor) ( path recursive? mailbox -- monitor )
IN_CHANGE_EVENTS swap add-watch
] if ;
M: linux-monitor dispose ( monitor -- )
dup inotify>> closed>> [ drop ] [
[ [ wd>> ] [ watches>> ] bi delete-at ]
[
[ inotify>> handle>> ] [ wd>> ] bi
inotify_rm_watch io-error
] bi
] if ;
M: linux-monitor dispose* ( monitor -- )
[ [ wd>> ] [ watches>> ] bi delete-at ]
[
[ inotify>> handle>> ] [ wd>> ] bi
inotify_rm_watch io-error
] bi ;
: ignore-flags? ( mask -- ? )
{

2
extra/io/unix/macosx/macosx.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents
continuations kernel sequences namespaces arrays system locals
accessors ;
accessors destructors ;
IN: io.unix.macosx
TUPLE: macosx-monitor < monitor handle ;

2
extra/io/unix/mmap/mmap.factor
View File

@ -9,7 +9,7 @@ IN: io.unix.mmap
:: mmap-open ( length prot flags path -- alien fd )
[
f length prot flags
path open-r/w dup close-later
path open-r/w |dispose
[ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
] with-destructors ;

16
extra/io/unix/sockets/secure/secure.factor
View File

@ -92,12 +92,12 @@ M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
2dup SSL_connect check-connect-response dup
[ >r over r> wait-for-port do-ssl-connect ] [ 3drop ] if ;
M: ssl-handle (wait-to-connect)
M: ssl establish-connection ( client-out remote -- )
addrspec>>
[ >r file>> r> (wait-to-connect) ]
[ drop handle>> do-ssl-connect ]
[ drop t >>connected 2drop ]
3tri ;
[ establish-connection ]
[ drop dup handle>> do-ssl-connect ]
[ drop t >>connected drop ]
2tri ;
M: ssl (server) addrspec>> (server) ;
@ -117,12 +117,8 @@ M: ssl (server) addrspec>> (server) ;
M: ssl (accept)
[
addrspec>>
(accept) >r
dup close-later
<ssl-socket> dup close-later
addrspec>> (accept) |dispose <ssl-socket> |dispose
dup do-ssl-accept
r>
] with-destructors ;
: check-shutdown-response ( handle r -- event )

59
extra/io/unix/sockets/sockets.factor Executable file → Normal file
View File

@ -13,7 +13,7 @@ EXCLUDE: io.sockets => accept ;
IN: io.unix.sockets
: socket-fd ( domain type -- fd )
0 socket dup io-error <fd> [ close-later ] [ init-handle ] [ ] tri ;
0 socket dup io-error <fd> |dispose dup init-handle ;
: set-socket-option ( fd level opt -- )
>r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ;
@ -22,24 +22,34 @@ M: unix addrinfo-error ( n -- )
dup zero? [ drop ] [ gai_strerror throw ] if ;
! Client sockets - TCP and Unix domain
: init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE set-socket-option ;
: get-socket-name ( fd addrspec -- sockaddr )
M: object (get-local-address) ( handle remote -- sockaddr )
>r handle-fd r> empty-sockaddr/size
[ getsockname io-error ] 2keep drop ;
: get-peer-name ( fd addrspec -- sockaddr )
>r handle-fd r> empty-sockaddr/size
[ getpeername io-error ] 2keep drop ;
: init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE set-socket-option ;
M: fd (wait-to-connect)
>r >r +output+ wait-for-port r> r> get-socket-name ;
: wait-to-connect ( port -- )
dup handle>> handle-fd f 0 write
{
{ [ 0 = ] [ drop ] }
{ [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
{ [ err_no EINTR = ] [ wait-to-connect ] }
[ (io-error) ]
} cond ;
M: object establish-connection ( client-out remote -- )
[ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
{
{ [ 0 = ] [ drop ] }
{ [ err_no EINPROGRESS = ] [
[ +output+ wait-for-port ] [ wait-to-connect ] bi
] }
[ (io-error) ]
} cond ;
M: object ((client)) ( addrspec -- fd )
[ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi
>r >r dup handle-fd r> r> connect zero? err_no EINPROGRESS = or
[ dup init-client-socket ] [ (io-error) ] if ;
protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
! Server sockets - TCP and Unix domain
: init-server-socket ( fd -- )
@ -50,27 +60,22 @@ M: object ((client)) ( addrspec -- fd )
dup init-server-socket
dup handle-fd rot make-sockaddr/size bind io-error ;
M: object (server) ( addrspec -- handle sockaddr )
M: object (server) ( addrspec -- handle )
[
[
SOCK_STREAM server-socket-fd
dup handle-fd 10 listen io-error
dup
] keep
get-socket-name
SOCK_STREAM server-socket-fd
dup handle-fd 10 listen io-error
] with-destructors ;
: do-accept ( server addrspec -- fd remote )
[ handle>> handle-fd ] [ empty-sockaddr/size ] bi*
[ accept ] 2keep drop ; inline
: do-accept ( server addrspec -- fd )
[ handle>> handle-fd ] [ empty-sockaddr/size ] bi* accept ; inline
M: object (accept) ( server addrspec -- fd remote )
M: object (accept) ( server addrspec -- fd )
2dup do-accept
{
{ [ over 0 >= ] [ { [ drop ] [ drop ] [ <fd> ] [ ] } spread ] }
{ [ err_no EINTR = ] [ 2drop (accept) ] }
{ [ dup 0 >= ] [ 2nip <fd> ] }
{ [ err_no EINTR = ] [ drop (accept) ] }
{ [ err_no EAGAIN = ] [
2drop
drop
[ drop +input+ wait-for-port ]
[ (accept) ]
2bi

2
extra/io/unix/unix-tests.factor
View File

@ -1,7 +1,7 @@
USING: io.files io.sockets io kernel threads
namespaces tools.test continuations strings byte-arrays
sequences prettyprint system io.encodings.binary io.encodings.ascii
io.streams.duplex ;
io.streams.duplex destructors ;
IN: io.unix.tests
! Unix domain stream sockets

5
extra/io/windows/files/files.factor
View File

@ -68,6 +68,11 @@ SYMBOLS: +read-only+ +hidden+ +system+
! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
[ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
! [
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
! ]
} cleave
\ file-info boa ;

198
extra/io/windows/windows.factor
View File

@ -8,17 +8,29 @@ windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields system accessors ;
IN: io.windows
TUPLE: win32-file handle ptr ;
TUPLE: win32-handle handle disposed ;
C: <win32-file> win32-file
: new-win32-handle ( handle class -- win32-handle )
new swap >>handle ;
: <win32-handle> ( handle -- win32-handle )
win32-handle new-win32-handle ;
M: win32-handle dispose* ( handle -- )
handle>> CloseHandle drop ;
TUPLE: win32-file handle ptr disposed ;
: <win32-file> ( handle -- win32-file )
win32-file new-win32-handle ;
M: win32-file init-handle ( handle -- )
drop ;
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
M: windows normalize-directory ( string -- string )
normalize-path "\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum )
{
FILE_SHARE_READ
@ -34,179 +46,3 @@ M: windows normalize-directory ( string -- string )
: security-attributes-inherit ( -- obj )
default-security-attributes
TRUE over set-SECURITY_ATTRIBUTES-bInheritHandle ; foldable
M: win32-file init-handle ( handle -- )
drop ;
M: win32-file close-handle ( handle -- )
handle>> close-handle ;
M: alien close-handle ( handle -- )
CloseHandle drop ;
! Clean up resources (open handle) if add-completion fails
: open-file ( path access-mode create-mode flags -- handle )
[
>r >r share-mode security-attributes-inherit r> r>
CreateFile-flags f CreateFile
dup invalid-handle?
|close-handle
dup add-completion
] with-destructors ;
: open-pipe-r/w ( path -- handle )
{ GENERIC_READ GENERIC_WRITE } flags
OPEN_EXISTING 0 open-file ;
: open-read ( path -- handle length )
GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
: open-write ( path -- handle length )
GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 ;
: (open-append) ( path -- handle )
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
: open-existing ( path -- handle )
{ GENERIC_READ GENERIC_WRITE } flags
share-mode
f
OPEN_EXISTING
FILE_FLAG_BACKUP_SEMANTICS
f CreateFileW dup win32-error=0/f ;
: maybe-create-file ( path -- handle ? )
#! return true if file was just created
{ GENERIC_READ GENERIC_WRITE } flags
share-mode
f
OPEN_ALWAYS
0 CreateFile-flags
f CreateFileW dup win32-error=0/f
GetLastError ERROR_ALREADY_EXISTS = not ;
: set-file-pointer ( handle length method -- )
>r dupd d>w/w <uint> r> SetFilePointer
INVALID_SET_FILE_POINTER = [
CloseHandle "SetFilePointer failed" throw
] when drop ;
HOOK: open-append os ( path -- handle length )
TUPLE: FileArgs
hFile lpBuffer nNumberOfBytesToRead
lpNumberOfBytesRet lpOverlapped ;
C: <FileArgs> FileArgs
: make-FileArgs ( port -- <FileArgs> )
{
[ handle>> handle>> ]
[ buffer>> ]
[ buffer>> buffer-length ]
[ drop "DWORD" <c-object> ]
[ FileArgs-overlapped ]
} cleave <FileArgs> ;
: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
{
[ hFile>> ]
[ lpBuffer>> buffer-end ]
[ lpBuffer>> buffer-capacity ]
[ lpNumberOfBytesRet>> ]
[ lpOverlapped>> ]
} cleave ;
: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
{
[ hFile>> ]
[ lpBuffer>> buffer@ ]
[ lpBuffer>> buffer-length ]
[ lpNumberOfBytesRet>> ]
[ lpOverlapped>> ]
} cleave ;
M: windows (file-reader) ( path -- stream )
open-read <win32-file> <input-port> ;
M: windows (file-writer) ( path -- stream )
open-write <win32-file> <output-port> ;
M: windows (file-appender) ( path -- stream )
open-append <win32-file> <output-port> ;
M: windows move-file ( from to -- )
[ normalize-path ] bi@ MoveFile win32-error=0/f ;
M: windows delete-file ( path -- )
normalize-path DeleteFile win32-error=0/f ;
M: windows copy-file ( from to -- )
dup parent-directory make-directories
[ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
M: windows make-directory ( path -- )
normalize-path
f CreateDirectory win32-error=0/f ;
M: windows delete-directory ( path -- )
normalize-path
RemoveDirectory win32-error=0/f ;
HOOK: WSASocket-flags io-backend ( -- DWORD )
TUPLE: win32-socket < win32-file overlapped ;
: <win32-socket> ( handle overlapped -- win32-socket )
win32-socket new
swap >>overlapped
swap >>handle ;
: open-socket ( family type -- socket )
0 f 0 WSASocket-flags WSASocket dup socket-error ;
USE: windows.winsock
: init-sockaddr ( port# addrspec -- sockaddr )
dup sockaddr-type <c-object>
[ swap protocol-family swap set-sockaddr-in-family ] keep
[ >r htons r> set-sockaddr-in-port ] keep ;
: server-sockaddr ( port# addrspec -- sockaddr )
init-sockaddr
[ INADDR_ANY swap set-sockaddr-in-addr ] keep ;
: bind-socket ( socket sockaddr addrspec -- )
[ server-sockaddr ] keep
sockaddr-type heap-size bind socket-error ;
TUPLE: socket-destructor alien ;
C: <socket-destructor> socket-destructor
M: socket-destructor dispose ( obj -- )
alien>> closesocket drop ;
: |close-socket ( handle -- handle )
dup <socket-destructor> <only-once> |dispose drop ;
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> open-socket |close-socket
dup rot make-sockaddr/size bind socket-error ;
USE: namespaces
! http://support.microsoft.com/kb/127144
! NOTE: Possibly tweak this because of SYN flood attacks
: listen-backlog ( -- n ) HEX: 7fffffff ; inline
: listen-on-socket ( socket -- )
listen-backlog listen winsock-return-check ;
M: win32-socket dispose ( stream -- )
handle>> closesocket drop ;
M: windows addrinfo-error ( n -- )
winsock-return-check ;
: tcp-socket ( addrspec -- socket )
protocol-family SOCK_STREAM open-socket ;

4
extra/irc/irc.factor
View File

@ -3,7 +3,7 @@
USING: arrays calendar combinators channels concurrency.messaging fry io
io.encodings.8-bit io.sockets kernel math namespaces sequences
sequences.lib splitting strings threads
continuations classes.tuple ascii accessors ;
continuations destructors classes.tuple ascii accessors ;
IN: irc
! utils
@ -143,7 +143,7 @@ SYMBOL: irc-client
" hostname servername :irc.factor" irc-print ;
: CONNECT ( server port -- stream )
<inet> latin1 <client> ;
<inet> latin1 <client> drop ;
: JOIN ( channel password -- )
"JOIN " irc-write

3
extra/lisp/lisp.factor
View File

@ -76,6 +76,7 @@ PRIVATE>
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env
ERROR: no-such-var var ;
: init-env ( -- )
H{ } clone lisp-env set ;
@ -84,7 +85,7 @@ SYMBOL: lisp-env
swap lisp-env get set-at ;
: lisp-get ( name -- word )
lisp-env get at ;
dup lisp-env get at [ ] [ no-such-var ] ?if ;
: funcall ( quot sym -- * )
dup lisp-symbol? [ name>> lisp-get ] when call ; inline

8
extra/logging/server/server.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel io calendar sequences io.files
io.sockets continuations prettyprint assocs math.parser
words debugger math combinators concurrency.messaging
threads arrays init math.ranges strings calendar.format
io.encodings.utf8 ;
io.sockets continuations destructors prettyprint assocs
math.parser words debugger math combinators
concurrency.messaging threads arrays init math.ranges strings
calendar.format io.encodings.utf8 ;
IN: logging.server
: log-root ( -- string )

16
extra/openssl/openssl.factor
View File

@ -103,8 +103,7 @@ M: openssl <ssl-context> ( config -- context )
maybe-init-ssl
[
dup method>> ssl-method SSL_CTX_new
dup ssl-error V{ } clone openssl-context boa
dup add-error-destructor
dup ssl-error V{ } clone openssl-context boa |dispose
{
[ load-certificate-chain ]
[ set-default-password ]
@ -138,14 +137,11 @@ M: ssl-handle init-handle file>> init-handle ;
HOOK: ssl-shutdown io-backend ( handle -- )
M: ssl-handle close-handle
dup disposed>> [ drop ] [
t >>disposed
[ ssl-shutdown ]
[ handle>> SSL_free ]
[ file>> close-handle ]
tri
] if ;
M: ssl-handle dispose*
[ ssl-shutdown ]
[ handle>> SSL_free ]
[ file>> dispose ]
tri ;
ERROR: certificate-verify-error result ;

6
extra/random/windows/windows.factor
View File

@ -1,7 +1,6 @@
USING: accessors alien.c-types byte-arrays continuations
kernel windows windows.advapi32 init namespaces random
destructors locals ;
USE: tools.walker
IN: random.windows
TUPLE: windows-rng provider type ;
@ -36,9 +35,8 @@ M: windows-crypto-context dispose ( tuple -- )
M: windows-rng random-bytes* ( n tuple -- bytes )
[
[ provider>> ] [ type>> ] bi
windows-crypto-context
dup add-always-destructor handle>>
swap dup <byte-array>
windows-crypto-context &dispose
handle>> swap dup <byte-array>
[ CryptGenRandom win32-error=0/f ] keep
] with-destructors ;

2
extra/semantic-db/semantic-db.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays combinators combinators.cleave combinators.lib
continuations db db.tuples db.types db.sqlite kernel math
math.parser namespaces parser sets sequences sequences.deep
sequences.lib strings words ;
sequences.lib strings words destructors ;
IN: semantic-db
TUPLE: node id content ;

4
extra/shuffle/shuffle.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences namespaces math inference.transforms
combinators macros quotations math.ranges bake ;
combinators macros quotations math.ranges fry ;
IN: shuffle
@ -19,7 +19,7 @@ MACRO: ndrop ( n -- ) [ drop ] n*quot ;
: nnip ( n -- ) swap >r ndrop r> ; inline
MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
MACRO: ntuck ( n -- ) 2 + '[ dup , -nrot ] ;
: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline

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