2each combinator, minor improvements to inspector and fep

library/bootstrap/image.factor

@@ -156,7 +156,7 @@ M: f ' ( obj -- ptr )
         dup word-primitive ,
         dup word-def ' ,
         dup word-props ' ,
-    ] make-list
+    ] make-vector
     swap object-tag here-as pool-object
     [ emit ] each ;
 

library/collections/sequences-epilogue.factor

@@ -23,23 +23,11 @@ M: object each ( seq quot -- )
         [ swap nth swap call ] 3keep
     ] repeat 2drop ;
 
-: change-nth ( seq i quot -- )
-    pick pick >r >r >r swap nth r> call r> r> swap set-nth ;
-    inline
-
-: (nmap) ( seq i quot -- )
-    pick length pick <= [
-        3drop
-    ] [
-        [ change-nth ] 3keep >r 1 + r> (nmap)
-    ] ifte ; inline
-
-: nmap ( seq quot -- | quot: elt -- elt )
-    #! Destructive on seq.
-    0 swap (nmap) ; inline
-
 : map ( seq quot -- seq | quot: elt -- elt )
-    swap [ swap nmap ] immutable ; inline
+    over [
+        length <vector> rot
+        [ -rot [ slip push ] 2keep ] each nip
+    ] keep like ; inline
 
 : map-with ( obj list quot -- list | quot: obj elt -- elt )
     swap [ with rot ] map 2nip ; inline
@@ -47,17 +35,23 @@ M: object each ( seq quot -- )
 : accumulate ( list identity quot -- values | quot: x y -- z )
     rot [ pick >r swap call r> ] map-with nip ; inline
 
-: (2nmap) ( seq1 seq2 i quot -- elt3 )
-    pick pick >r >r >r 2nth r> call r> r> swap set-nth ; inline
+: change-nth ( seq i quot -- )
+    pick pick >r >r >r swap nth r> call r> r> swap set-nth ;
+    inline
 
-: 2nmap ( seq1 seq2 quot -- | quot: elt1 elt2 -- elt3 )
-    #! Destructive on seq2.
-    over length [
-        [ >r 3dup r> swap (2nmap) ] keep
-    ] repeat 3drop ; inline
+: nmap ( seq quot -- seq | quot: elt -- elt )
+    over length [ [ swap change-nth ] 3keep ] repeat 2drop ; inline
 
