Merge git://factorcode.org/git/factor

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

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

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 ;

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 )

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 ;

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

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

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

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

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

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
 

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

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? [

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 ;

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

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

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 ;

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

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

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 ;

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

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