From bf85f0e75c0ac7521114d0fe38a755890840daa6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 15 Oct 2007 23:55:08 -0500
Subject: [PATCH 1/5] Remove duplicate definitions
---
extra/windows/kernel32/kernel32.factor | 7 -------
1 file changed, 7 deletions(-)
diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor
index a11d352a52..e11f6ed081 100644
--- a/extra/windows/kernel32/kernel32.factor
+++ b/extra/windows/kernel32/kernel32.factor
@@ -16,13 +16,6 @@ IN: windows.kernel32
: GENERIC_EXECUTE HEX: 20000000 ; inline
: GENERIC_ALL HEX: 10000000 ; inline
-: DELETE HEX: 00010000 ; inline
-: READ_CONTROL HEX: 00020000 ; inline
-: WRITE_DAC HEX: 00040000 ; inline
-: WRITE_OWNER HEX: 00080000 ; inline
-: SYNCHRONIZE HEX: 00100000 ; inline
-: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
-
: CREATE_NEW 1 ; inline
: CREATE_ALWAYS 2 ; inline
: OPEN_EXISTING 3 ; inline
From e9075501b0d6f61efa8ec14abc3a5fa10ee23ca4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 16 Oct 2007 01:35:32 -0400
Subject: [PATCH 2/5] Fix planet USING:
---
extra/webapps/planet/planet.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index bdbb1ccd29..c79a7113db 100644
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -1,6 +1,7 @@
USING: sequences rss arrays concurrency kernel sorting
html.elements io assocs namespaces math threads vocabs html
-furnace http.server.templating calendar math.parser splitting ;
+furnace http.server.templating calendar math.parser splitting
+continuations debugger ;
IN: webapps.planet
TUPLE: posting author title date link body ;
From 0a1799f4b5c85803c5de95341951cf433326569f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 16 Oct 2007 04:14:44 -0400
Subject: [PATCH 3/5] Fix base64 typo
---
extra/base64/base64.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/base64/base64.factor b/extra/base64/base64.factor
index 7bbf422ea0..f338786f85 100644
--- a/extra/base64/base64.factor
+++ b/extra/base64/base64.factor
@@ -33,7 +33,7 @@ PRIVATE>
: >base64 ( seq -- base64 )
#! cut string into two pieces, convert 3 bytes at a time
#! pad string with = when not enough bits
- dup length dup 3 mod - swap
+ dup length dup 3 mod - cut swap
[
3 group [ encode3 % ] each
dup empty? [ drop ] [ >base64-rem % ] if
From 1d8bd74d0f712015ec8458a798a21aa00dc0165e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 16 Oct 2007 04:15:16 -0400
Subject: [PATCH 4/5] new unfold word
---
core/bootstrap/image/image.factor | 12 +++---------
core/classes/classes.factor | 10 ++++------
core/io/io.factor | 4 +---
core/kernel/kernel.factor | 5 +++++
core/sequences/sequences.factor | 7 +++++++
core/tuples/tuples.factor | 3 ++-
extra/concurrency/concurrency.factor | 12 +++---------
extra/help/crossref/crossref.factor | 5 +----
extra/io/sockets/impl/impl.factor | 7 +++----
extra/serialize/serialize-tests.factor | 10 ++++++++++
extra/serialize/serialize.factor | 5 +----
extra/store/blob/blob.factor | 2 +-
extra/ui/gadgets/gadgets.factor | 10 ++--------
extra/xml-rpc/xml-rpc.factor | 2 +-
14 files changed, 44 insertions(+), 50 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index c749ec3dad..423b25b69e 100644
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -153,17 +153,11 @@ GENERIC: ' ( obj -- ptr )
: bignum-radix bignum-bits 2^ 1- ;
-: (bignum>seq) ( n -- )
- dup zero? [
- drop
- ] [
- dup bignum-radix bitand ,
- bignum-bits neg shift (bignum>seq)
- ] if ;
-
: bignum>seq ( n -- seq )
#! n is positive or zero.
- [ (bignum>seq) ] { } make ;
+ [ dup 0 > ]
+ [ dup bignum-bits neg shift swap bignum-radix bitand ]
+ { } unfold ;
: emit-bignum ( n -- )
[ 0 < 1 0 ? ] keep abs bignum>seq
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 41be3dd484..a17866aa3b 100644
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -127,15 +127,13 @@ DEFER: (class<)
curry* subset empty?
] curry find [ "Topological sort failed" throw ] unless* ;
-: (sort-classes) ( vec -- )
- dup empty?
- [ drop ]
- [ dup largest-class , over delete-nth (sort-classes) ] if ;
-
PRIVATE>
: sort-classes ( seq -- newseq )
- [ >vector (sort-classes) ] { } make ;
+ >vector
+ [ dup empty? not ]
+ [ dup largest-class >r over delete-nth r> ]
+ { } unfold ;
: class-or ( class1 class2 -- class )
{
diff --git a/core/io/io.factor b/core/io/io.factor
index 4580d83241..d00a208e4e 100644
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -85,10 +85,8 @@ SYMBOL: stdio
: write-object ( str obj -- )
presented associate format ;
-: lines-loop ( -- ) readln [ , lines-loop ] when* ;
-
: lines ( stream -- seq )
- [ [ lines-loop ] { } make ] with-stream ;
+ [ [ readln dup ] [ ] { } unfold ] with-stream ;
: contents ( stream -- str )
2048 <sbuf> [ stream-copy ] keep >string ;
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index ba054140c7..88ca0a64f7 100644
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -60,6 +60,11 @@ DEFER: if
: 2apply ( x y quot -- ) tuck 2slip call ; inline
+: while ( pred body tail -- )
+ >r >r dup slip r> r> roll
+ [ >r tuck 2slip r> while ]
+ [ 2nip call ] if ; inline
+
! Quotation building
: 2curry ( obj1 obj2 quot -- curry )
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 3c63cd5cb4..5d4e23db7c 100644
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -655,3 +655,10 @@ PRIVATE>
: trim ( seq quot -- newseq )
[ ltrim ] keep rtrim ; inline
+
+: unfold ( obj pred quot exemplar -- seq )
+ [
+ 10 swap new-resizable [
+ [ push ] curry compose [ drop ] while
+ ] keep
+ ] keep like ; inline
diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor
index ce32ef3cd5..edd37abb65 100644
--- a/core/tuples/tuples.factor
+++ b/core/tuples/tuples.factor
@@ -106,7 +106,8 @@ M: tuple equal?
: (delegates) ( obj -- )
[ dup , delegate (delegates) ] when* ;
-: delegates ( obj -- seq ) [ (delegates) ] { } make ;
+: delegates ( obj -- seq )
+ [ dup ] [ [ delegate ] keep ] { } unfold ;
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor
index 14f74f5d55..94bda9e720 100644
--- a/extra/concurrency/concurrency.factor
+++ b/extra/concurrency/concurrency.factor
@@ -40,17 +40,11 @@ PRIVATE>
(mailbox-block-if-empty)
mailbox-data dlist-pop-front ;
-<PRIVATE
-: (mailbox-get-all) ( mailbox -- )
- dup mailbox-empty? [
- drop
- ] [
- dup mailbox-data dlist-pop-front , (mailbox-get-all)
- ] if ;
-PRIVATE>
: mailbox-get-all ( mailbox -- array )
(mailbox-block-if-empty)
- [ (mailbox-get-all) ] { } make ;
+ [ dup mailbox-empty? ]
+ [ dup mailbox-data dlist-pop-front ]
+ { } unfold ;
: while-mailbox-empty ( mailbox quot -- )
over mailbox-empty? [
diff --git a/extra/help/crossref/crossref.factor b/extra/help/crossref/crossref.factor
index 2dae83ffee..9597a51471 100644
--- a/extra/help/crossref/crossref.factor
+++ b/extra/help/crossref/crossref.factor
@@ -13,11 +13,8 @@ M: link uses
{ $subsection $link $see-also }
collect-elements [ \ f or ] map ;
-: (help-path) ( topic -- )
- article-parent [ dup , (help-path) ] when* ;
-
: help-path ( topic -- seq )
- [ (help-path) ] { } make ;
+ [ dup ] [ [ article-parent ] keep ] { } unfold 1 tail ;
: set-article-parents ( parent article -- )
article-children [ set-article-parent ] curry* each ;
diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor
index e99c8d213a..b03ec94a6b 100644
--- a/extra/io/sockets/impl/impl.factor
+++ b/extra/io/sockets/impl/impl.factor
@@ -94,11 +94,10 @@ M: f parse-sockaddr nip ;
swap addrinfo-family addrspec-of-family
parse-sockaddr ;
-: addrspec, ( addrinfo -- )
- [ dup addrinfo>addrspec , addrinfo-next addrspec, ] when* ;
-
: parse-addrinfo-list ( addrinfo -- seq )
- [ addrspec, ] { } make [ ] subset ;
+ [ dup ]
+ [ dup addrinfo-next swap addrinfo>addrspec ]
+ { } unfold [ ] subset ;
M: object resolve-host ( host serv passive? -- seq )
>r dup integer? [ number>string ] when
diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor
index f40499f534..a713840a20 100644
--- a/extra/serialize/serialize-tests.factor
+++ b/extra/serialize/serialize-tests.factor
@@ -59,3 +59,13 @@ C: <serialize-test> serialize-test
[ t ] [ objects [ check-serialize-2 ] all? ] unit-test
[ t ] [ pi check-serialize-1 ] unit-test
+
+[ t ] [
+ { 1 2 3 } [
+ [
+ dup (serialize) (serialize)
+ ] with-serialized
+ ] string-out [
+ deserialize-sequence all-eq?
+ ] string-in
+] unit-test
diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor
index 370033152b..632ed763fb 100644
--- a/extra/serialize/serialize.factor
+++ b/extra/serialize/serialize.factor
@@ -260,11 +260,8 @@ DEFER: (deserialize) ( -- obj )
: with-serialized ( quot -- )
V{ } clone serialized rot with-variable ; inline
-: (deserialize-sequence)
- deserialize* [ , (deserialize-sequence) ] [ drop ] if ;
-
: deserialize-sequence ( -- seq )
- [ (deserialize-sequence) ] { } make ;
+ [ [ deserialize* ] [ ] { } unfold ] with-serialized ;
: deserialize ( -- obj )
[ (deserialize) ] with-serialized ;
diff --git a/extra/store/blob/blob.factor b/extra/store/blob/blob.factor
index a903471c8f..9cec77c6c2 100644
--- a/extra/store/blob/blob.factor
+++ b/extra/store/blob/blob.factor
@@ -11,7 +11,7 @@ IN: store.blob
: (load-blob) ( path -- seq/f )
dup exists? [
<file-reader> [
- [ deserialize-sequence ] with-serialized
+ deserialize-sequence
] with-stream
] [
drop f
diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor
index 3d3dd4244b..214c5b4921 100644
--- a/extra/ui/gadgets/gadgets.factor
+++ b/extra/ui/gadgets/gadgets.factor
@@ -285,11 +285,8 @@ M: gadget ungraft* drop ;
: add-gadgets ( seq parent -- )
swap [ over (add-gadget) ] each relayout ;
-: (parents) ( gadget -- )
- [ dup , gadget-parent (parents) ] when* ;
-
: parents ( gadget -- seq )
- [ (parents) ] { } make ;
+ [ dup ] [ [ gadget-parent ] keep ] { } unfold ;
: each-parent ( gadget quot -- ? )
>r parents r> all? ; inline
@@ -335,11 +332,8 @@ M: f request-focus-on 2drop ;
: request-focus ( gadget -- )
dup focusable-child swap request-focus-on ;
-: (focus-path) ( gadget -- )
- [ dup , gadget-focus (focus-path) ] when* ;
-
: focus-path ( world -- seq )
- [ (focus-path) ] { } make ;
+ [ dup ] [ [ gadget-focus ] keep ] { } unfold ;
: make-gadget ( quot gadget -- gadget )
[ \ make-gadget rot with-variable ] keep ; inline
diff --git a/extra/xml-rpc/xml-rpc.factor b/extra/xml-rpc/xml-rpc.factor
index 3e04a8dd85..a7603a939e 100644
--- a/extra/xml-rpc/xml-rpc.factor
+++ b/extra/xml-rpc/xml-rpc.factor
@@ -35,7 +35,7 @@ M: string item>xml ! This should change < and &
2array "member" build-tag* ;
M: hashtable item>xml
- [ [ struct-member , ] assoc-each ] { } make
+ [ struct-member ] { } assoc>map
"struct" build-tag* ;
M: array item>xml
From 1ccca6cac02a130c8bdca06f1bb5143d0aa9c0fe Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 18 Oct 2007 14:38:00 -0400
Subject: [PATCH 5/5] Rename prettyprint:break to prettyprint:line-break
---
core/prettyprint/backend/backend.factor | 4 ++--
core/prettyprint/prettyprint-docs.factor | 2 +-
core/prettyprint/prettyprint.factor | 2 +-
.../prettyprint/sections/sections-docs.factor | 14 +++++------
core/prettyprint/sections/sections.factor | 24 ++++++++++---------
5 files changed, 24 insertions(+), 22 deletions(-)
diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor
index 1a376ef0e1..363071ccbd 100644
--- a/core/prettyprint/backend/backend.factor
+++ b/core/prettyprint/backend/backend.factor
@@ -44,10 +44,10 @@ M: word pprint*
dup parsing? [
\ POSTPONE: [ pprint-word ] pprint-prefix
] [
- dup "break-before" word-prop break
+ dup "break-before" word-prop line-break
dup pprint-word
dup ?start-group dup ?end-group
- "break-after" word-prop break
+ "break-after" word-prop line-break
] if ;
M: real pprint* number>string text ;
diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor
index 8467391d6d..2b01df8faa 100644
--- a/core/prettyprint/prettyprint-docs.factor
+++ b/core/prettyprint/prettyprint-docs.factor
@@ -72,7 +72,7 @@ $nl
"Once the output sections have been generated, the tree of sections is traversed and intelligent decisions are made about indentation and line breaks. Finally, text is output."
{ $subsection section }
"Adding leaf sections:"
-{ $subsection break }
+{ $subsection line-break }
{ $subsection text }
{ $subsection styled-text }
"Nesting and denesting sections:"
diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor
index 011a8cc851..ce54bc6b9b 100644
--- a/core/prettyprint/prettyprint.factor
+++ b/core/prettyprint/prettyprint.factor
@@ -227,7 +227,7 @@ M: mixin-class see-class*
\ MIXIN: pprint-word
dup pprint-word <block
dup members [
- hard break
+ hard line-break
\ INSTANCE: pprint-word pprint-word pprint-word
] curry* each block> ;
diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor
index d55ec36bbd..ad47dc0664 100644
--- a/core/prettyprint/sections/sections-docs.factor
+++ b/core/prettyprint/sections/sections-docs.factor
@@ -30,10 +30,10 @@ HELP: fresh-line
{ $description "Advances the prettyprinter by one line unless the current line is empty. If the line limit is exceeded, escapes the prettyprinter by restoring a continuation captured in " { $link do-pprint } "." } ;
HELP: soft
-{ $description "Possible input parameter to " { $link break } "." } ;
+{ $description "Possible input parameter to " { $link line-break } "." } ;
HELP: hard
-{ $description "Possible input parameter to " { $link break } "." } ;
+{ $description "Possible input parameter to " { $link line-break } "." } ;
{ soft hard } related-words
@@ -70,7 +70,7 @@ HELP: section
{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various classes which delegate to this class:"
{ $list
{ $link text }
- { $link break }
+ { $link line-break }
{ $link block }
{ $link inset }
{ $link flow }
@@ -123,7 +123,7 @@ HELP: pprint-section
{ $contract "Prints a section, performing wrapping and indentation using available formatting information." }
$prettyprinting-note ;
-HELP: break
+HELP: line-break
{ $values { "type" { $link soft } " or " { $link hard } } }
{ $description "Adds a section introducing a line break to the current block. If the block is output as a " { $link short-section } ", all breaks are ignored. Otherwise, hard breaks introduce unconditional newlines, and soft breaks introduce a newline if the position is more than half of the " { $link margin } "." }
$prettyprinting-note ;
@@ -158,11 +158,11 @@ HELP: save-end-position
HELP: pprint-sections
{ $values { "block" block } { "advancer" "a quotation with stack effect " { $snippet "( block -- )" } } }
-{ $description "Prints child sections of a block, ignoring any " { $link break } " sections. The " { $snippet "advancer" } " quotation is called between every pair of sections." } ;
+{ $description "Prints child sections of a block, ignoring any " { $link line-break } " sections. The " { $snippet "advancer" } " quotation is called between every pair of sections." } ;
HELP: do-break
-{ $values { "break" break } }
-{ $description "Prints a break section as per the policy outlined in " { $link break } "." } ;
+{ $values { "break" line-break } }
+{ $description "Prints a break section as per the policy outlined in " { $link line-break } "." } ;
HELP: empty-block?
{ $values { "block" block } { "?" "a boolean" } }
diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor
index ff8e8b297d..063dcb7fd4 100644
--- a/core/prettyprint/sections/sections.factor
+++ b/core/prettyprint/sections/sections.factor
@@ -124,15 +124,16 @@ M: object short-section? section-fits? ;
] if ;
! Break section
-TUPLE: break type ;
+TUPLE: line-break type ;
-: <break> ( type -- section )
+: <line-break> ( type -- section )
H{ } 0 <section>
- { set-break-type set-delegate } \ break construct ;
+ { set-line-break-type set-delegate }
+ \ line-break construct ;
-M: break short-section drop ;
+M: line-break short-section drop ;
-M: break long-section drop ;
+M: line-break long-section drop ;
! Block sections
TUPLE: block sections ;
@@ -149,7 +150,8 @@ TUPLE: block sections ;
pprinter-block block-sections push ;
: last-section ( -- section )
- pprinter-block block-sections [ break? not ] find-last nip ;
+ pprinter-block block-sections
+ [ line-break? not ] find-last nip ;
: start-group ( -- )
t last-section set-section-start-group? ;
@@ -162,13 +164,13 @@ TUPLE: block sections ;
swap short-section? and
[ bl ] when ;
-: break ( type -- ) [ <break> add-section ] when* ;
+: line-break ( type -- ) [ <line-break> add-section ] when* ;
M: block section-fits? ( section -- ? )
line-limit? [ drop t ] [ delegate section-fits? ] if ;
: pprint-sections ( block advancer -- )
- swap block-sections [ break? not ] subset
+ swap block-sections [ line-break? not ] subset
unclip pprint-section [
dup rot call pprint-section
] curry* each ; inline
@@ -177,7 +179,7 @@ M: block short-section ( block -- )
[ advance ] pprint-sections ;
: do-break ( break -- )
- dup break-type hard eq?
+ dup line-break-type hard eq?
over section-end last-newline get - margin get 2/ > or
[ <fresh-line ] [ drop ] if ;
@@ -284,7 +286,7 @@ M: colon unindent-first-line? drop t ;
! Long section layout algorithm
: chop-break ( seq -- seq )
- dup peek break? [ 1 head-slice* chop-break ] when ;
+ dup peek line-break? [ 1 head-slice* chop-break ] when ;
SYMBOL: prev
SYMBOL: next
@@ -322,7 +324,7 @@ M: block long-section ( block -- )
[
block-sections chop-break group-flow [
dup ?break-group [
- dup break? [
+ dup line-break? [
do-break
] [
dup advance pprint-section