Changing list code to use generic sequence words

TODO.FACTOR.txt

@@ -75,10 +75,9 @@ should fix in 0.82:
 
 + misc:
 
+- make-image then compiler-tests sometimes reveals weird ghost words
 - 3 >n fep
 - code walker & exceptions
 - slice: if sequence or seq start is changed, abstraction violation
 - make 3.4 bits>double an error
-- colorcoded prettyprinting for vocabularies
-- signal handler should not lose stack pointers
 - code walker and callbacks is broken?

library/collections/sequences-epilogue.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: sequences
-USING: errors generic kernel kernel-internals math
+USING: arrays errors generic kernel kernel-internals math
 sequences-internals strings vectors words ;
 
 : first2 ( { x y } -- x y )
@@ -82,6 +82,11 @@ M: object like drop ;
 : add ( seq elt -- seq )
     swap [ push ] immutable ; flushable
 
+: add* ( seq elt -- seq )
+    over >r
+    over thaw [ push ] keep [ swap nappend ] keep
+    r> like ; flushable
+
 : diff ( seq1 seq2 -- seq2-seq1 )
     [ swap member? not ] subset-with ; flushable
 

library/compiler/alien/alien-callback.factor

@@ -52,7 +52,7 @@ M: alien-callback-error summary ( error -- )
 : generate-callback ( node -- )
     [ alien-callback-xt ] keep [
         dup alien-callback-parameters registers>objects
-        dup alien-callback-quot \ init-error-handler swons
+        dup alien-callback-quot \ init-error-handler add*
         %alien-callback
         unbox-return
         %return

library/compiler/alien/alien-invoke.factor

@@ -80,8 +80,9 @@ M: alien-invoke stack-reserve*
 
 : (define-c-word) ( type lib func types stack-effect -- )
     >r over create-in >r 
-    [ alien-invoke ] cons cons cons cons r> swap define-compound
+    [ alien-invoke ] curry curry curry curry
-    word r> "stack-effect" set-word-prop ;
+    r> swap define-compound word r>
+    "stack-effect" set-word-prop ;
 
 : define-c-word ( return library function parameters -- )
     [ "()" subseq? not ] subset >r pick r> parse-arglist

library/compiler/alien/c-types.factor

@@ -53,10 +53,10 @@ SYMBOL: c-types
 
 : define-deref ( name vocab -- )
     >r dup "*" swap append r> create
-    swap c-getter 0 swons define-compound ;
+    swap c-getter 0 add* define-compound ;
 
 : (define-nth) ( word type quot -- )
-    >r c-size [ rot * ] curry r> append define-compound ;
+    >r c-size [ rot * ] swap add* r> append define-compound ;
 
 : define-nth ( name vocab -- )
     >r dup "-nth" append r> create
@@ -67,8 +67,8 @@ SYMBOL: c-types
     swap dup c-setter (define-nth) ;
 
 : define-out ( name vocab -- )
-    over [ <c-object> tuck 0 ] over c-setter append
+    over [ <c-object> tuck 0 ] over c-setter append swap
-    >r >r constructor-word r> r> cons define-compound ;
+    >r >r constructor-word r> r> add* define-compound ;
 
 : init-c-type ( name vocab -- )
     over define-pointer define-nth ;

library/compiler/alien/structs.factor

@@ -10,12 +10,12 @@ sequences strings words ;
 : define-getter ( offset type name -- )
     #! Define a word with stack effect ( alien -- obj ) in the
     #! current 'in' vocabulary.
-    create-in >r c-getter cons r> swap define-compound ;
+    create-in >r c-getter swap add* r> swap define-compound ;
 
 : define-setter ( offset type name -- )
     #! Define a word with stack effect ( obj alien -- ) in the
     #! current 'in' vocabulary.
-    "set-" swap append create-in >r c-setter cons r>
+    "set-" swap append create-in >r c-setter swap add* r>
     swap define-compound ;
 
 : define-field ( offset type name -- offset )

library/generic/generic.factor

@@ -181,9 +181,8 @@ PREDICATE: word predicate "definition" word-prop ;
 
 ! Union classes for dispatch on multiple classes.
 : union-predicate ( members -- list )
-    [
+    [ dup ] swap [ "predicate" word-prop append ] map-with
-        "predicate" word-prop \ dup swons [ drop t ] 2array
+    [ [ drop t ] 2array ] map [ drop f ] swap alist>quot ;
-    ] map [ drop f ] swap alist>quot ;
 
 : set-members ( class members -- )
     [ bootstrap-word ] map "members" set-word-prop ;

library/generic/slots.factor

@@ -10,7 +10,7 @@ parser sequences strings words ;
 
 : define-slot-word ( class slot word quot -- )
     over [
-        >r swap >fixnum r> cons define-typecheck
+        rot >fixnum add* define-typecheck
     ] [
         2drop 2drop
     ] if ;
@@ -19,7 +19,7 @@ parser sequences strings words ;
     [ slot ] rot dup object eq? [
         drop
     ] [
-        1array [ declare ] curry append
+        1array [ declare ] swap add* append
     ] if define-slot-word ;
 
 : define-writer ( class slot writer -- )

library/generic/standard-combination.factor

@@ -32,34 +32,40 @@ math namespaces sequences vectors words ;
         swap [ first classes-intersect? ] subset-with
     ] map-with ;
 
