diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index e50e211561..10af2d9db9 100644 --- a/library/bootstrap/image.factor +++ b/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 ; diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index f2aa932e3d..68a075a6b7 100644 --- a/library/collections/sequences-epilogue.factor +++ b/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 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 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 swap + [ over push 2dup push ] each nip >pop> + concat ; + M: object reverse-slice ( seq -- seq ) ; M: object reverse ( seq -- seq ) [ ] keep like ; diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index eae919d0ea..ce7fc3c22c 100644 --- a/library/collections/sequences.factor +++ b/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 diff --git a/library/math/matrices.factor b/library/math/matrices.factor index d485bd35ef..775da30b31 100644 --- a/library/math/matrices.factor +++ b/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 ; diff --git a/library/test/inspector.factor b/library/test/inspector.factor index 8d32470c8f..ad245af241 100644 --- a/library/test/inspector.factor +++ b/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 diff --git a/library/test/sequences.factor b/library/test/sequences.factor index abbe3cd98b..5211229b1f 100644 --- a/library/test/sequences.factor +++ b/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 diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index 92af684656..d9a85a8411 100644 --- a/library/tools/inspector.factor +++ b/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 diff --git a/native/debug.c b/native/debug.c index 8da5eeb324..616764ff1b 100644 --- a/native/debug.c +++ b/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_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); } diff --git a/native/run.h b/native/run.h index c8041d5b37..e09986e11c 100644 --- a/native/run.h +++ b/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;