diff --git a/Makefile b/Makefile
index e02b6a672b..aad7fe90eb 100755
--- a/Makefile
+++ b/Makefile
@@ -56,6 +56,8 @@ default:
@echo "linux-arm"
@echo "openbsd-x86-32"
@echo "openbsd-x86-64"
+ @echo "netbsd-x86-32"
+ @echo "netbsd-x86-64"
@echo "macosx-x86-32"
@echo "macosx-x86-64"
@echo "macosx-ppc"
@@ -83,6 +85,12 @@ freebsd-x86-32:
freebsd-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.64
+netbsd-x86-32:
+ $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.32
+
+netbsd-x86-64:
+ $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.64
+
macosx-freetype:
ln -sf libfreetype.6.dylib \
Factor.app/Contents/Frameworks/libfreetype.dylib
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index 0163422f47..8fc3435ffa 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -87,5 +87,5 @@ IN: bootstrap.stage2
"output-image" get resource-path save-image-and-exit
] if
] [
- error. :c "listener" vocab-main execute
+ print-error :c "listener" vocab-main execute
] recover
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index 5addd273c8..854e6add5a 100755
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -207,3 +207,14 @@ DEFER: mixin-forget-test-g
[ { } mixin-forget-test-g ] unit-test-fails
[ H{ } ] [ H{ } mixin-forget-test-g ] unit-test
+
+! Method flattening interfered with mixin update
+MIXIN: flat-mx-1
+TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1
+TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1
+TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1
+TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1
+MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1
+TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
+
+[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 65dc5f5ff7..a6a1db7045 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -255,7 +255,14 @@ PRIVATE>
>r dup word-props r> union over set-word-props
t "class" set-word-prop ;
-GENERIC: update-methods ( class -- )
+GENERIC: update-predicate ( class -- )
+
+M: class update-predicate drop ;
+
+: update-predicates ( assoc -- )
+ [ drop update-predicate ] assoc-each ;
+
+GENERIC: update-methods ( assoc -- )
: define-class ( word members superclass metaclass -- )
#! If it was already a class, update methods after.
@@ -264,8 +271,9 @@ GENERIC: update-methods ( class -- )
over class-usages [
uncache-classes
dupd (define-class)
- ] keep cache-classes
- r> [ update-methods ] [ drop ] if ;
+ ] keep cache-classes r>
+ [ class-usages dup update-predicates update-methods ]
+ [ drop ] if ;
GENERIC: class ( object -- class ) inline
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
old mode 100644
new mode 100755
index e95c08b507..0adbdc080d
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -20,6 +20,8 @@ PREDICATE: class union-class
over members union-predicate-quot
define-predicate ;
+M: union-class update-predicate define-union-predicate ;
+
: define-union-class ( class members -- )
dupd f union-class define-class define-union-predicate ;
diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor
index 954e45cb66..075961047f 100755
--- a/core/compiler/test/intrinsics.factor
+++ b/core/compiler/test/intrinsics.factor
@@ -334,10 +334,6 @@ cell 8 = [
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
-[ H{ } ] [
- 100 [ (hashtable) ] compile-call [ reset-hash ] keep
-] unit-test
-
[ B{ 0 0 0 0 0 } ] [
[ 5 <byte-array> ] compile-call
] unit-test
diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor
index 266b331ffc..c1561f38d4 100755
--- a/core/compiler/test/redefine.factor
+++ b/core/compiler/test/redefine.factor
@@ -238,3 +238,15 @@ DEFER: flushable-test-2
[ \ bx forget ] with-compilation-unit
[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test
+
+DEFER: defer-redefine-test-2
+
+[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test
+
+[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test
+
+[ defer-redefine-test-2 ] unit-test-fails
+
+[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test
+
+[ 1 ] [ defer-redefine-test-2 ] unit-test
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
old mode 100644
new mode 100755
index 2918f3340b..51e461c715
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -68,6 +68,15 @@ $nl
ABOUT: "continuations"
+HELP: dispose
+{ $values { "object" "a disposable object" } }
+{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
+{ $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." } ;
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index 278264c17d..6e4ce16bea 100755
--- a/core/continuations/continuations.factor
+++ b/core/continuations/continuations.factor
@@ -135,6 +135,11 @@ PRIVATE>
[ [ , f ] compose [ , drop t ] recover ] curry all?
] { } make peek swap [ rethrow ] when ; inline
+GENERIC: dispose ( object -- )
+
+: with-disposal ( object quot -- )
+ over [ dispose ] curry [ ] cleanup ; inline
+
TUPLE: condition restarts continuation ;
: <condition> ( error restarts cc -- condition )
diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor
old mode 100644
new mode 100755
index 5a808a9a5d..2aeaadad3e
--- a/core/dlists/dlists-docs.factor
+++ b/core/dlists/dlists-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax kernel ;
+USING: help.markup help.syntax kernel quotations ;
IN: dlists
ARTICLE: "dlists" "Doubly-linked lists"
@@ -13,23 +13,31 @@ $nl
{ $subsection dlist? }
"Constructing a dlist:"
{ $subsection <dlist> }
-"Double-ended queue protocol:"
-{ $subsection dlist-empty? }
+"Working with the front of the list:"
{ $subsection push-front }
+{ $subsection push-front* }
+{ $subsection peek-front }
{ $subsection pop-front }
{ $subsection pop-front* }
+"Working with the back of the list:"
{ $subsection push-back }
+{ $subsection push-back* }
+{ $subsection peek-back }
{ $subsection pop-back }
{ $subsection pop-back* }
"Finding out the length:"
+{ $subsection dlist-empty? }
{ $subsection dlist-length }
"Iterating over elements:"
{ $subsection dlist-each }
{ $subsection dlist-find }
{ $subsection dlist-contains? }
-"Deleting a node matching a predicate:"
-{ $subsection delete-node* }
+"Deleting a node:"
{ $subsection delete-node }
+{ $subsection dlist-delete }
+"Deleting a node matching a predicate:"
+{ $subsection delete-node-if* }
+{ $subsection delete-node-if }
"Consuming all nodes:"
{ $subsection dlist-slurp } ;
@@ -77,7 +85,7 @@ HELP: pop-back*
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
HELP: dlist-find
-{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
$nl
@@ -85,20 +93,20 @@ HELP: dlist-find
} ;
HELP: dlist-contains?
-{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } }
+{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ;
-HELP: delete-node*
-{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+HELP: delete-node-if*
+{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
{ $notes "This operation is O(n)." } ;
-HELP: delete-node
-{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
-{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
+HELP: delete-node-if
+{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
+{ $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
{ $notes "This operation is O(n)." } ;
HELP: dlist-each
-{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } }
+{ $values { "quot" quotation } { "dlist" { $link dlist } } }
{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;
diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor
index ebae68472b..203c975bb2 100755
--- a/core/dlists/dlists-tests.factor
+++ b/core/dlists/dlists-tests.factor
@@ -49,14 +49,14 @@ IN: temporary
[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
-[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test
-[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node-if ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
+[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test
[ 0 ] [ <dlist> dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor
index 84d68b28aa..ddec312182 100755
--- a/core/dlists/dlists.factor
+++ b/core/dlists/dlists.factor
@@ -63,12 +63,22 @@ C: <dlist-node> dlist-node
>r dlist-front r> (dlist-each-node) ; inline
PRIVATE>
-: push-front ( obj dlist -- )
- [ dlist-front f swap <dlist-node> dup set-next-prev ] keep
+: push-front* ( obj dlist -- dlist-node )
+ [ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep
[ set-dlist-front ] keep
[ set-back-to-front ] keep
inc-length ;
+: push-front ( obj dlist -- )
+ push-front* drop ;
+
+: push-back* ( obj dlist -- dlist-node )
+ [ dlist-back f <dlist-node> ] keep
+ [ dlist-back set-next-when ] 2keep
+ [ set-dlist-back ] 2keep
+ [ set-front-to-back ] keep
+ inc-length ;
+
: push-back ( obj dlist -- )
[ dlist-back f <dlist-node> ] keep
[ dlist-back set-next-when ] 2keep
@@ -76,6 +86,9 @@ PRIVATE>
[ set-front-to-back ] keep
inc-length ;
+: peek-front ( dlist -- obj )
+ dlist-front dlist-node-obj ;
+
: pop-front ( dlist -- obj )
dup dlist-front [
dup dlist-node-next
@@ -87,6 +100,9 @@ PRIVATE>
: pop-front* ( dlist -- ) pop-front drop ;
+: peek-back ( dlist -- obj )
+ dlist-back dlist-node-obj ;
+
: pop-back ( dlist -- obj )
dup dlist-back [
dup dlist-node-prev
@@ -108,25 +124,25 @@ PRIVATE>
dup dlist-node-prev over dlist-node-next set-prev-when
dup dlist-node-next swap dlist-node-prev set-next-when ;
-: (delete-node) ( dlist dlist-node -- )
+: delete-node ( dlist dlist-node -- )
{
{ [ over dlist-front over eq? ] [ drop pop-front* ] }
{ [ over dlist-back over eq? ] [ drop pop-back* ] }
{ [ t ] [ unlink-node dec-length ] }
} cond ;
-: delete-node* ( quot dlist -- obj/f ? )
+: delete-node-if* ( quot dlist -- obj/f ? )
tuck dlist-find-node [
- [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if*
+ [ delete-node ] keep [ dlist-node-obj t ] [ f f ] if*
] [
2drop f f
] if ; inline
-: delete-node ( quot dlist -- obj/f )
- delete-node* drop ; inline
+: delete-node-if ( quot dlist -- obj/f )
+ delete-node-if* drop ; inline
: dlist-delete ( obj dlist -- obj/f )
- >r [ eq? ] curry r> delete-node ;
+ >r [ eq? ] curry r> delete-node-if ;
: dlist-each ( dlist quot -- )
[ dlist-node-obj ] swap compose dlist-each-node ; inline
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index 0e499cf90f..de80872b73 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -19,8 +19,8 @@ SYMBOL: compiled
: queue-compile ( word -- )
{
{ [ dup compiled get key? ] [ drop ] }
+ { [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] }
- { [ dup deferred? ] [ drop ] }
{ [ t ] [ dup compile-queue get set-at ] }
} cond ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 5ee6b9c87c..bde5fd31af 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -107,5 +107,5 @@ M: class forget* ( class -- )
dup uncache-class
forget-word ;
-M: class update-methods ( class -- )
- class-usages implementors* [ make-generic ] each ;
+M: assoc update-methods ( assoc -- )
+ implementors* [ make-generic ] each ;
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index cf2d021430..121c555d29 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -402,10 +402,14 @@ TUPLE: recursive-declare-error word ;
dup node-param #return node,
dataflow-graph get 1array over set-node-children ;
+: inlined-block? "inlined-block" word-prop ;
+
+: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
+
: inline-block ( word -- node-block data )
[
copy-inference nest-node
- dup word-def swap gensym
+ dup word-def swap <inlined-block>
[ infer-quot-recursive ] 2keep
#label unnest-node
] H{ } make-assoc ;
diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor
index f5ad256ec5..3e3858d45d 100755
--- a/core/inference/inference-tests.factor
+++ b/core/inference/inference-tests.factor
@@ -421,6 +421,8 @@ DEFER: bar
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
+\ dispose must-infer
+
! Test stream protocol
\ set-timeout must-infer
\ stream-read must-infer
@@ -430,7 +432,6 @@ DEFER: bar
\ stream-write must-infer
\ stream-write1 must-infer
\ stream-nl must-infer
-\ stream-close must-infer
\ stream-format must-infer
\ stream-write-table must-infer
\ stream-flush must-infer
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
old mode 100644
new mode 100755
index 3559a3487b..5d4bb70912
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@@ -1,5 +1,5 @@
IN: temporary
-USING: tools.test io.files io threads kernel ;
+USING: tools.test io.files io threads kernel continuations ;
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
[ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test
@@ -41,7 +41,7 @@ USING: tools.test io.files io threads kernel ;
[ ] [ "test-blah" resource-path make-directory ] unit-test
[ ] [
- "test-blah/fooz" resource-path <file-writer> stream-close
+ "test-blah/fooz" resource-path <file-writer> dispose
] unit-test
[ t ] [
diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor
index cf867d7945..208e2a2ba7 100755
--- a/core/io/io-docs.factor
+++ b/core/io/io-docs.factor
@@ -1,12 +1,12 @@
USING: help.markup help.syntax quotations hashtables kernel
-classes strings ;
+classes strings continuations ;
IN: io
ARTICLE: "stream-protocol" "Stream protocol"
"The stream protocol consists of a large number of generic words, many of which are optional."
$nl
-"A word required to be implemented for all streams:"
-{ $subsection stream-close }
+"All streams must implement the " { $link dispose } " word in addition to the stream protocol."
+$nl
"Three words are required for input streams:"
{ $subsection stream-read1 }
{ $subsection stream-read }
@@ -73,16 +73,10 @@ ARTICLE: "streams" "Streams"
ABOUT: "streams"
-HELP: stream-close
-{ $values { "stream" "a stream" } }
-{ $contract "Closes the stream. This releases any external resources associated with the stream, such as file handles and network connections. No further operations can be performed on the stream after this call." }
-{ $notes "You must close streams after you are finished working with them. A convenient way to automate this is by using the " { $link with-stream } " word." }
-$io-error ;
-
HELP: set-timeout
{ $values { "n" "an integer" } { "stream" "a stream" } }
-{ $contract "Sets a timeout, in milliseconds, for closing the stream if there is no activity. Not all streams support timeouts." }
-$io-error ;
+{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." }
+{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ;
HELP: stream-readln
{ $values { "stream" "an input stream" } { "str" string } }
diff --git a/core/io/io.factor b/core/io/io.factor
index edd0fa938f..e0c890c0e3 100755
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings
continuations assocs io.styles sbufs ;
IN: io
-GENERIC: stream-close ( stream -- )
GENERIC: set-timeout ( n stream -- )
GENERIC: stream-readln ( stream -- str )
GENERIC: stream-read1 ( stream -- ch/f )
@@ -29,7 +28,7 @@ GENERIC: stream-write-table ( table-cells style stream -- )
[ over stream-write (stream-copy) ] [ 2drop ] if* ;
: stream-copy ( in out -- )
- [ 2dup (stream-copy) ] [ stream-close stream-close ] [ ]
+ [ 2dup (stream-copy) ] [ dispose dispose ] [ ]
cleanup ;
! Default stream
@@ -54,9 +53,7 @@ SYMBOL: stderr
stdio swap with-variable ; inline
: with-stream ( stream quot -- )
- swap [
- [ stdio get stream-close ] [ ] cleanup
- ] with-stream* ; inline
+ [ with-stream* ] curry with-disposal ; inline
: tabular-output ( style quot -- )
swap >r { } make r> stdio get stream-write-table ; inline
diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor
index d816e08443..b02c3367d4 100755
--- a/core/io/streams/c/c.factor
+++ b/core/io/streams/c/c.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces io
strings sequences math generic threads.private classes
io.backend io.streams.lines io.streams.plain io.streams.duplex
-io.files ;
+io.files continuations ;
IN: io.streams.c
TUPLE: c-writer handle ;
@@ -19,7 +19,7 @@ M: c-writer stream-write
M: c-writer stream-flush
c-writer-handle fflush ;
-M: c-writer stream-close
+M: c-writer dispose
c-writer-handle fclose ;
TUPLE: c-reader handle ;
@@ -46,7 +46,7 @@ M: c-reader stream-read-until
[ swap read-until-loop ] "" make swap
over empty? over not and [ 2drop f f ] when ;
-M: c-reader stream-close
+M: c-reader dispose
c-reader-handle fclose ;
: <duplex-c-stream> ( in out -- stream )
diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor
old mode 100644
new mode 100755
index 6293836348..fa82c54163
--- a/core/io/streams/duplex/duplex-docs.factor
+++ b/core/io/streams/duplex/duplex-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax io ;
+USING: help.markup help.syntax io continuations ;
IN: io.streams.duplex
ARTICLE: "io.streams.duplex" "Duplex streams"
@@ -19,4 +19,4 @@ HELP: <duplex-stream>
HELP: check-closed
{ $values { "stream" "a duplex stream" } }
{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
-{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link stream-close } "." } ;
+{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;
diff --git a/core/io/streams/duplex/duplex-tests.factor b/core/io/streams/duplex/duplex-tests.factor
old mode 100644
new mode 100755
index a4a6433a29..962a46413f
--- a/core/io/streams/duplex/duplex-tests.factor
+++ b/core/io/streams/duplex/duplex-tests.factor
@@ -6,7 +6,7 @@ TUPLE: closing-stream closed? ;
: <closing-stream> closing-stream construct-empty ;
-M: closing-stream stream-close
+M: closing-stream dispose
dup closing-stream-closed? [
"Closing twice!" throw
] [
@@ -17,24 +17,24 @@ TUPLE: unclosable-stream ;
: <unclosable-stream> unclosable-stream construct-empty ;
-M: unclosable-stream stream-close
+M: unclosable-stream dispose
"Can't close me!" throw ;
[ ] [
<closing-stream> <closing-stream> <duplex-stream>
- dup stream-close stream-close
+ dup dispose dispose
] unit-test
[ t ] [
<unclosable-stream> <closing-stream> [
<duplex-stream>
- [ dup stream-close ] catch 2drop
+ [ dup dispose ] catch 2drop
] keep closing-stream-closed?
] unit-test
[ t ] [
<closing-stream> [ <unclosable-stream>
<duplex-stream>
- [ dup stream-close ] catch 2drop
+ [ dup dispose ] catch 2drop
] keep closing-stream-closed?
] unit-test
diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor
old mode 100644
new mode 100755
index a46dad71a0..86660b2752
--- a/core/io/streams/duplex/duplex.factor
+++ b/core/io/streams/duplex/duplex.factor
@@ -65,14 +65,14 @@ M: duplex-stream make-cell-stream
M: duplex-stream stream-write-table
duplex-stream-out+ stream-write-table ;
-M: duplex-stream stream-close
+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 duplex-stream-closed? [
t over set-duplex-stream-closed?
- [ dup duplex-stream-out stream-close ]
- [ dup duplex-stream-in stream-close ] [ ] cleanup
+ [ dup duplex-stream-out dispose ]
+ [ dup duplex-stream-in dispose ] [ ] cleanup
] unless drop ;
M: duplex-stream set-timeout
diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor
old mode 100644
new mode 100755
index 83a86a9ced..e32c90a2fc
--- a/core/io/streams/nested/nested.factor
+++ b/core/io/streams/nested/nested.factor
@@ -1,14 +1,14 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.nested
USING: arrays generic assocs kernel namespaces strings
-quotations io ;
+quotations io continuations ;
TUPLE: ignore-close-stream ;
: <ignore-close-stream> ignore-close-stream construct-delegate ;
-M: ignore-close-stream stream-close drop ;
+M: ignore-close-stream dispose drop ;
TUPLE: style-stream style ;
@@ -44,4 +44,4 @@ TUPLE: block-stream ;
: <block-stream> block-stream construct-delegate ;
-M: block-stream stream-close drop ;
+M: block-stream dispose drop ;
diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor
old mode 100644
new mode 100755
index 9aaece6e31..3d5a55739b
--- a/core/io/streams/string/string.factor
+++ b/core/io/streams/string/string.factor
@@ -2,11 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.string
USING: io kernel math namespaces sequences sbufs strings
-generic splitting io.streams.plain io.streams.lines ;
+generic splitting io.streams.plain io.streams.lines
+continuations ;
+
+M: sbuf dispose drop ;
M: sbuf stream-write1 push ;
M: sbuf stream-write push-all ;
-M: sbuf stream-close drop ;
M: sbuf stream-flush drop ;
: <string-writer> ( -- stream )
diff --git a/core/listener/listener.factor b/core/listener/listener.factor
index 8f26ddf9b2..02cd727930 100755
--- a/core/listener/listener.factor
+++ b/core/listener/listener.factor
@@ -18,11 +18,10 @@ GENERIC: stream-read-quot ( stream -- quot/f )
[ parse-lines in get ] with-compilation-unit in set ;
: read-quot-step ( lines -- quot/f )
- [ parse-lines-interactive ] catch {
- { [ dup delegate unexpected-eof? ] [ 2drop f ] }
- { [ dup not ] [ drop ] }
- { [ t ] [ rethrow ] }
- } cond ;
+ [ parse-lines-interactive ] [
+ dup delegate unexpected-eof?
+ [ 2drop f ] [ rethrow ] if
+ ] recover ;
: read-quot-loop ( stream accum -- quot/f )
over stream-readln dup [
diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor
index d91a84ec99..d80cfa9ceb 100644
--- a/core/system/system-docs.factor
+++ b/core/system/system-docs.factor
@@ -49,6 +49,7 @@ HELP: os
"linux"
"macosx"
"openbsd"
+ "netbsd"
"solaris"
"windows"
}
diff --git a/core/system/system.factor b/core/system/system.factor
index 845ba8265d..4983260a36 100644
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -39,11 +39,11 @@ splitting assocs ;
: unix? ( -- ? )
os {
- "freebsd" "openbsd" "linux" "macosx" "solaris"
+ "freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris"
} member? ;
: bsd? ( -- ? )
- os { "freebsd" "openbsd" "macosx" } member? ;
+ os { "freebsd" "openbsd" "netbsd" "macosx" } member? ;
: linux? ( -- ? )
os "linux" = ;
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
new file mode 100644
index 0000000000..a2b5dffb4d
--- /dev/null
+++ b/extra/builder/builder.factor
@@ -0,0 +1,113 @@
+
+USING: kernel io io.files io.launcher
+ system namespaces sequences splitting math.parser
+ unix prettyprint tools.time calendar bake vars ;
+
+IN: builder
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: datestamp ( -- string )
+ now `{ ,[ dup timestamp-year ]
+ ,[ dup timestamp-month ]
+ ,[ dup timestamp-day ]
+ ,[ dup timestamp-hour ]
+ ,[ timestamp-minute ] }
+ [ number>string 2 CHAR: 0 pad-left ] map "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-recipients
+
+: quote ( str -- str ) "'" swap "'" 3append ;
+
+: email-file ( subject file -- )
+ `{
+ "cat" ,
+ "| mutt -s" ,[ quote ]
+ "-x" %[ builder-recipients get ]
+ }
+ " " join system drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: boot-image ( -- filename ) `{ "boot" ,[ cpu ] "image" } "." join ;
+
+: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: stamp
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: build ( -- )
+
+datestamp >stamp
+
+"/builds/factor" cd
+"git pull git://factorcode.org/git/factor.git" system
+0 =
+[ ]
+[
+ "builder: git pull" "/dev/null" email-file
+ "builder: git pull" throw
+]
+if
+
+"/builds/" stamp> append make-directory
+"/builds/" stamp> append cd
+"git clone /builds/factor" system drop
+
+"factor" cd
+
+{ "/usr/bin/git" "show" } <process-stream>
+[ readln ] with-stream
+" " split second
+"../git-id" <file-writer> [ print ] with-stream
+
+"make clean" system drop
+
+"make " target " > ../compile-log" 3append system
+0 =
+[ ]
+[
+ "builder: vm compile" "../compile-log" email-file
+ "builder: vm compile" throw
+] if
+
+"wget http://factorcode.org/images/latest/" boot-image append system
+0 =
+[ ]
+[
+ "builder: image download" "/dev/null" email-file
+ "builder: image download" throw
+] if
+
+[ "./factor -i=" boot-image " -no-user-init > ../boot-log" 3append system ]
+benchmark nip
+"../boot-time" <file-writer> [ . ] with-stream
+0 =
+[ ]
+[
+ "builder: bootstrap" "../boot-log" email-file
+ "builder: bootstrap" throw
+] if
+
+[
+ "./factor -e='USE: tools.browser load-everything' > ../load-everything-log"
+ system
+] benchmark nip
+"../load-everything-time" <file-writer> [ . ] with-stream
+0 =
+[ ]
+[
+ "builder: load-everything" "../load-everything-log" email-file
+ "builder: load-everything" throw
+] if
+
+;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: build
\ No newline at end of file
diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
old mode 100644
new mode 100755
index 3042b87ad6..550eb50e0a
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -53,7 +53,7 @@ IN: bunny
model-path resource-path dup exists? [
"Downloading bunny from " write
model-url dup print flush
- over download
+ over download-to
] unless ;
: draw-triangle ( ns vs triple -- )
diff --git a/extra/cabal/cabal.factor b/extra/cabal/cabal.factor
old mode 100644
new mode 100755
index cc51bcf308..0ad8465498
--- a/extra/cabal/cabal.factor
+++ b/extra/cabal/cabal.factor
@@ -41,7 +41,7 @@ VARS: input user ;
: ((send-input)) ( other -- ) [ input> print flush ] with-stream* ;
: (send-input) ( other -- )
-[ ((send-input)) ] catch [ print dup stream-close users> delete ] when ;
+[ ((send-input)) ] catch [ print dup dispose users> delete ] when ;
: send-input ( other -- )
dup duplex-stream-closed? [ users> delete ] [ (send-input) ] if ;
diff --git a/extra/const/const.factor b/extra/const/const.factor
index 59d65edaae..8efef7e372 100644
--- a/extra/const/const.factor
+++ b/extra/const/const.factor
@@ -14,3 +14,11 @@ IN: const
: ENUM:
";" parse-tokens [ create-in ] map define-enum ; parsing
+
+: define-value ( word -- )
+ { f } clone [ first ] curry define ;
+
+: VALUE: CREATE define-value ; parsing
+
+: set-value ( value word -- )
+ word-def first set-first ;
diff --git a/extra/cryptlib/streams/streams.factor b/extra/cryptlib/streams/streams.factor
old mode 100644
new mode 100755
index 77a34e84d1..64b5ee9992
--- a/extra/cryptlib/streams/streams.factor
+++ b/extra/cryptlib/streams/streams.factor
@@ -84,7 +84,7 @@ M: crypt-stream stream-write1 ( ch stream -- )
: check-close ( err -- )
dup CRYPT_ERROR_PARAM1 = [ drop ] [ check-result ] if ;
-M: crypt-stream stream-close ( stream -- )
+M: crypt-stream dispose ( stream -- )
crypt-stream-handle cryptDestroySession check-close ;
: create-session ( format -- session )
@@ -115,7 +115,7 @@ M: crypt-stream stream-close ( stream -- )
dup stream-readln print
- stream-close
+ dispose
end
;
@@ -130,7 +130,7 @@ M: crypt-stream stream-close ( stream -- )
"Thanks!" over stream-print
dup stream-flush
- stream-close
+ dispose
end
;
@@ -152,6 +152,6 @@ M: crypt-stream stream-close ( stream -- )
(rpl)
- stream-close
+ dispose
end
;
\ No newline at end of file
diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor
old mode 100644
new mode 100755
index 07f4ce119a..1121883b7c
--- a/extra/delegate/protocols/protocols.factor
+++ b/extra/delegate/protocols/protocols.factor
@@ -15,7 +15,7 @@ PROTOCOL: assoc-protocol
! everything should work, just slower (with >alist)
PROTOCOL: stream-protocol
- stream-close stream-read1 stream-read stream-read-until
+ stream-read1 stream-read stream-read-until
stream-flush stream-write1 stream-write stream-format
stream-nl make-span-stream make-block-stream stream-readln
make-cell-stream stream-write-table set-timeout ;
diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor
index 3b959ba801..234e7891d7 100755
--- a/extra/help/handbook/handbook.factor
+++ b/extra/help/handbook/handbook.factor
@@ -137,22 +137,25 @@ ARTICLE: "collections" "Collections"
{ $subsection "graphs" }
{ $subsection "buffers" } ;
-USING: io.sockets io.launcher io.mmap ;
+USING: io.sockets io.launcher io.mmap io.monitor ;
ARTICLE: "io" "Input and output"
{ $subsection "streams" }
-"Stream implementations:"
+"External streams:"
{ $subsection "file-streams" }
+{ $subsection "network-streams" }
+"Wrapper streams:"
{ $subsection "io.streams.duplex" }
{ $subsection "io.streams.lines" }
{ $subsection "io.streams.plain" }
{ $subsection "io.streams.string" }
-"Advanced features:"
+"Stream utilities:"
{ $subsection "stream-binary" }
{ $subsection "styles" }
-{ $subsection "network-streams" }
+"Advanced features:"
{ $subsection "io.launcher" }
-{ $subsection "io.mmap" } ;
+{ $subsection "io.mmap" }
+{ $subsection "io.monitor" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.annotations" }
diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor
old mode 100644
new mode 100755
index b3308e83c2..f20ca27a5f
--- a/extra/help/tutorial/tutorial.factor
+++ b/extra/help/tutorial/tutorial.factor
@@ -23,7 +23,7 @@ $nl
$nl
"Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
{ $code "IN: palindrome" }
-"You are now ready to go on to the next section." ;
+"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ;
ARTICLE: "first-program-logic" "Writing some logic in your first program"
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
@@ -56,7 +56,7 @@ $nl
{ $code "\\ = see" }
"It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
-"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors." ;
+"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
ARTICLE: "first-program-test" "Testing your first program"
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
@@ -92,7 +92,7 @@ $nl
}
"Now, you can run unit tests:"
{ $code "\"palindrome\" test" }
-"It should report that all tests have passed." ;
+"It should report that all tests have passed. Now you can read about " { $link "first-program-extend" } "." ;
ARTICLE: "first-program-extend" "Extending your first program"
"Our palindrome program works well, however we'd like to extend it to ignore spaces and non-alphabetical characters in the input."
diff --git a/extra/html/html.factor b/extra/html/html.factor
index f9d5bde5e6..b5d4e63930 100755
--- a/extra/html/html.factor
+++ b/extra/html/html.factor
@@ -105,7 +105,7 @@ TUPLE: html-sub-stream style stream ;
TUPLE: html-span-stream ;
-M: html-span-stream stream-close
+M: html-span-stream dispose
end-sub-stream not-a-div format-html-span ;
: border-css, ( border -- )
@@ -138,7 +138,7 @@ M: html-span-stream stream-close
TUPLE: html-block-stream ;
-M: html-block-stream stream-close ( quot style stream -- )
+M: html-block-stream dispose ( quot style stream -- )
end-sub-stream a-div format-html-div ;
: border-spacing-css,
diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor
old mode 100644
new mode 100755
index 5c570993e6..d2fb719acd
--- a/extra/http/client/client-tests.factor
+++ b/extra/http/client/client-tests.factor
@@ -7,3 +7,8 @@ USING: http.client tools.test ;
[ 404 ] [ "404 File not found" parse-response ] unit-test
[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test
[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test
+
+[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
+[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
old mode 100644
new mode 100755
index 85a8b516ca..7eb84fba4c
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -44,14 +44,14 @@ DEFER: http-get-stream
#! Should this support Location: headers that are
#! relative URLs?
pick 100 /i 3 = [
- stream-close "location" swap header-single nip http-get-stream
+ dispose "location" swap header-single nip http-get-stream
] when ;
: http-get-stream ( url -- code headers stream )
#! Opens a stream for reading from an HTTP URL.
parse-url over parse-host <inet> <client> [
[ [ get-request read-response ] with-stream* ] keep
- ] [ >r stream-close r> rethrow ] recover do-redirect ;
+ ] [ ] [ dispose ] cleanup do-redirect ;
: http-get ( url -- code headers string )
#! Opens a stream for reading from an HTTP URL.
@@ -59,9 +59,23 @@ DEFER: http-get-stream
http-get-stream [ stdio get contents ] with-stream
] with-scope ;
-: download ( url file -- )
+: download-name ( url -- name )
+ file-name "?" split1 drop "/" ?tail drop ;
+
+: default-timeout 60 1000 * over set-timeout ;
+
+: success? ( code -- ? ) 200 = ;
+
+: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
- >r http-get 2nip r> <file-writer> [ write ] with-stream ;
+ >r http-get-stream nip default-timeout swap success? [
+ r> <file-writer> stream-copy
+ ] [
+ r> drop dispose "HTTP download failed" throw
+ ] if ;
+
+: download ( url -- )
+ dup download-name download-to ;
: post-request ( content-type content host resource -- )
#! Note: It is up to the caller to url encode the content if
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index 28063bae0d..072cfcf959 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -93,7 +93,7 @@ HELP: run-process*
{ $notes "User code should call " { $link run-process } " instead." } ;
HELP: >descriptor
-{ $values { "obj" object } { "desc" "a launch descriptor" } }
+{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } }
{ $description "Creates a launch descriptor from an object, which must be one of the following:"
{ $list
{ "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" }
@@ -103,12 +103,12 @@ HELP: >descriptor
} ;
HELP: run-process
-{ $values { "obj" object } { "process" process } }
+{ $values { "desc" "a launch descriptor" } { "process" process } }
{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
{ $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
HELP: run-detached
-{ $values { "obj" object } { "process" process } }
+{ $values { "desc" "a launch descriptor" } { "process" process } }
{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
{ $notes
"This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
@@ -127,12 +127,17 @@ HELP: process-stream
{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
HELP: <process-stream>
-{ $values { "obj" object } { "stream" "a bidirectional stream" } }
+{ $values
+ { "desc" "a launch descriptor" }
+ { "stream" "a bidirectional stream" } }
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." }
{ $notes "Closing the stream will block until the process exits." } ;
HELP: with-process-stream
-{ $values { "obj" object } { "quot" quotation } { "process" process } }
+{ $values
+ { "desc" "a launch descriptor" }
+ { "quot" quotation }
+ { "process" process } }
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ;
HELP: wait-for-process
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 7cf9d51ed0..9fb24fb51a 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -63,7 +63,7 @@ SYMBOL: append-environment
{ replace-environment [ ] }
} case ;
-GENERIC: >descriptor ( obj -- desc )
+GENERIC: >descriptor ( desc -- desc )
M: string >descriptor +command+ associate ;
M: sequence >descriptor +arguments+ associate ;
@@ -76,24 +76,24 @@ HOOK: run-process* io-backend ( desc -- handle )
dup [ processes get at push stop ] curry callcc0
] when process-status ;
-: run-process ( obj -- process )
+: run-process ( desc -- process )
>descriptor
dup run-process*
+detached+ rot at [ dup wait-for-process drop ] unless ;
-: run-detached ( obj -- process )
+: run-detached ( desc -- process )
>descriptor H{ { +detached+ t } } union run-process ;
HOOK: process-stream* io-backend ( desc -- stream process )
TUPLE: process-stream process ;
-: <process-stream> ( obj -- stream )
+: <process-stream> ( desc -- stream )
>descriptor process-stream*
{ set-delegate set-process-stream-process }
process-stream construct ;
-: with-process-stream ( obj quot -- process )
+: with-process-stream ( desc quot -- process )
swap <process-stream>
[ swap with-stream ] keep
process-stream-process ; inline
diff --git a/extra/io/mmap/mmap-docs.factor b/extra/io/mmap/mmap-docs.factor
old mode 100644
new mode 100755
index 22e403ed31..cb51088e58
--- a/extra/io/mmap/mmap-docs.factor
+++ b/extra/io/mmap/mmap-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax alien math ;
+USING: help.markup help.syntax alien math continuations ;
IN: io.mmap
HELP: mapped-file
@@ -15,21 +15,17 @@ 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: (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 close-mapped-file } " instead." }
-{ $errors "Throws an error if a memory mapping could not be established." } ;
-
HELP: close-mapped-file
{ $values { "mmap" mapped-file } }
-{ $description "Releases system resources associated with the mapped file." }
+{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
ARTICLE: "io.mmap" "Memory-mapped files"
"The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
{ $subsection <mapped-file> }
-{ $subsection close-mapped-file }
-"A combinator which wraps the above two words:"
+"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "."
+$nl
+"A utility combinator which wraps the above:"
{ $subsection with-mapped-file }
"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:"
{ $subsection mapped-file-address }
diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor
index 26378a06aa..af020e5a26 100755
--- a/extra/io/mmap/mmap.factor
+++ b/extra/io/mmap/mmap.factor
@@ -23,14 +23,12 @@ INSTANCE: mapped-file sequence
HOOK: <mapped-file> io-backend ( path length -- mmap )
-HOOK: (close-mapped-file) io-backend ( mmap -- )
+HOOK: close-mapped-file io-backend ( mmap -- )
-: close-mapped-file ( mmap -- )
+M: mapped-file dispose ( mmap -- )
check-closed
t over set-mapped-file-closed?
- (close-mapped-file) ;
+ close-mapped-file ;
: with-mapped-file ( path length quot -- )
- >r <mapped-file> r>
- [ keep ] curry
- [ close-mapped-file ] [ ] cleanup ; inline
+ >r <mapped-file> r> with-disposal ; inline
diff --git a/extra/io/monitor/monitor-docs.factor b/extra/io/monitor/monitor-docs.factor
new file mode 100755
index 0000000000..56fd203bde
--- /dev/null
+++ b/extra/io/monitor/monitor-docs.factor
@@ -0,0 +1,61 @@
+IN: io.monitor
+USING: help.markup help.syntax continuations ;
+
+HELP: <monitor>
+{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } }
+{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported."
+$nl
+"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;
+
+HELP: next-change
+{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a sequence of change descriptors" } }
+{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence containing at least one change descriptor; see " { $link "io.monitor.descriptors" } "." } ;
+
+HELP: with-monitor
+{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
+{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ;
+
+HELP: +change-file+
+{ $description "Indicates that the contents of the file have changed." } ;
+
+HELP: +change-name+
+{ $description "Indicates that the file name has changed." } ;
+
+HELP: +change-size+
+{ $description "Indicates that the file size has changed." } ;
+
+HELP: +change-attributes+
+{ $description "Indicates that file attributes has changed. Attributes are operating system-specific but may include the creation time and permissions." } ;
+
+HELP: +change-modified+
+{ $description "Indicates that the last modification time of the file has changed." } ;
+
+ARTICLE: "io.monitor.descriptors" "File system change descriptors"
+"Change descriptors output by " { $link next-change } ":"
+{ $subsection +change-file+ }
+{ $subsection +change-name+ }
+{ $subsection +change-size+ }
+{ $subsection +change-attributes+ }
+{ $subsection +change-modified+ } ;
+
+ARTICLE: "io.monitor" "File system change monitors"
+"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."
+$nl
+"Creating a file system change monitor and listening for changes:"
+{ $subsection <monitor> }
+{ $subsection next-change }
+{ $subsection "io.monitor.descriptors" }
+"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "."
+$nl
+"A utility combinator which opens a monitor and cleans it up after:"
+{ $subsection with-monitor }
+"An example which watches the Factor directory for changes:"
+{ $code
+ "USE: io.monitor"
+ ": watch-loop ( monitor -- )"
+ " dup next-change . . nl nl flush watch-loop ;"
+ ""
+ "\"\" resource-path f [ watch-loop ] with-monitor"
+} ;
+
+ABOUT: "io.monitor"
diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitor/monitor.factor
index 23b336c929..044fa9572b 100755
--- a/extra/io/monitor/monitor.factor
+++ b/extra/io/monitor/monitor.factor
@@ -5,8 +5,6 @@ IN: io.monitor
HOOK: <monitor> io-backend ( path recursive? -- monitor )
-HOOK: close-monitor io-backend ( monitor -- )
-
HOOK: next-change io-backend ( monitor -- path changes )
SYMBOL: +change-file+
@@ -16,4 +14,4 @@ SYMBOL: +change-attributes+
SYMBOL: +change-modified+
: with-monitor ( path recursive? quot -- )
- >r <monitor> r> over [ close-monitor ] curry [ ] cleanup ;
+ >r <monitor> r> with-disposal ; inline
diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor
old mode 100644
new mode 100755
index d6d619229f..af73a47030
--- a/extra/io/nonblocking/nonblocking-docs.factor
+++ b/extra/io/nonblocking/nonblocking-docs.factor
@@ -1,5 +1,5 @@
USING: io io.buffers io.backend help.markup help.syntax kernel
-strings sbufs words ;
+strings sbufs words continuations ;
IN: io.nonblocking
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
@@ -23,7 +23,7 @@ $nl
"Per-port native I/O protocol:"
{ $subsection init-handle }
{ $subsection (wait-to-read) }
-"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link stream-close } " generic words."
+"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words."
$nl
"Dummy ports which should be used to implement networking:"
{ $subsection server-port }
diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor
index 8a7e732281..ca50d7063a 100755
--- a/extra/io/nonblocking/nonblocking.factor
+++ b/extra/io/nonblocking/nonblocking.factor
@@ -1,16 +1,20 @@
-! Copyright (C) 2005, 2007 Slava Pestov, Doug Coleman
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
IN: io.nonblocking
-USING: math kernel io sequences io.buffers generic sbufs
-system io.streams.lines io.streams.plain io.streams.duplex
-continuations debugger classes byte-arrays namespaces
-splitting ;
+USING: math kernel io sequences io.buffers generic sbufs system
+io.streams.lines io.streams.plain io.streams.duplex io.backend
+continuations debugger classes byte-arrays namespaces splitting
+dlists assocs ;
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
! Common delegate of native stream readers and writers
-TUPLE: port handle error timeout cutoff type eof? ;
+TUPLE: port
+handle
+error
+timeout-entry timeout cutoff
+type eof? ;
SYMBOL: closed
@@ -41,19 +45,46 @@ GENERIC: close-handle ( handle -- )
: handle>duplex-stream ( in-handle out-handle -- stream )
<writer>
- [ >r <reader> r> <duplex-stream> ] [ ] [ stream-close ]
+ [ >r <reader> r> <duplex-stream> ] [ ] [ dispose ]
cleanup ;
-: touch-port ( port -- )
- dup port-timeout dup zero?
- [ 2drop ] [ millis + swap set-port-cutoff ] if ;
-
: timeout? ( port -- ? )
port-cutoff dup zero? not swap millis < and ;
: pending-error ( port -- )
dup port-error f rot set-port-error [ throw ] when* ;
+SYMBOL: timeout-queue
+
+timeout-queue global [ [ <dlist> ] unless* ] change-at
+
+: unqueue-timeout ( port -- )
+ port-timeout-entry [
+ timeout-queue get-global swap delete-node
+ ] when* ;
+
+: queue-timeout ( port -- )
+ dup timeout-queue get-global push-front*
+ swap set-port-timeout-entry ;
+
+HOOK: expire-port io-backend ( port -- )
+
+M: object expire-port drop ;
+
+: expire-timeouts ( -- )
+ timeout-queue get-global dup dlist-empty? [ drop ] [
+ dup peek-back timeout?
+ [ pop-back expire-port expire-timeouts ] [ drop ] if
+ ] if ;
+
+: touch-port ( port -- )
+ dup port-timeout dup zero? [
+ 2drop
+ ] [
+ millis + over set-port-cutoff
+ dup unqueue-timeout queue-timeout
+ ] if ;
+
M: port set-timeout
[ set-port-timeout ] keep touch-port ;
@@ -157,7 +188,7 @@ GENERIC: port-flush ( port -- )
M: output-port stream-flush ( port -- )
dup port-flush pending-error ;
-M: port stream-close
+M: port dispose
dup port-type closed eq? [
dup port-type >r closed over set-port-type r>
output-port eq? [ dup port-flush ] when
diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor
index 0141289c38..6e7cd5a940 100755
--- a/extra/io/server/server.factor
+++ b/extra/io/server/server.factor
@@ -29,8 +29,7 @@ SYMBOL: log-stream
: with-log-file ( file quot -- )
>r <file-appender> r>
- [ [ with-log-stream ] 2keep ]
- [ drop stream-close ] [ ] cleanup ; inline
+ [ with-log-stream ] with-disposal ; inline
: with-log-stdio ( quot -- )
stdio get swap with-log-stream ;
@@ -52,7 +51,7 @@ SYMBOL: log-stream
[ swap accept with-client ] 2keep accept-loop ; inline
: server-loop ( server quot -- )
- [ accept-loop ] [ drop stream-close ] [ ] cleanup ; inline
+ [ accept-loop ] compose with-disposal ; inline
: spawn-server ( addrspec quot -- )
"Waiting for connections on " pick unparse append
@@ -87,8 +86,7 @@ SYMBOL: log-stream
: spawn-datagrams ( quot addrspec -- )
"Waiting for datagrams on " over unparse append log-message
- <datagram> [ datagram-loop ] [ stream-close ] [ ] cleanup ;
- inline
+ <datagram> [ datagram-loop ] with-disposal ; inline
: with-datagrams ( seq service quot -- )
[
diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor
old mode 100644
new mode 100755
index a5c623b6b7..9136c3ca22
--- a/extra/io/sockets/sockets-docs.factor
+++ b/extra/io/sockets/sockets-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.backend threads
-strings byte-arrays ;
+strings byte-arrays continuations ;
IN: io.sockets
ARTICLE: "network-addressing" "Address specifiers"
@@ -19,7 +19,7 @@ ARTICLE: "network-connection" "Connection-oriented networking"
{ $subsection accept }
"The stream returned by " { $link accept } " holds the address specifier of the remote client:"
{ $subsection client-stream-addr }
-"Server sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol."
+"Server sockets are closed by calling " { $link dispose } "."
$nl
"Address specifiers have the following interpretation with connection-oriented networking words:"
{ $list
@@ -36,7 +36,7 @@ ARTICLE: "network-packet" "Packet-oriented networking"
"Packets can be sent and received with a pair of words:"
{ $subsection send }
{ $subsection receive }
-"Packet-oriented sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol."
+"Packet-oriented sockets are closed by calling " { $link dispose } "."
$nl
"Address specifiers have the following interpretation with connection-oriented networking words:"
{ $list
@@ -104,7 +104,7 @@ HELP: <server>
{ $description
"Begins listening for network connections to a local address. Server objects responds to two words:"
{ $list
- { { $link stream-close } " - stops listening on the port and frees all associated resources" }
+ { { $link dispose } " - stops listening on the port and frees all associated resources" }
{ { $link accept } " - blocks until there is a connection" }
}
}
@@ -128,7 +128,7 @@ HELP: <datagram>
{ $values { "addrspec" "an address specifier" } { "datagram" "a handle" } }
{ $description "Creates a datagram socket bound to a local address. Datagram socket objects responds to three words:"
{ $list
- { { $link stream-close } " - stops listening on the port and frees all associated resources" }
+ { { $link dispose } " - stops listening on the port and frees all associated resources" }
{ { $link receive } " - waits for a packet" }
{ { $link send } " - sends a packet" }
}
diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor
old mode 100644
new mode 100755
index 12a36091ce..28d1b29be8
--- a/extra/io/streams/null/null.factor
+++ b/extra/io/streams/null/null.factor
@@ -5,7 +5,7 @@ USING: kernel io ;
TUPLE: null-stream ;
-M: null-stream stream-close drop ;
+M: null-stream dispose drop ;
M: null-stream set-timeout 2drop ;
M: null-stream stream-readln drop f ;
M: null-stream stream-read1 drop f ;
diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor
old mode 100644
new mode 100755
index 5a72a5426a..71c55f2303
--- a/extra/io/unix/mmap/mmap.factor
+++ b/extra/io/unix/mmap/mmap.factor
@@ -15,7 +15,7 @@ M: unix-io <mapped-file> ( path length -- obj )
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
r> mmap-open f mapped-file construct-boa ;
-M: unix-io (close-mapped-file) ( mmap -- )
+M: unix-io close-mapped-file ( mmap -- )
[ mapped-file-address ] keep
[ mapped-file-length munmap ] keep
mapped-file-handle close
diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor
old mode 100644
new mode 100755
index 35366b1d41..748dbc40a7
--- a/extra/io/unix/sockets/sockets.factor
+++ b/extra/io/unix/sockets/sockets.factor
@@ -15,8 +15,7 @@ libc combinators ;
#! <client> don't set up error handlers until after <client>
#! returns (and if they did before, they wouldn't have
#! anything to close!)
- dup port-error dup
- [ swap stream-close throw ] [ 2drop ] if ;
+ dup port-error dup [ swap dispose throw ] [ 2drop ] if ;
: socket-fd ( domain type -- socket )
0 socket dup io-error dup init-handle ;
diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor
old mode 100644
new mode 100755
index e328e7bf5d..ce2f052450
--- a/extra/io/unix/unix-tests.factor
+++ b/extra/io/unix/unix-tests.factor
@@ -63,7 +63,7 @@ yield
"d" get send
- "d" get stream-close
+ "d" get dispose
"Done" print
@@ -104,7 +104,7 @@ client-addr <datagram>
>r >string r>
] unit-test
-[ ] [ "d" get stream-close ] unit-test
+[ ] [ "d" get dispose ] unit-test
! Test error behavior
@@ -120,7 +120,7 @@ client-addr <datagram>
B{ 1 2 3 } "unix-domain-datagram-test-3" <local> "d" get send
] unit-test-fails
-[ ] [ "d" get stream-close ] unit-test
+[ ] [ "d" get dispose ] unit-test
! See what happens on send/receive after close
diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor
index 27587e8340..d1cafa4c0f 100755
--- a/extra/io/windows/mmap/mmap.factor
+++ b/extra/io/windows/mmap/mmap.factor
@@ -81,7 +81,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
f \ mapped-file construct-boa
] with-destructors ;
-M: windows-io (close-mapped-file) ( mapped-file -- )
+M: windows-io close-mapped-file ( mapped-file -- )
[
dup mapped-file-handle [ close-always ] each
mapped-file-address UnmapViewOfFile win32-error=0/f
diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor
index 3b10ddd935..940b1b7fee 100755
--- a/extra/io/windows/nt/backend/backend.factor
+++ b/extra/io/windows/nt/backend/backend.factor
@@ -1,8 +1,8 @@
USING: alien alien.c-types arrays assocs combinators
continuations destructors io io.backend io.nonblocking
-io.windows libc kernel math namespaces sequences threads
-tuples.lib windows windows.errors windows.kernel32 strings
-splitting io.files qualified ;
+io.windows libc kernel math namespaces sequences
+threads tuples.lib windows windows.errors windows.kernel32
+strings splitting io.files qualified ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
@@ -122,19 +122,11 @@ M: windows-nt-io add-completion ( handle -- )
: drain-overlapped ( timeout -- )
handle-overlapped [ 0 drain-overlapped ] unless ;
-: maybe-expire ( io-callbck -- )
- io-callback-port
- dup timeout? [
- port-handle win32-file-handle CancelIo drop
- ] [
- drop
- ] if ;
-
-: cancel-timeout ( -- )
- io-hash get-global [ nip maybe-expire ] assoc-each ;
+M: windows-nt-io expire-port
+ port-handle win32-file-handle CancelIo drop ;
M: windows-nt-io io-multiplex ( ms -- )
- cancel-timeout drain-overlapped ;
+ expire-timeouts drain-overlapped ;
M: windows-nt-io init-io ( -- )
<master-completion-port> master-completion-port set-global
diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor
index bd3debecad..f296e859f0 100755
--- a/extra/io/windows/nt/monitor/monitor.factor
+++ b/extra/io/windows/nt/monitor/monitor.factor
@@ -34,8 +34,6 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
: check-closed ( monitor -- )
port-type closed eq? [ "Monitor closed" throw ] when ;
-M: windows-nt-io close-monitor ( monitor -- ) stream-close ;
-
: begin-reading-changes ( monitor -- overlapped )
dup port-handle win32-file-handle
over buffer-ptr
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 03cb3be9ae..419864b624 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -1,10 +1,11 @@
-! Copyright (C) 2004, 2007 Mackenzie Straight, Doug Coleman.
+! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.nonblocking io.sockets io.binary
io.sockets.impl windows.errors strings io.streams.duplex kernel
math namespaces sequences windows windows.kernel32
-windows.shell32 windows.types windows.winsock splitting ;
+windows.shell32 windows.types windows.winsock splitting
+continuations ;
IN: io.windows
TUPLE: windows-nt-io ;
@@ -174,7 +175,7 @@ USE: namespaces
: listen-on-socket ( socket -- )
listen-backlog listen winsock-return-check ;
-M: win32-socket stream-close ( stream -- )
+M: win32-socket dispose ( stream -- )
win32-file-handle closesocket drop ;
M: windows-io addrinfo-error ( n -- )
diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor
old mode 100644
new mode 100755
index 6f54768cab..74d8951d10
--- a/extra/irc/irc.factor
+++ b/extra/irc/irc.factor
@@ -185,7 +185,7 @@ SYMBOL: line
dup irc-client-profile profile-server
over irc-client-profile profile-port connect*
dup irc-client-profile profile-nickname login
- [ irc-loop ] [ irc-stream> stream-close ] [ ] cleanup ;
+ [ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ;
: with-infinite-loop ( quot timeout -- quot timeout )
"looping" print flush
diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor
old mode 100644
new mode 100755
index 4a737f06c2..ee312c1111
--- a/extra/tar/tar.factor
+++ b/extra/tar/tar.factor
@@ -95,7 +95,7 @@ TUPLE: unimplemented-typeflag header ;
! Normal file
: typeflag-0
tar-header-name tar-path+ <file-writer>
- [ read-data-blocks ] keep stream-close ;
+ [ read-data-blocks ] keep dispose ;
! Hard link
: typeflag-1 ( header -- )
@@ -221,7 +221,7 @@ TUPLE: unimplemented-typeflag header ;
[ <unknown-typeflag> throw ]
} case
! dup tar-header-size zero? [
- ! out-stream get [ stream-close ] when
+ ! out-stream get [ dispose ] when
! out-stream off
! drop
! ] [
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index 83e0ea5ec3..f2bd03475f 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -9,15 +9,16 @@ quotations io.launcher words.private tools.deploy.config
bootstrap.image ;
IN: tools.deploy.backend
-: (copy-lines) ( stream -- stream )
- dup stream-readln [ print flush (copy-lines) ] when* ;
+: (copy-lines) ( stream -- )
+ dup stream-readln dup
+ [ print flush (copy-lines) ] [ 2drop ] if ;
: copy-lines ( stream -- )
- [ (copy-lines) ] [ stream-close ] [ ] cleanup ;
+ [ (copy-lines) ] with-disposal ;
: run-with-output ( descriptor -- )
<process-stream>
- dup duplex-stream-out stream-close
+ dup duplex-stream-out dispose
copy-lines ;
: boot-image-name ( -- string )
diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor
index 016d02e527..dde312b34d 100755
--- a/extra/ui/gadgets/panes/panes.factor
+++ b/extra/ui/gadgets/panes/panes.factor
@@ -8,7 +8,7 @@ hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors
io.streams.duplex sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
-ui.gadgets.grid-lines tuples models ;
+ui.gadgets.grid-lines tuples models continuations ;
IN: ui.gadgets.panes
TUPLE: pane output current prototype scrolls?
@@ -161,7 +161,7 @@ M: pane-stream stream-write
M: pane-stream stream-format
[ rot string-lines pane-format ] do-pane-stream ;
-M: pane-stream stream-close drop ;
+M: pane-stream dispose drop ;
M: pane-stream stream-flush drop ;
@@ -249,7 +249,7 @@ TUPLE: nested-pane-stream style parent ;
TUPLE: pane-block-stream ;
-M: pane-block-stream stream-close
+M: pane-block-stream dispose
unnest-pane-stream write-gadget ;
M: pane-stream make-block-stream
@@ -272,7 +272,7 @@ M: pane-stream make-block-stream
TUPLE: pane-cell-stream ;
-M: pane-cell-stream stream-close ?nl ;
+M: pane-cell-stream dispose ?nl ;
M: pane-stream make-cell-stream
<nested-pane-stream> pane-cell-stream construct-delegate ;
@@ -284,9 +284,9 @@ M: pane-stream stream-write-table
r> print-gadget ;
! Stream utilities
-M: pack stream-close drop ;
+M: pack dispose drop ;
-M: paragraph stream-close drop ;
+M: paragraph dispose drop ;
: gadget-write ( string gadget -- )
over empty? [
diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor
index 9c9242edc3..70a9c781a2 100644
--- a/extra/unicode/breaks/breaks.factor
+++ b/extra/unicode/breaks/breaks.factor
@@ -1,7 +1,7 @@
USING: unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
combinators.lib assocs.lib math.ranges unicode.normalize
-unicode.syntax unicode.data compiler.units alien.syntax ;
+unicode.syntax unicode.data compiler.units alien.syntax const ;
IN: unicode.breaks
C-ENUM: Any L V T Extend Control CR LF graphemes ;
@@ -32,7 +32,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
: other-extend-lines ( -- lines )
"extra/unicode/PropList.txt" resource-path file-lines ;
-DEFER: other-extend
+VALUE: other-extend
CATEGORY: (extend) Me Mn ;
: extend? ( ch -- ? )
@@ -77,7 +77,7 @@ SYMBOL: table
T T connect
graphemes Extend connect-after ;
-DEFER: grapheme-table
+VALUE: grapheme-table
: grapheme-break? ( class1 class2 -- ? )
grapheme-table nth nth not ;
@@ -113,10 +113,10 @@ DEFER: grapheme-table
[ grapheme-class dup rot grapheme-break? ] find-last-index
nip -1 or 1+ ;
-<<
- other-extend-lines process-other-extend \ other-extend define-value
+[
+ other-extend-lines process-other-extend \ other-extend set-value
init-grapheme-table table
[ make-grapheme-table finish-table ] with-variable
- \ grapheme-table define-value
->>
+ \ grapheme-table set-value
+] with-compilation-unit
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index e112471c28..c579d1fdfd 100644
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -1,15 +1,12 @@
USING: assocs math kernel sequences io.files hashtables
quotations splitting arrays math.parser combinators.lib hash2
-byte-arrays words namespaces words compiler.units ;
+byte-arrays words namespaces words compiler.units const ;
IN: unicode.data
! Convenience functions
: 1+* ( n/f _ -- n+1 )
drop [ 1+ ] [ 0 ] if* ;
-: define-value ( value word -- )
- swap 1quotation define ;
-
: ?between? ( n/f from to -- ? )
pick [ between? ] [ 3drop f ] if ;
@@ -107,16 +104,16 @@ C: <code-point> code-point
4 head [ multihex ] map first4
<code-point> swap first set ;
-DEFER: simple-lower
-DEFER: simple-upper
-DEFER: simple-title
-DEFER: canonical-map
-DEFER: combine-map
-DEFER: class-map
-DEFER: compat-map
-DEFER: category-map
-DEFER: name-map
-DEFER: special-casing
+VALUE: simple-lower
+VALUE: simple-upper
+VALUE: simple-title
+VALUE: canonical-map
+VALUE: combine-map
+VALUE: class-map
+VALUE: compat-map
+VALUE: category-map
+VALUE: name-map
+VALUE: special-casing
: canonical-entry ( char -- seq ) canonical-map at ;
: combine-chars ( a b -- char/f ) combine-map hash2 ;
@@ -132,16 +129,14 @@ DEFER: special-casing
[ length 5 = ] subset
[ [ set-code-point ] each ] H{ } make-assoc ;
-[
- load-data
- dup process-names \ name-map define-value
- 13 over process-data \ simple-lower define-value
- 12 over process-data tuck \ simple-upper define-value
- 14 over process-data swapd union \ simple-title define-value
- dup process-combining \ class-map define-value
- dup process-canonical \ canonical-map define-value
- \ combine-map define-value
- dup process-compat \ compat-map define-value
- process-category \ category-map define-value
- load-special-casing \ special-casing define-value
-] with-compilation-unit
+load-data
+dup process-names \ name-map set-value
+13 over process-data \ simple-lower set-value
+12 over process-data tuck \ simple-upper set-value
+14 over process-data swapd union \ simple-title set-value
+dup process-combining \ class-map set-value
+dup process-canonical \ canonical-map set-value
+ \ combine-map set-value
+dup process-compat \ compat-map set-value
+process-category \ category-map set-value
+load-special-casing \ special-casing set-value
diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor
index 86a922793f..b018d115f8 100644
--- a/extra/unicode/normalize/normalize.factor
+++ b/extra/unicode/normalize/normalize.factor
@@ -2,7 +2,7 @@ USING: sequences namespaces unicode.data kernel combinators.lib
math arrays ;
IN: unicode.normalize
-! Utility word
+! Utility word--probably unnecessary
: make* ( seq quot exemplar -- newseq )
! quot has access to original seq on stack
! this just makes the new-resizable the same length as seq
@@ -89,7 +89,7 @@ IN: unicode.normalize
swap [ [
dup hangul? [ hangul>jamo % drop ]
[ dup rot call [ % ] [ , ] ?if ] if
- ] with each ] "" make*
+ ] with each ] "" make
dup reorder
] if ; inline
@@ -167,7 +167,7 @@ SYMBOL: char
0 ind set
SBUF" " clone after set
pass-combining (compose)
- ] "" make* ;
+ ] "" make ;
: nfc ( string -- nfc )
nfd compose ;
diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor
index 5119663872..6c75a77c76 100644
--- a/extra/unicode/syntax/syntax.factor
+++ b/extra/unicode/syntax/syntax.factor
@@ -1,5 +1,5 @@
USING: unicode.data kernel math sequences parser bit-arrays namespaces
-sequences.private arrays quotations classes.predicate ;
+sequences.private arrays quotations classes.predicate assocs ;
IN: unicode.syntax
! Character classes (categories)
@@ -48,5 +48,5 @@ IN: unicode.syntax
categories swap seq-minus define-category ; parsing
: UNICHAR:
- ! This should be part of CHAR:
+ ! This should be part of CHAR:. Also, name-map at ==> name>char
scan name>char [ parsed ] [ "Invalid character" throw ] if* ; parsing
diff --git a/extra/xml/entities/entities.factor b/extra/xml/entities/entities.factor
index a52f5be3dc..b90613ec79 100644
--- a/extra/xml/entities/entities.factor
+++ b/extra/xml/entities/entities.factor
@@ -1,8 +1,32 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel ;
+USING: namespaces kernel assocs sequences ;
IN: xml.entities
+: entities-out
+ H{
+ { CHAR: < "<" }
+ { CHAR: > ">" }
+ { CHAR: & "&" }
+ } ;
+
+: quoted-entities-out
+ H{
+ { CHAR: & "&" }
+ { CHAR: ' "'" }
+ { CHAR: " """ }
+ } ;
+
+: escape-string-by ( str table -- escaped )
+ #! Convert <, >, &, ' and " to HTML entities.
+ [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ;
+
+: escape-string ( str -- newstr )
+ entities-out escape-string-by ;
+
+: escape-quoted-string ( str -- newstr )
+ quoted-entities-out escape-string-by ;
+
: entities
H{
{ "lt" CHAR: < }
diff --git a/extra/xml/test/templating.factor b/extra/xml/test/templating.factor
index 0ee4ae51b0..2dd69ca99b 100644
--- a/extra/xml/test/templating.factor
+++ b/extra/xml/test/templating.factor
@@ -1,4 +1,3 @@
-IN: templating
USING: kernel xml sequences assocs tools.test io arrays namespaces
xml.data xml.utilities xml.writer generic sequences.deep ;
@@ -9,10 +8,10 @@ SYMBOL: ref-table
GENERIC: (r-ref) ( xml -- )
M: tag (r-ref)
- sub-tag over at [
+ sub-tag over at* [
ref-table get at
swap set-tag-children
- ] [ drop ] if* ;
+ ] [ 2drop ] if ;
M: object (r-ref) drop ;
: template ( xml -- )
@@ -40,4 +39,4 @@ M: object (r-ref) drop ;
sample-doc string>xml dup template xml>string
] with-scope ;
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test
+[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test
diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor
index 80a508787e..ec59d3564e 100644
--- a/extra/xml/test/test.factor
+++ b/extra/xml/test/test.factor
@@ -26,7 +26,7 @@ SYMBOL: xml-file
] unit-test
[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test
[ "that" ] [ xml-file get "this" swap at ] unit-test
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<a b=\"c\"/>" ]
+[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><a b=\"c\"/>" ]
[ "<a b='c'/>" string>xml xml>string ] unit-test
[ "abcd" ] [
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml
@@ -44,7 +44,7 @@ SYMBOL: xml-file
at swap "z" >r tuck r> swap set-at
T{ name f "blah" "z" f } swap at ] unit-test
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<foo>bar baz</foo>" ]
+[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><foo>bar baz</foo>" ]
[ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<foo>\n bar\n</foo>" ]
[ "<foo> bar </foo>" string>xml pprint-xml>string ] unit-test
diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor
index 7bd1cc3046..95f38f3da9 100644
--- a/extra/xml/writer/writer.factor
+++ b/extra/xml/writer/writer.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math namespaces sequences strings
-io io.streams.string xml.data assocs ;
+io io.streams.string xml.data assocs wrap xml.entities ;
IN: xml.writer
SYMBOL: xml-pprint?
@@ -13,10 +13,13 @@ SYMBOL: indenter
: sensitive? ( tag -- ? )
sensitive-tags get swap [ names-match? ] curry contains? ;
+: indent-string ( -- string )
+ xml-pprint? get
+ [ indentation get indenter get <repetition> concat ]
+ [ "" ] if ;
+
: ?indent ( -- )
- xml-pprint? get [
- nl indentation get indenter get <repetition> [ write ] each
- ] when ;
+ xml-pprint? get [ nl indent-string write ] when ;
: indent ( -- )
xml-pprint? get [ 1 indentation +@ ] when ;
@@ -35,30 +38,6 @@ SYMBOL: indenter
[ dup empty? swap string? and not ] subset
] when ;
-: entities-out
- H{
- { CHAR: < "<" }
- { CHAR: > ">" }
- { CHAR: & "&" }
- } ;
-
-: quoted-entities-out
- H{
- { CHAR: & "&" }
- { CHAR: ' "'" }
- { CHAR: " """ }
- } ;
-
-: escape-string-by ( str table -- escaped )
- #! Convert <, >, &, ' and " to HTML entities.
- [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ;
-
-: escape-string ( str -- newstr )
- entities-out escape-string-by ;
-
-: escape-quoted-string ( str -- newstr )
- quoted-entities-out escape-string-by ;
-
: print-name ( name -- )
dup name-space f like
[ write CHAR: : write1 ] when*
@@ -76,10 +55,11 @@ SYMBOL: indenter
GENERIC: write-item ( object -- )
M: string write-item
- escape-string write ;
+ escape-string dup empty? not xml-pprint? get and
+ [ nl 80 indent-string indented-break ] when write ;
: write-tag ( tag -- )
- CHAR: < write1
+ ?indent CHAR: < write1
dup print-name tag-attrs print-attrs ;
M: contained-tag write-item
@@ -87,7 +67,7 @@ M: contained-tag write-item
: write-children ( tag -- )
indent tag-children ?filter-children
- [ ?indent write-item ] each unindent ;
+ [ write-item ] each unindent ;
: write-end-tag ( tag -- )
?indent "</" write print-name CHAR: > write1 ;
@@ -112,7 +92,7 @@ M: instruction write-item
"<?xml version=\"" write dup prolog-version write
"\" encoding=\"" write dup prolog-encoding write
prolog-standalone [ "\" standalone=\"yes" write ] when
- "\"?>\n" write ;
+ "\"?>" write ;
: write-chunk ( seq -- )
[ write-item ] each ;
diff --git a/vm/Config.netbsd b/vm/Config.netbsd
new file mode 100644
index 0000000000..5fb5966b1e
--- /dev/null
+++ b/vm/Config.netbsd
@@ -0,0 +1,5 @@
+include vm/Config.unix
+PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o
+CFLAGS += -export-dynamic
+LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
+LIBS = -lm $(X11_UI_LIBS)
diff --git a/vm/Config.netbsd.x86.32 b/vm/Config.netbsd.x86.32
new file mode 100644
index 0000000000..849bd65732
--- /dev/null
+++ b/vm/Config.netbsd.x86.32
@@ -0,0 +1,2 @@
+include vm/Config.netbsd
+include vm/Config.x86.32
diff --git a/vm/Config.netbsd.x86.64 b/vm/Config.netbsd.x86.64
new file mode 100644
index 0000000000..24f86d0118
--- /dev/null
+++ b/vm/Config.netbsd.x86.64
@@ -0,0 +1,2 @@
+include vm/Config.netbsd
+include vm/Config.x86.64
diff --git a/vm/os-netbsd.c b/vm/os-netbsd.c
new file mode 100644
index 0000000000..b9238b7877
--- /dev/null
+++ b/vm/os-netbsd.c
@@ -0,0 +1,6 @@
+#include "master.h"
+
+const char *vm_executable_path(void)
+{
+ return NULL;
+}
diff --git a/vm/os-netbsd.h b/vm/os-netbsd.h
new file mode 100644
index 0000000000..e282828577
--- /dev/null
+++ b/vm/os-netbsd.h
@@ -0,0 +1,9 @@
+#include <ucontext.h>
+
+#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
+#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
+
+#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
+#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
+
+extern char **environ;
diff --git a/vm/platform.h b/vm/platform.h
index 40324cc330..b0641176bc 100644
--- a/vm/platform.h
+++ b/vm/platform.h
@@ -58,6 +58,9 @@
#else
#error "Unsupported OpenBSD flavor"
#endif
+ #elif defined(__NetBSD__)
+ #define FACTOR_OS_STRING "netbsd"
+ #include "os-netbsd.h"
#elif defined(linux)
#define FACTOR_OS_STRING "linux"
#include "os-linux.h"