-: simplify-alist ( class assoc -- default assoc )
+: (simplify-alist) ( class i assoc -- default assoc )
-    dup cdr [
+    2dup length 1- = [
-        2dup cdr car first class< [
+        nth second [ ] rot drop
-            cdr simplify-alist
-        ] [
-            uncons >r second nip r>
-        ] if
     ] [
-        nip car second [ ]
+        3dup >r 1+ r> nth first class< [
+            >r 1+ r> (simplify-alist)
+        ] [
+            [ nth second ] 2keep >r 1+ r> tail rot drop
+        ] if
     ] if ;
 
+: simplify-alist ( class assoc -- default assoc )
+    0 swap (simplify-alist) ;
+
+: methods* ( dispatch# word -- assoc )
+    #! Make a class->method association, together with a
+    #! default delegating method at the end.
+    empty-method object bootstrap-word swap 2array 1array
+    swap methods append ;
+
+: small-generic ( dispatch# word -- def )
+    2dup methods* object bootstrap-word swap simplify-alist
+    swapd class-predicates alist>quot ;
+
 : vtable-methods ( dispatch# alist-seq -- alist-seq )
     dup length [
         type>class
-        [ swap simplify-alist ] [ car second [ ] ] if*
+        [ swap simplify-alist ] [ first second [ ] ] if*
         >r over r> class-predicates alist>quot
     ] 2map nip ;
 
 : <vtable> ( dispatch# word n -- vtable )
     #! n is vtable size; either num-types or num-tags.
-    >r 2dup empty-method \ object bootstrap-word swap 2array
+    >r 2dup methods* r> sort-methods vtable-methods ;
-    >r methods >list r> swons r> sort-methods vtable-methods ;
-
-: small-generic ( dispatch# word -- def )
-    2dup empty-method object bootstrap-word swap 2array
-    swap methods >list cons
-    object bootstrap-word swap simplify-alist
-    swapd class-predicates alist>quot ;
 
 : big-generic ( dispatch# word n dispatcher -- def )
     [ >r pick picker % r> , <vtable> , \ dispatch , ] [ ] make ;

library/generic/tuple.factor

@@ -33,7 +33,7 @@ IN: generic
     define-predicate ;
 
 : forget-tuple ( class -- )
-    dup forget "predicate" word-prop car [ forget ] when* ;
+    dup forget "predicate" word-prop first [ forget ] when* ;
 
 : check-shape ( word slots -- )
     >r in get lookup dup [

library/syntax/prettyprint.factor

@@ -24,7 +24,6 @@ SYMBOL: string-limit
 global [
     4 tab-size set
     64 margin set
-    recursion-check off
     0 position set
     0 indent set
     0 last-newline set
@@ -230,9 +229,9 @@ M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
         over recursion-check get memq? [
             2drop "&" plain-text
         ] [
-            over recursion-check [ cons ] change
+            over recursion-check get push
             call
-            recursion-check [ cdr ] change
+            recursion-check get pop*
         ] if
     ] if ; inline
 
@@ -294,6 +293,7 @@ M: wrapper pprint* ( wrapper -- )
 
 : with-pprint ( quot -- )
     [
+        V{ } clone recursion-check set
         <block> f ?push pprinter-stack set
         call end-blocks do-pprint
     ] with-scope ; inline

library/threads.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2006 Slava Pestov.
 ! Copyright (C) 2005 Mackenzie Straight.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: threads
-USING: errors hashtables io-internals kernel lists math
+USING: arrays errors hashtables io-internals kernel math
 namespaces queues sequences vectors ;
 
 ! Co-operative multitasker.
@@ -14,16 +14,16 @@ namespaces queues sequences vectors ;
 : sleep-queue ( -- vec ) \ sleep-queue get-global ;
 
 : sleep-queue* ( -- vec )
-    sleep-queue dup [ 2car swap - ] nsort ;
+    sleep-queue dup [ [ first ] 2apply swap - ] nsort ;
 
 : sleep-time ( sorted-queue -- ms )
-    dup empty? [ drop -1 ] [ peek car millis - 0 max ] if ;
+    dup empty? [ drop -1 ] [ peek first millis - 0 max ] if ;
 
 DEFER: next-thread
 
 : do-sleep ( -- continuation )
     sleep-queue* dup sleep-time dup zero?
-    [ drop pop cdr ] [ nip io-multiplex next-thread ] if ;
+    [ drop pop second ] [ nip io-multiplex next-thread ] if ;
 
 : next-thread ( -- continuation )
     run-queue dup queue-empty? [ drop do-sleep ] [ deque ] if ;
@@ -33,7 +33,7 @@ DEFER: next-thread
 : yield ( -- ) [ schedule-thread stop ] callcc0 ;
 
 : sleep ( ms -- )
-    millis + [ cons sleep-queue push stop ] callcc0 drop ;
+    millis + [ 2array sleep-queue push stop ] callcc0 drop ;
 
 : in-thread ( quot -- )
     [

library/tools/annotations.factor

@@ -28,4 +28,4 @@ sequences strings walker ;
     ] annotate ;
 
 : profile ( word -- )
-    [ swap [ global [ inc ] bind call ] curry cons ] annotate ;
+    [ swap [ global [ inc ] bind ] curry swap append ] annotate ;