-M: object 2map ( seq1 seq2 quot -- seq | quot: elt1 elt2 -- elt3 )
-    swap [ swap 2nmap ] immutable ;
+: 2each ( seq seq quot -- | quot: elt -- )
+    over length >r >r cons r> r>
+    [ [ swap >r >r uncons r> 2nth r> call ] 3keep ] repeat
+    2drop ; inline
+
+: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
+    over [
+        length <vector> 2swap
+        [ 2swap [ slip push ] 2keep ] 2each nip
+    ] keep like ; inline
 
 M: object find* ( i seq quot -- i elt  )
     pick pick length >= [
@@ -158,7 +152,7 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
 
 : add ( seq elt -- seq )
     #! Outputs a new sequence of the same type as seq.
-    unit append ;
+    swap [ push ] immutable ;
 
 : append3 ( s1 s2 s3 -- s1+s2+s3 )
     #! Return a new sequence of the same type as s1.
@@ -190,6 +184,12 @@ M: object peek ( sequence -- element )
 
 : >pop> ( stack -- stack ) dup pop drop ;
 
+: join ( seq glue -- seq )
+    #! The new sequence is of the same type as glue.
+    swap dup length <vector> swap
+    [ over push 2dup push ] each nip >pop>
+    concat ;
+
 M: object reverse-slice ( seq -- seq ) <reversed> ;
 
 M: object reverse ( seq -- seq ) [ <reversed> ] keep like ;

library/collections/sequences.factor

@@ -38,9 +38,6 @@ G: each ( seq quot -- | quot: elt -- )
 : reduce ( seq identity quot -- value | quot: x y -- z )
     swapd each ; inline
 
-G: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
-    [ over ] [ type ] ; inline
-
 G: find ( seq quot -- i elt | quot: elt -- ? )
     [ over ] [ type ] ; inline
 

library/math/matrices.factor

@@ -36,10 +36,7 @@ vectors ;
 : set-axis ( x y axis -- v )
     2dup v* >r >r drop dup r> v* v- r> v+ ;
 
-! Later, this will fixed when 2each works properly
-! : v. ( v v -- x ) 0 swap [ conjugate * + ] 2each ;
-: v** ( v v -- v ) [ conjugate * ] 2map ;
-: v. ( v v -- x ) v** sum ;
+: v. ( v v -- x ) 0 -rot [ conjugate * + ] 2each ;
 
 : norm-sq ( v -- n ) 0 [ absq + ] reduce ;
 

library/test/inspector.factor

@@ -5,7 +5,3 @@ USING: test inspector prettyprint math ;
 [ 1 2 3 ] inspect
 f inspect
 \ + inspect
-
-[ "hello world how are you" ]
-[ [ "hello" "world" "how" "are" "you" ] " " join ]
-unit-test

library/test/sequences.factor

@@ -54,3 +54,7 @@ USING: kernel lists math sequences strings test vectors ;
 [ { 4 2 6 } ] [ { 1 4 2 5 3 6 } [ 2 mod 0 = ] subset ] unit-test
 
 [ [ 3 ] ] [ 2 [ 1 2 3 ] [ < ] subset-with ] unit-test
+
+[ "hello world how are you" ]
+[ { "hello" "world" "how" "are" "you" } " " join ]
+unit-test

library/tools/inspector.factor

@@ -29,18 +29,6 @@ M: hashtable sheet hash>alist unzip 2list ;
     [ [ length ] map 0 [ max ] reduce ] keep
     [ swap CHAR: \s pad-right ] map-with ;
 
-: (join) ( list glue -- )
-    over [
-        over car % >r cdr dup
-        [ r> dup % (join) ] [ r> 2drop ] ifte
-    ] [
-        2drop
-    ] ifte ;
-
-: join ( list glue -- seq )
-    #! The new sequence is of the same type as glue.
-    [ [ (join) ] make-vector ] keep like ;
-
 : describe ( obj -- list )
     sheet dup first length count swons
     dup peek over first zip [ uncons set ] each
@@ -48,17 +36,6 @@ M: hashtable sheet hash>alist unzip 2list ;
     seq-transpose
     [ " | " join ] map ;
 
-: class-banner ( word -- )
-    dup metaclass dup [
-        "This is a class whose behavior is specifed by the " write
-        unparse. " metaclass," print
-        "currently having " write
-        "predicate" word-prop instances length unparse write
-        " instances." print
-    ] [
-        2drop
-    ] ifte ;
-
 : vocab-banner ( word -- )
     dup word-vocabulary [
         dup interned? [
@@ -76,24 +53,20 @@ M: hashtable sheet hash>alist unzip 2list ;
 GENERIC: extra-banner ( obj -- )
 
 M: word extra-banner ( obj -- )
-    dup vocab-banner swap class-banner ;
+    dup vocab-banner
+    metaclass [
+        "This is a class whose behavior is specifed by the " write
+        unparse. " metaclass." print
+    ] when* ;
 
 M: object extra-banner ( obj -- ) drop ;
 
 : inspect-banner ( obj -- )
-    dup references length >r
     "You are looking at an instance of the " write dup class unparse.
     " class:" print
     "  " write dup unparse. terpri
-    "The object has been placed in the inspecting variable." print
-    "It is located at address " write dup address >hex write
-    " and takes up " write dup size unparse write
-    " bytes of memory." print
-    "This object is referenced from " write r> unparse write
-    " other objects in the heap." print
-    extra-banner
-    "The object's slots, if any, are stored in integer variables," print
-    "numbered starting from 0." print ;
+    "It takes up " write dup size unparse write " bytes of memory." print
+    extra-banner ;
 
 : inspect ( obj -- )
     dup inspecting set

native/debug.c

@@ -137,6 +137,8 @@ void print_string(F_STRING* str)
 
 void print_obj(CELL obj)
 {
+	F_ARRAY *array;
+
 	switch(type_of(obj))
 	{
 	case FIXNUM_TYPE:
@@ -154,6 +156,12 @@ void print_obj(CELL obj)
 	case F_TYPE:
 		fprintf(stderr,"f");
 		break;
+	case TUPLE_TYPE:
+		array = untag_array_fast(obj);
+		fprintf(stderr,"<< ");
+		print_word(untag_word(get(AREF(array,0))));
+		fprintf(stderr," ... >>\n");
+		break;
 	default:
 		fprintf(stderr,"#<type %ld @ %lx>",type_of(obj),obj);
 		break;
@@ -207,6 +215,8 @@ void dump_cell(CELL cell)
 
 void dump_memory(CELL from, CELL to)
 {
+	from = UNTAG(from);
+
 	for(; from <= to; from += CELLS)
 		dump_cell(from);
 }

native/run.h

@@ -19,11 +19,6 @@
 /* TAGGED user environment data; see getenv/setenv prims */
 DLLEXPORT CELL userenv[USER_ENV];
 
-/* Profiling timer */
-#ifndef WIN32
-struct itimerval prof_timer;
-#endif
-
 /* Error handlers restore this */
 #ifdef WIN32
 jmp_buf toplevel;