From cae545f93002400c0656daff94361cfb8ed27b45 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 24 Jul 2005 23:08:32 +0000 Subject: [PATCH 001/178] factorbot fix, starting 0.77 --- CHANGES.html | 3 +++ Makefile | 15 +++++++++--- examples/factorbot.factor | 13 ++++++---- library/bootstrap/boot-stage3.factor | 36 +++++++++++++++------------- version.factor | 2 +- 5 files changed, 43 insertions(+), 26 deletions(-) diff --git a/CHANGES.html b/CHANGES.html index ff7f199285..c4a21fd11d 100644 --- a/CHANGES.html +++ b/CHANGES.html @@ -119,3 +119,6 @@ write1 ( char -- ) + + + diff --git a/Makefile b/Makefile index 148077d847..0fa0af9fb9 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,16 @@ else STRIP = strip endif -DEFAULT_LIBS = -lm +ifdef STATIC + DEFAULT_LIBS = -lm -Wl,-static -Wl,-whole-archive \ + -Wl,-export-dynamic \ + -lSDL -lSDL_gfx -lSDL_ttf \ + -Wl,-no-whole-archive \ + -lfreetype -lz -L/usr/X11R6/lib -lX11 -lXext \ + -Wl,-Bdynamic +else + DEFAULT_LIBS = -lm +endif UNIX_OBJS = native/unix/file.o \ native/unix/signal.o \ @@ -76,13 +85,13 @@ macosx: linux: $(MAKE) f \ CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic" \ - LIBS="$(DEFAULT_LIBS) -ldl" + LIBS="-ldl $(DEFAULT_LIBS)" $(STRIP) f linux-ppc: $(MAKE) f \ CFLAGS="$(DEFAULT_CFLAGS) -export-dynamic -mregnames" \ - LIBS="$(DEFAULT_LIBS) -ldl" + LIBS="-ldl $(DEFAULT_LIBS)" $(STRIP) f windows: diff --git a/examples/factorbot.factor b/examples/factorbot.factor index b699c036f3..d3f0ad297f 100644 --- a/examples/factorbot.factor +++ b/examples/factorbot.factor @@ -30,15 +30,15 @@ SYMBOL: receiver "JOIN " irc-write irc-print ; GENERIC: handle-irc -PREDICATE: string privmsg "PRIVMSG" swap subseq? ; +PREDICATE: string privmsg " " split1 nip "PRIVMSG" head? ; +PREDICATE: string ping "PING" head? ; M: string handle-irc ( line -- ) drop ; : parse-privmsg ( line -- text ) - ":" ?head drop - "!" split1 swap speaker set - "PRIVMSG " split1 nip + " " split1 nip + "PRIVMSG " ?head drop " " split1 swap receiver set ":" ?head drop ; @@ -48,6 +48,9 @@ M: privmsg handle-irc ( line -- ) [ "factorbot-commands" ] search dup [ execute ] [ 2drop ] ifte ; +: parse-irc ( line -- ) + ":" ?head [ "!" split1 swap speaker set ] when handle-irc ; + : say ( line nick -- ) "PRIVMSG " irc-write irc-write " :" irc-write irc-print ; @@ -72,7 +75,7 @@ M: privmsg handle-irc ( line -- ) : irc-loop ( -- ) irc-stream get stream-readln - [ dup print flush handle-irc irc-loop ] when* ; + [ dup print flush parse-irc irc-loop ] when* ; : factorbot "irc.freenode.net" connect diff --git a/library/bootstrap/boot-stage3.factor b/library/bootstrap/boot-stage3.factor index ddf07d26c4..2a9e7dcb0c 100644 --- a/library/bootstrap/boot-stage3.factor +++ b/library/bootstrap/boot-stage3.factor @@ -6,23 +6,25 @@ parser sequences io unparser words ; "Compiling base..." print -unix? [ - "sdl" "libSDL.so" "cdecl" add-library - "sdl-gfx" "libSDL_gfx.so" "cdecl" add-library - "sdl-ttf" "libSDL_ttf.so" "cdecl" add-library -] when - -win32? [ - "kernel32" "kernel32.dll" "stdcall" add-library - "user32" "user32.dll" "stdcall" add-library - "gdi32" "gdi32.dll" "stdcall" add-library - "winsock" "ws2_32.dll" "stdcall" add-library - "mswsock" "mswsock.dll" "stdcall" add-library - "libc" "msvcrt.dll" "cdecl" add-library - "sdl" "SDL.dll" "cdecl" add-library - "sdl-gfx" "SDL_gfx.dll" "cdecl" add-library - "sdl-ttf" "SDL_ttf.dll" "cdecl" add-library -] when +"statically-linked" get [ + unix? [ + "sdl" "libSDL.so" "cdecl" add-library + "sdl-gfx" "libSDL_gfx.so" "cdecl" add-library + "sdl-ttf" "libSDL_ttf.so" "cdecl" add-library + ] when + + win32? [ + "kernel32" "kernel32.dll" "stdcall" add-library + "user32" "user32.dll" "stdcall" add-library + "gdi32" "gdi32.dll" "stdcall" add-library + "winsock" "ws2_32.dll" "stdcall" add-library + "mswsock" "mswsock.dll" "stdcall" add-library + "libc" "msvcrt.dll" "cdecl" add-library + "sdl" "SDL.dll" "cdecl" add-library + "sdl-gfx" "SDL_gfx.dll" "cdecl" add-library + "sdl-ttf" "SDL_ttf.dll" "cdecl" add-library + ] when +] unless default-cli-args parse-command-line diff --git a/version.factor b/version.factor index e0a6ea9f9b..d66bf72f8a 100644 --- a/version.factor +++ b/version.factor @@ -1,2 +1,2 @@ IN: kernel -: version "0.76" ; +: version "0.77" ; From 678e18859bbc4115462a421d4c77d005368273d8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jul 2005 00:17:51 +0000 Subject: [PATCH 002/178] fix multi-shot callcc1 problem --- examples/factorbot.factor | 6 +++--- library/continuations.factor | 20 ++++++++++---------- library/math/matrices.factor | 2 +- library/test/continuations.factor | 5 +++++ library/tools/interpreter.factor | 4 ++-- 5 files changed, 21 insertions(+), 16 deletions(-) diff --git a/examples/factorbot.factor b/examples/factorbot.factor index d3f0ad297f..f159747cf1 100644 --- a/examples/factorbot.factor +++ b/examples/factorbot.factor @@ -1,8 +1,8 @@ ! Simple IRC bot written in Factor. IN: factorbot -USING: hashtables http io kernel math namespaces prettyprint -sequences strings words ; +USING: generic hashtables http io kernel math namespaces +prettyprint sequences strings words ; SYMBOL: irc-stream SYMBOL: nickname @@ -33,7 +33,7 @@ GENERIC: handle-irc PREDICATE: string privmsg " " split1 nip "PRIVMSG" head? ; PREDICATE: string ping "PING" head? ; -M: string handle-irc ( line -- ) +M: object handle-irc ( line -- ) drop ; : parse-privmsg ( line -- text ) diff --git a/library/continuations.factor b/library/continuations.factor index 0d83b28b06..558906f1ec 100644 --- a/library/continuations.factor +++ b/library/continuations.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. -IN: kernel USING: errors lists namespaces sequences ; +IN: kernel USING: errors lists namespaces sequences words ; TUPLE: interp data call name catch ; @@ -8,24 +8,24 @@ TUPLE: interp data call name catch ; datastack callstack >pop> >pop> namestack catchstack ; +: continuation ( interp -- ) + interp dup interp-call >pop> >pop> drop + dup interp-data >pop> drop ; + : >interp< ( interp -- data call name catch ) [ interp-data ] keep [ interp-call ] keep [ interp-name ] keep interp-catch ; -: set-interp ( interp -- ) - >interp< set-catchstack set-namestack - >r set-datastack r> set-callstack ; - -: continuation ( interp -- ) - interp dup interp-call >pop> >pop> drop - dup interp-data >pop> drop ; +: set-interp ( interp quot -- ) + >r >interp< set-catchstack set-namestack + >r set-datastack r> r> swap set-callstack call ; : callcc0 ( quot ++ | quot: cont -- | cont: ++ ) continuation - [ set-interp ] cons swap call ; + [ [ ] set-interp ] cons swap call ; : callcc1 ( quot ++ obj | quot: cont -- | cont: obj ++ obj ) continuation - [ [ interp-data push ] keep set-interp ] cons swap call ; + [ swap literalize set-interp ] cons swap call ; diff --git a/library/math/matrices.factor b/library/math/matrices.factor index ea2856761f..d485bd35ef 100644 --- a/library/math/matrices.factor +++ b/library/math/matrices.factor @@ -29,7 +29,7 @@ vectors ; >r over >r v>= r> r> v<= vand ; : sum ( v -- n ) 0 [ + ] reduce ; -: product 1 [ * ] reduce ; +: product ( v -- n ) 1 [ * ] reduce ; : conj ( v -- ? ) [ ] all? ; : disj ( v -- ? ) [ ] contains? ; diff --git a/library/test/continuations.factor b/library/test/continuations.factor index 755489f841..3bcf782fec 100644 --- a/library/test/continuations.factor +++ b/library/test/continuations.factor @@ -27,3 +27,8 @@ USE: test [ t ] [ 10 callcc1-test 10 count = ] unit-test [ t ] [ callcc-namespace-test ] unit-test + +: multishot-test ( -- stack ) + [ dup "cc" set 5 swap call ] callcc1 "cc" get car interp-data ; + +[ 5 { } ] [ multishot-test ] unit-test diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index 167a74da4c..366442a6ea 100644 --- a/library/tools/interpreter.factor +++ b/library/tools/interpreter.factor @@ -56,8 +56,8 @@ SYMBOL: meta-executing [ \ call push-r interp [ interp over interp-data push - set-interp - ] cons cons push-r meta-interp set-interp + [ ] set-interp + ] cons cons push-r meta-interp [ ] set-interp ] call set-meta-interp pop-d 2drop ; : meta-call ( quot -- ) From b547a0c2248246e8ceb09be27b0b1da518050dce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jul 2005 02:44:33 +0000 Subject: [PATCH 003/178] 2each combinator, minor improvements to inspector and fep --- library/bootstrap/image.factor | 2 +- library/collections/sequences-epilogue.factor | 52 +++++++++---------- library/collections/sequences.factor | 3 -- library/math/matrices.factor | 5 +- library/test/inspector.factor | 4 -- library/test/sequences.factor | 4 ++ library/tools/inspector.factor | 41 +++------------ native/debug.c | 10 ++++ native/run.h | 5 -- 9 files changed, 49 insertions(+), 77 deletions(-) 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; From b0ecd948ce656af67161ccc45e4638d002b9fd42 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jul 2005 02:59:23 +0000 Subject: [PATCH 004/178] using 2each in some places instead of zip [ uncons ... ] each --- library/tools/inspector.factor | 2 +- library/tools/memory.factor | 7 +++---- library/ui/layouts.factor | 20 ++++++++++---------- 3 files changed, 14 insertions(+), 15 deletions(-) diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index d9a85a8411..47dfa1ed40 100644 --- a/library/tools/inspector.factor +++ b/library/tools/inspector.factor @@ -31,7 +31,7 @@ M: hashtable sheet hash>alist unzip 2list ; : describe ( obj -- list ) sheet dup first length count swons - dup peek over first zip [ uncons set ] each + dup peek over first [ set ] 2each [ column ] map seq-transpose [ " | " join ] map ; diff --git a/library/tools/memory.factor b/library/tools/memory.factor index 9d6076c08c..f803cf39f0 100644 --- a/library/tools/memory.factor +++ b/library/tools/memory.factor @@ -87,11 +87,10 @@ M: object (each-slot) ( quot obj -- ) [ dup size swap type rot seq+ ] keep 1 swap type rot seq+ ; -: heap-stats ( -- stats ) +: heap-stats ( -- counts sizes ) #! Return a list of instance count/total size pairs. num-types zero-vector num-types zero-vector - [ >r 2dup r> heap-stat-step ] each-object - swap >list swap >list zip ; + [ >r 2dup r> heap-stat-step ] each-object ; : heap-stat. ( type instances bytes -- ) dup 0 = [ @@ -104,7 +103,7 @@ M: object (each-slot) ( quot obj -- ) : heap-stats. ( -- ) #! Print heap allocation breakdown. - 0 heap-stats [ dupd uncons heap-stat. 1 + ] each drop ; + 0 heap-stats [ >r >r dup r> r> heap-stat. 1 + ] 2each drop ; : orphans ( word -- list ) #! Orphans are forgotten but still referenced. diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index f6440210c5..6b68458c5e 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -20,7 +20,7 @@ namespaces sdl sequences ; TUPLE: pack align fill vector ; : pref-dims ( gadget -- list ) - gadget-children [ pref-dim ] map >list ; + gadget-children [ pref-dim ] map ; : orient ( gadget list1 list2 -- list ) zip >r pack-vector r> [ uncons rot set-axis ] map-with ; @@ -31,28 +31,28 @@ TUPLE: pack align fill vector ; rot pack-fill v*n v+ ] map-with ; -: (packed-dims) ( gadget sizes -- list ) +: (packed-dims) ( gadget sizes -- seq ) 2dup packed-dim-2 swap orient ; -: packed-dims ( gadget sizes -- list ) - over gadget-children >list >r (packed-dims) r> - zip [ uncons set-gadget-dim ] each ; +: packed-dims ( gadget sizes -- seq ) + over gadget-children >r (packed-dims) r> + [ set-gadget-dim ] 2each ; -: packed-loc-1 ( sizes -- list ) +: packed-loc-1 ( sizes -- seq ) { 0 0 0 } [ v+ ] accumulate ; -: packed-loc-2 ( gadget sizes -- list ) +: packed-loc-2 ( gadget sizes -- seq ) >r dup rectangle-dim { 1 1 1 } vmax over r> packed-dim-2 [ v- ] map-with >r dup pack-align swap rectangle-dim { 1 1 1 } vmax r> [ >r 2dup r> v- n*v ] map 2nip ; -: (packed-locs) ( gadget sizes -- list ) +: (packed-locs) ( gadget sizes -- seq ) dup packed-loc-1 >r dupd packed-loc-2 r> orient ; : packed-locs ( gadget sizes -- ) - over gadget-children >list >r (packed-locs) r> - zip [ uncons set-rectangle-loc ] each ; + over gadget-children >r (packed-locs) r> + [ set-rectangle-loc ] 2each ; : packed-layout ( gadget sizes -- ) 2dup packed-locs packed-dims ; From a7e713764f92e14c493bd8ac4c819924ff9e0ae9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jul 2005 03:09:43 +0000 Subject: [PATCH 005/178] improved inspector with slot links --- library/tools/inspector.factor | 22 +++++++++++++--------- library/ui/layouts.factor | 4 ++-- 2 files changed, 15 insertions(+), 11 deletions(-) diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index 47dfa1ed40..300feb3edf 100644 --- a/library/tools/inspector.factor +++ b/library/tools/inspector.factor @@ -2,8 +2,8 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: inspector USING: generic hashtables io kernel kernel-internals lists math -memory namespaces prettyprint sequences strings test unparser -vectors words ; +memory namespaces prettyprint sequences strings styles test +unparser vectors words ; SYMBOL: inspecting @@ -16,11 +16,11 @@ M: object sheet ( obj -- sheet ) PREDICATE: list nonvoid cons? ; -M: nonvoid sheet >list unit ; +M: nonvoid sheet unit ; -M: vector sheet >list unit ; +M: vector sheet unit ; -M: array sheet >list unit ; +M: array sheet unit ; M: hashtable sheet hash>alist unzip 2list ; @@ -29,8 +29,8 @@ M: hashtable sheet hash>alist unzip 2list ; [ [ length ] map 0 [ max ] reduce ] keep [ swap CHAR: \s pad-right ] map-with ; -: describe ( obj -- list ) - sheet dup first length count swons +: format-sheet ( sheet -- list ) + dup first length count swons dup peek over first [ set ] 2each [ column ] map seq-transpose @@ -68,6 +68,10 @@ M: object extra-banner ( obj -- ) drop ; "It takes up " write dup size unparse write " bytes of memory." print extra-banner ; +: describe ( obj -- ) + sheet dup format-sheet + swap peek [ presented swons unit ] map + [ format terpri ] 2each ; + : inspect ( obj -- ) - dup inspecting set - dup inspect-banner describe [ print ] each ; + dup inspecting set dup inspect-banner describe ; diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor index 6b68458c5e..f1cbf27f3f 100644 --- a/library/ui/layouts.factor +++ b/library/ui/layouts.factor @@ -22,8 +22,8 @@ TUPLE: pack align fill vector ; : pref-dims ( gadget -- list ) gadget-children [ pref-dim ] map ; -: orient ( gadget list1 list2 -- list ) - zip >r pack-vector r> [ uncons rot set-axis ] map-with ; +: orient ( gadget seq1 seq2 -- seq ) + >r >r pack-vector r> r> [ pick set-axis ] 2map nip ; : packed-dim-2 ( gadget sizes -- list ) [ From 9c5360cdbac88dabadfb1aeca527be7815b66a79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jul 2005 03:12:34 +0000 Subject: [PATCH 006/178] document 0.77 changes, print tuple addr in debugger --- CHANGES.html | 22 +++++++++++++++++++++- native/debug.c | 2 +- 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/CHANGES.html b/CHANGES.html index c4a21fd11d..f6c4a319f9 100644 --- a/CHANGES.html +++ b/CHANGES.html @@ -1,9 +1,29 @@ + + Factor change log +

Factor 0.77:

+ +
    +
  • Sequences: + +
      +
    • 2each ( seq seq quot -- quot: elt -- elt ) combinator
      • +
    • join ( seq glue -- seq ) combinator. Takes a sequence of sequences, and constructs a new sequence with the glue in between each sequence. For example: +
        [ "usr" "bin" "grep" ] "/" join
+"usr/bin/grep"
      • +
    + +
    • +
+ +
    Everything else: +
  • Object slots are now clickable in the inspector
    • +
+

Factor 0.76:

-
  • diff --git a/native/debug.c b/native/debug.c index 616764ff1b..64876de366 100644 --- a/native/debug.c +++ b/native/debug.c @@ -160,7 +160,7 @@ void print_obj(CELL obj) array = untag_array_fast(obj); fprintf(stderr,"<< "); print_word(untag_word(get(AREF(array,0)))); - fprintf(stderr," ... >>\n"); + fprintf(stderr," %ld >>\n",obj); break; default: fprintf(stderr,"#",type_of(obj),obj); From 257c21f9de6db584a895f4dfc4c576bbcf8c5c01 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jul 2005 03:35:34 +0000 Subject: [PATCH 007/178] editor bug fix --- TODO.FACTOR.txt | 1 - library/ui/editors.factor | 3 ++- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 0f483351c9..d3636a2076 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -76,7 +76,6 @@ + sequences -- dipping 2nmap, 2each - array sort - nappend: instead of using push, enlarge the sequence with set-length then add set the elements with set-nth diff --git a/library/ui/editors.factor b/library/ui/editors.factor index f1a6e5bd4d..d30c9cf356 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -33,7 +33,8 @@ TUPLE: editor line caret ; dup 0 [ + ] accumulate swap 2 v/n v+ ; : x>offset ( x font str -- offset ) - run-char-widths [ <= ] find-with drop ; + dup >r run-char-widths [ <= ] find-with drop dup -1 = + [ drop r> length ] [ r> drop ] ifte ; : set-caret-x ( x editor -- ) #! Move the caret to a clicked location. From 1d7b5483864c50288edf3e4a8fb31f721f8860bc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jul 2005 03:58:29 +0000 Subject: [PATCH 008/178] inspector shows delegate slots --- library/tools/inspector.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index 300feb3edf..2b584e96c7 100644 --- a/library/tools/inspector.factor +++ b/library/tools/inspector.factor @@ -9,10 +9,17 @@ SYMBOL: inspecting GENERIC: sheet ( obj -- sheet ) -M: object sheet ( obj -- sheet ) +: object-sheet ( obj -- names values ) dup class "slots" word-prop [ second ] map - tuck [ execute ] map-with 2list ; + tuck [ execute ] map-with ; + +M: object sheet object-sheet 2list ; + +M: tuple sheet + dup object-sheet + >r >r \ delegate swap delegate r> r> + 2cons 2list ; PREDICATE: list nonvoid cons? ; From ec0bbe7e2d897c86a99ac038d67acd4596504b9d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jul 2005 05:04:33 +0000 Subject: [PATCH 009/178] fix problem in optimizer --- library/compiler/optimizer.factor | 14 ++++++++------ library/test/compiler/optimizer.factor | 10 +++++++--- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/library/compiler/optimizer.factor b/library/compiler/optimizer.factor index 682300ae26..8dc963bfe1 100644 --- a/library/compiler/optimizer.factor +++ b/library/compiler/optimizer.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: compiler-frontend -USING: hashtables inference kernel lists namespaces sequences ; +USING: generic hashtables inference kernel lists matrices +namespaces sequences ; ! The optimizer transforms dataflow IR to dataflow IR. Currently ! it removes literals that are eventually dropped, and never @@ -125,7 +126,7 @@ M: #drop useless-node? ( node -- ? ) ! #call M: #call can-kill* ( literal node -- ? ) - nip node-param {{ + dup node-param {{ [[ dup t ]] [[ drop t ]] [[ swap t ]] @@ -133,9 +134,10 @@ M: #call can-kill* ( literal node -- ? ) [[ pick t ]] [[ >r t ]] [[ r> t ]] - }} hash ; + }} hash >r delegate can-kill* r> or ; -: kill-mask ( killing inputs -- mask ) +: kill-mask ( killing node -- mask ) + dup node-param \ r> = [ node-in-r ] [ node-in-d ] ifte [ swap memq? ] map-with ; : (kill-shuffle) ( word -- map ) @@ -159,13 +161,13 @@ M: #call can-kill* ( literal node -- ? ) }} hash ; : lookup-mask ( mask word -- word ) - over [ not ] all? [ nip ] [ (kill-shuffle) hash ] ifte ; + over disj [ (kill-shuffle) hash ] [ nip ] ifte ; : kill-shuffle ( literals node -- ) #! If certain values passing through a stack op are being #! killed, the stack op can be reduced, in extreme cases #! to a no-op. - [ [ node-in-d kill-mask ] keep node-param lookup-mask ] keep + [ [ kill-mask ] keep node-param lookup-mask ] keep set-node-param ; M: #call kill-node* ( literals node -- ) diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index de0fe83399..90fce73b48 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -21,9 +21,9 @@ USE: sequences [ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test -[ [ t t f ] ] [ [ 1 2 3 ] [ - f ] map - [ [ literal-value 2 <= ] subset ] keep kill-mask +[ [ t t f ] ] [ + [ 1 2 3 ] [ f ] map + [ [ literal-value 2 <= ] subset ] keep in-d-node <#drop> kill-mask ] unit-test [ t ] [ @@ -69,3 +69,7 @@ USE: sequences [ [ 5 [ dup ] [ dup ] ] ] [ \ literal-kill-test-6 word-def kill-set* ] unit-test +: literal-kill-test-7 + [ 1 2 3 ] >r + r> drop ; compiled + +[ 4 ] [ 2 2 literal-kill-test-7 ] unit-test From a9fcfe8343d93cb8145f2cabc4c89ca1287e35a9 Mon Sep 17 00:00:00 2001 From: Alex Chapman Date: Mon, 25 Jul 2005 12:14:59 +0000 Subject: [PATCH 010/178] small gl type bugfix --- contrib/gl/gl.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/contrib/gl/gl.factor b/contrib/gl/gl.factor index 31dc28ab56..a1f1b047ff 100644 --- a/contrib/gl/gl.factor +++ b/contrib/gl/gl.factor @@ -701,10 +701,10 @@ FUNCTION: void glViewport ( GLint x, GLint y, GLsizei width, GLsizei height ) ; FUNCTION: void glPushMatrix ( ) ; FUNCTION: void glPopMatrix ( ) ; FUNCTION: void glLoadIdentity ( ) ; -FUNCTION: void glLoadMatrixd ( GLdouble *m ) ; -FUNCTION: void glLoadMatrixf ( GLfloat *m ) ; -FUNCTION: void glMultMatrixd ( GLdouble *m ) ; -FUNCTION: void glMultMatrixf ( GLfloat *m ) ; +FUNCTION: void glLoadMatrixd ( GLdouble* m ) ; +FUNCTION: void glLoadMatrixf ( GLfloat* m ) ; +FUNCTION: void glMultMatrixd ( GLdouble* m ) ; +FUNCTION: void glMultMatrixf ( GLfloat* m ) ; FUNCTION: void glRotated ( GLdouble angle, GLdouble x, GLdouble y, GLdouble z ) ; FUNCTION: void glRotatef ( GLfloat angle, GLfloat x, GLfloat y, GLfloat z ) ; FUNCTION: void glScaled ( GLdouble x, GLdouble y, GLdouble z ) ; @@ -892,10 +892,10 @@ FUNCTION: void glRectf ( GLfloat x1, GLfloat y1, GLfloat x2, GLfloat y2 ) ; FUNCTION: void glRecti ( GLint x1, GLint y1, GLint x2, GLint y2 ) ; FUNCTION: void glRects ( GLshort x1, GLshort y1, GLshort x2, GLshort y2 ) ; -FUNCTION: void glRectdv ( GLdouble *v1, GLdouble *v2 ) ; -FUNCTION: void glRectfv ( GLfloat *v1, GLfloat *v2 ) ; -FUNCTION: void glRectiv ( GLint *v1, GLint *v2 ) ; -FUNCTION: void glRectsv ( GLshort *v1, GLshort *v2 ) ; +FUNCTION: void glRectdv ( GLdouble* v1, GLdouble* v2 ) ; +FUNCTION: void glRectfv ( GLfloat* v1, GLfloat* v2 ) ; +FUNCTION: void glRectiv ( GLint* v1, GLint* v2 ) ; +FUNCTION: void glRectsv ( GLshort* v1, GLshort* v2 ) ; ! Vertex Arrays (1.1) From 7b470868c1bbb93d6bc2efe55d50cd7bd6ca5736 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 Jul 2005 21:13:35 +0000 Subject: [PATCH 011/178] integers support sequence protocol, remove count, project, project-with, remove zip, clean up a lot of code --- library/collections/cons.factor | 5 - library/collections/lists.factor | 25 +---- library/collections/sequences-epilogue.factor | 5 + library/generic/builtin.factor | 3 +- library/generic/complement.factor | 2 +- library/generic/object.factor | 2 +- library/generic/slots.factor | 16 +--- library/generic/tuple.factor | 12 +-- library/help/tutorial.factor | 2 +- library/inference/branches.factor | 2 +- library/io/binary.factor | 2 +- library/math/integer.factor | 6 +- library/math/matrices.factor | 2 +- library/syntax/math.factor | 4 +- library/syntax/prettyprint.factor | 10 +- library/test/continuations.factor | 2 +- library/test/hashtables.factor | 2 +- library/test/lists/lists.factor | 4 +- library/test/lists/queues.factor | 4 +- library/test/math/matrices.factor | 94 +++++++++---------- library/test/memory.factor | 4 + library/test/vectors.factor | 6 +- library/tools/inspector.factor | 14 +-- library/tools/memory.factor | 20 +--- 24 files changed, 104 insertions(+), 144 deletions(-) diff --git a/library/collections/cons.factor b/library/collections/cons.factor index 03bbf6dd11..0b68ca0f3a 100644 --- a/library/collections/cons.factor +++ b/library/collections/cons.factor @@ -43,11 +43,6 @@ PREDICATE: general-list list ( list -- ? ) : 2cons ( ca1 ca2 cd1 cd2 -- c1 c2 ) rot swons >r cons r> ; : 2uncons ( c1 c2 -- ca1 ca2 cd1 cd2 ) [ 2car ] 2keep 2cdr ; -: zip ( list list -- list ) - #! Make a new list containing pairs of corresponding - #! elements from the two given lists. - 2dup and [ 2uncons zip >r cons r> cons ] [ 2drop [ ] ] ifte ; - : unzip ( assoc -- keys values ) #! Split an association list into two lists of keys and #! values. diff --git a/library/collections/lists.factor b/library/collections/lists.factor index 610e9cfaa0..da37c5bff0 100644 --- a/library/collections/lists.factor +++ b/library/collections/lists.factor @@ -13,12 +13,10 @@ M: cons peek ( list -- last ) #! Last element of a list. last car ; -: (each) ( list quot -- list quot ) - [ >r car r> call ] 2keep >r cdr r> ; inline - M: f each ( list quot -- ) 2drop ; -M: cons each ( list quot -- | quot: elt -- ) (each) each ; +M: cons each ( list quot -- | quot: elt -- ) + [ >r car r> call ] 2keep >r cdr r> each ; : (list-find) ( list quot i -- i elt ) pick [ @@ -76,25 +74,6 @@ M: general-list reverse-slice ( list -- list ) M: general-list reverse reverse-slice ; -IN: sequences -DEFER: - -IN: lists - -: count ( n -- [ 0 ... n-1 ] ) - 0 swap >list ; - -: project ( n quot -- list ) - >r count r> map ; inline - -: project-with ( elt n quot -- list ) - swap [ with rot ] project 2nip ; inline - -: seq-transpose ( seq -- list ) - #! An example illustrates this word best: - #! [ [ 1 2 3 ] [ 4 5 6 ] ] ==> [ [ 1 2 ] [ 3 4 ] [ 5 6 ] ] - dup first length [ swap [ nth ] map-with ] project-with ; - M: general-list head ( n list -- list ) #! Return the first n elements of the list. over 0 > [ diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 68a075a6b7..82a5f8da72 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -234,6 +234,11 @@ M: object reverse ( seq -- seq ) [ ] keep like ; #! lexicographically. lexi 0 > ; +: seq-transpose ( seq -- list ) + #! An example illustrates this word best: + #! { { 1 2 3 } { 4 5 6 } } ==> { { 1 2 } { 3 4 } { 5 6 } } + dup first length [ swap [ nth ] map-with ] map-with ; + IN: kernel : depth ( -- n ) diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index 6bfd170a7a..b289fce50a 100644 --- a/library/generic/builtin.factor +++ b/library/generic/builtin.factor @@ -43,7 +43,8 @@ builtin [ 2drop t ] "class<" set-word-prop dup builtin define-class dup r> unit "predicate" set-word-prop dup builtin-predicate - dup r> define-slots + dup r> intern-slots 2dup "slots" set-word-prop + define-slots register-builtin ; : builtin-type ( n -- symbol ) builtins get nth ; diff --git a/library/generic/complement.factor b/library/generic/complement.factor index ca9152fa03..38aa439ddd 100644 --- a/library/generic/complement.factor +++ b/library/generic/complement.factor @@ -10,7 +10,7 @@ SYMBOL: complement complement [ "complement" word-prop builtin-supertypes - num-types count + num-types >list seq-diff ] "builtin-supertypes" set-word-prop diff --git a/library/generic/object.factor b/library/generic/object.factor index 0c91559d1f..e53c21513d 100644 --- a/library/generic/object.factor +++ b/library/generic/object.factor @@ -7,7 +7,7 @@ USING: kernel lists math sequences vectors words ; SYMBOL: object object [ - drop num-types count + drop num-types >list ] "builtin-supertypes" set-word-prop object [ diff --git a/library/generic/slots.factor b/library/generic/slots.factor index d5c5aea5ae..e960d0b60d 100644 --- a/library/generic/slots.factor +++ b/library/generic/slots.factor @@ -41,8 +41,6 @@ sequences strings words ; #! given class. The spec is a list of lists of length 3 of #! the form [ slot reader writer ]. slot is an integer, #! reader and writer are either words, strings or f. - intern-slots - 2dup "slots" set-word-prop [ 3unlist define-slot ] each-with ; : reader-word ( class name -- word ) @@ -51,17 +49,13 @@ sequences strings words ; : writer-word ( class name -- word ) [ swap "set-" % word-name % "-" % % ] make-string create-in ; -: simple-slot ( class name -- [ reader writer ] ) - [ reader-word ] 2keep writer-word 2list ; +: simple-slot ( class name -- reader writer ) + [ reader-word ] 2keep writer-word ; -: simple-slot-spec ( class slots -- spec ) - [ simple-slot ] map-with ; - -: simple-slots ( base class slots -- ) +: simple-slots ( class slots base -- spec ) #! Takes a list of slot names, and for each slot name #! defines a pair of words - and #! set--. Slot numbering is consecutive and #! begins at base. - >r tuck r> - simple-slot-spec [ length [ + ] project-with ] keep zip - define-slots ; + over length [ + ] map-with + [ >r dupd simple-slot r> -rot 3list ] 2map nip ; diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 011f8a639d..f938cb4a53 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -28,9 +28,6 @@ BUILTIN: tuple 18 tuple? ; M: tuple delegate 3 slot ; M: tuple set-delegate 3 set-slot ; -#! arrayed objects can be passed to array-nth, and set-array-nth -UNION: arrayed array tuple ; - : class ( obj -- class ) #! The class of an object. dup tuple? [ class-tuple ] [ type builtin-type ] ifte ; @@ -76,7 +73,10 @@ UNION: arrayed array tuple ; : tuple-slots ( tuple slots -- ) 2dup "slot-names" set-word-prop 2dup length 2 + "tuple-size" set-word-prop - 4 -rot simple-slots ; + dupd 4 simple-slots + 2dup { [ 3 delegate set-delegate ] } swap append + "slots" set-word-prop + define-slots ; : define-constructor ( word def -- ) >r [ word-name "in" get constructor-word ] keep [ @@ -85,8 +85,8 @@ UNION: arrayed array tuple ; : default-constructor ( tuple -- ) dup [ - "slots" word-prop - reverse [ peek unit , \ keep , ] each + "slots" word-prop 1 swap tail-slice reverse-slice + [ peek unit , \ keep , ] each ] make-list define-constructor ; : define-tuple ( tuple slots -- ) diff --git a/library/help/tutorial.factor b/library/help/tutorial.factor index 2c9ab2b006..960a170d64 100644 --- a/library/help/tutorial.factor +++ b/library/help/tutorial.factor @@ -275,7 +275,7 @@ M: general-list tutorial-line "" [ "-1 sqrt ." ] "" - [ "M[ [ 10 3 ] [ 7 5 ] [ -2 0 ] ]M M[ [ 11 2 ] [ 4 8 ] ]M m." ] + [ "M{ { 10 3 } { 7 5 } { -2 0 } }M M{ { 11 2 } { 4 8 } }M m." ] "" "... and there is much more for the math geeks." ] [ diff --git a/library/inference/branches.factor b/library/inference/branches.factor index e607ced654..ac43cb23fe 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -31,7 +31,7 @@ sequences strings vectors words hashtables prettyprint ; : unify-stacks ( list -- stack ) #! Replace differing literals in stacks with unknown #! results. - unify-lengths seq-transpose [ unify-results ] map >vector ; + unify-lengths seq-transpose [ unify-results ] map ; : balanced? ( list -- ? ) #! Check if a list of [[ instack outstack ]] pairs is diff --git a/library/io/binary.factor b/library/io/binary.factor index fbb28b4406..128a9161c8 100644 --- a/library/io/binary.factor +++ b/library/io/binary.factor @@ -8,5 +8,5 @@ USING: kernel lists math sequences strings ; : nth-byte ( x n -- b ) -8 * shift HEX: ff bitand ; -: >le ( x n -- string ) [ nth-byte ] project-with >string ; +: >le ( x n -- string ) [ nth-byte ] map-with >string ; : >be ( x n -- string ) >le reverse ; diff --git a/library/math/integer.factor b/library/math/integer.factor index 5600a1fd9f..84878b7d47 100644 --- a/library/math/integer.factor +++ b/library/math/integer.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: math -USING: errors generic kernel math ; +USING: errors generic kernel math sequences ; DEFER: fixnum? BUILTIN: fixnum 0 fixnum? ; @@ -105,3 +105,7 @@ M: bignum bitnot bignum-bitnot ; M: integer truncate ; M: integer floor ; M: integer ceiling ; + +! Integers support the sequence protocol +M: integer length ; +M: integer nth drop ; diff --git a/library/math/matrices.factor b/library/math/matrices.factor index 775da30b31..7792b25dfe 100644 --- a/library/math/matrices.factor +++ b/library/math/matrices.factor @@ -184,4 +184,4 @@ M: diagonal nth ( n diag -- n ) : row-list ( matrix -- list ) #! A list of lists, where each sublist is a row of the #! matrix. - dup matrix-rows [ swap >list ] project-with ; + dup matrix-rows [ swap >vector ] map-with >list ; diff --git a/library/syntax/math.factor b/library/syntax/math.factor index 76d24d7fa1..daf3425145 100644 --- a/library/syntax/math.factor +++ b/library/syntax/math.factor @@ -20,9 +20,9 @@ vectors ; : BIN: 2 (BASE) ; parsing ! Matrices -: M[ f ; parsing +: M{ f ; parsing -: ]M +: }M reverse [ dup length swap car length ] keep concat >vector swons ; parsing diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index e1d2a67ab3..3ecabe8475 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -53,11 +53,7 @@ M: word prettyprint* ( indent word -- indent ) ] when* ; : ?prettyprint-newline ( indent -- ) - one-line get [ - bl drop - ] [ - prettyprint-newline - ] ifte ; + one-line get [ bl drop ] [ prettyprint-newline ] ifte ; : r 3 + r> + \ M{ unparse. bl >r 3 + r> row-list matrix-rows. - bl \ ]M unparse. 3 - ; + bl \ }M unparse. 3 - ; : prettyprint ( obj -- ) [ diff --git a/library/test/continuations.factor b/library/test/continuations.factor index 3bcf782fec..3c8fd435b0 100644 --- a/library/test/continuations.factor +++ b/library/test/continuations.factor @@ -25,7 +25,7 @@ USE: test ] with-scope ] callcc0 "x" get 5 = ; -[ t ] [ 10 callcc1-test 10 count = ] unit-test +[ t ] [ 10 callcc1-test 10 >list = ] unit-test [ t ] [ callcc-namespace-test ] unit-test : multishot-test ( -- stack ) diff --git a/library/test/hashtables.factor b/library/test/hashtables.factor index 158c0e5221..c1b2224591 100644 --- a/library/test/hashtables.factor +++ b/library/test/hashtables.factor @@ -15,7 +15,7 @@ USE: sequences 1000 [ [ silly-key/value "testhash" get set-hash ] keep ] repeat [ f ] -[ 1000 count [ silly-key/value "testhash" get hash = not ] subset ] +[ 1000 >list [ silly-key/value "testhash" get hash = not ] subset ] unit-test [ t ] diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor index 580978042b..e5cd4471dc 100644 --- a/library/test/lists/lists.factor +++ b/library/test/lists/lists.factor @@ -38,8 +38,8 @@ USING: kernel lists sequences test ; [ [ 1 2 3 ] ] [ 1 [ 1 2 3 ] unique ] unit-test [ [ 1 2 3 ] ] [ 2 [ 1 2 3 ] unique ] unit-test -[ [ ] ] [ 0 count ] unit-test -[ [ 0 1 2 3 ] ] [ 4 count ] unit-test +[ [ ] ] [ 0 >list ] unit-test +[ [ 0 1 2 3 ] ] [ 4 >list ] unit-test [ f ] [ 0 f head ] unit-test [ f ] [ 0 [ 1 ] head ] unit-test diff --git a/library/test/lists/queues.factor b/library/test/lists/queues.factor index 4ff439e0ef..c8a7251e6e 100644 --- a/library/test/lists/queues.factor +++ b/library/test/lists/queues.factor @@ -1,7 +1,7 @@ IN: temporary USING: kernel lists math sequences test ; -[ [ 1 2 3 4 5 ] ] [ +[ { 1 2 3 4 5 } ] [ [ 1 2 3 4 5 ] [ swap enque ] each - 5 [ drop deque swap ] project nip + 5 [ drop deque swap ] map nip ] unit-test diff --git a/library/test/math/matrices.factor b/library/test/math/matrices.factor index cf9a1978a0..ad133aa195 100644 --- a/library/test/math/matrices.factor +++ b/library/test/math/matrices.factor @@ -2,57 +2,57 @@ IN: temporary USING: kernel lists math matrices namespaces sequences test vectors ; -[ [ [ 1 4 ] [ 2 5 ] [ 3 6 ] ] ] -[ M[ [ 1 4 ] [ 2 5 ] [ 3 6 ] ]M row-list ] unit-test +[ [ { 1 4 } { 2 5 } { 3 6 } ] ] +[ M{ { 1 4 } { 2 5 } { 3 6 } }M row-list ] unit-test [ - M[ [ 0 ] [ 0 ] [ 0 ] ]M + M{ { 0 } { 0 } { 0 } }M ] [ 3 1 ] unit-test [ - M[ [ 1 ] [ 2 ] [ 3 ] ]M + M{ { 1 } { 2 } { 3 } }M ] [ { 1 2 3 } ] unit-test [ - M[ [ 1 0 0 ] - [ 0 1 0 ] - [ 0 0 1 ] ]M + M{ { 1 0 0 } + { 0 1 0 } + { 0 0 1 } }M ] [ 3 ] unit-test [ - M[ [ 1 0 4 ] - [ 0 7 0 ] - [ 6 0 3 ] ]M + M{ { 1 0 4 } + { 0 7 0 } + { 6 0 3 } }M ] [ - M[ [ 1 0 0 ] - [ 0 2 0 ] - [ 0 0 3 ] ]M + M{ { 1 0 0 } + { 0 2 0 } + { 0 0 3 } }M - M[ [ 0 0 4 ] - [ 0 5 0 ] - [ 6 0 0 ] ]M + M{ { 0 0 4 } + { 0 5 0 } + { 6 0 0 } }M m+ ] unit-test [ - M[ [ 1 0 4 ] - [ 0 7 0 ] - [ 6 0 3 ] ]M + M{ { 1 0 4 } + { 0 7 0 } + { 6 0 3 } }M ] [ - M[ [ 1 0 0 ] - [ 0 2 0 ] - [ 0 0 3 ] ]M + M{ { 1 0 0 } + { 0 2 0 } + { 0 0 3 } }M - M[ [ 0 0 -4 ] - [ 0 -5 0 ] - [ -6 0 0 ] ]M + M{ { 0 0 -4 } + { 0 -5 0 } + { -6 0 0 } }M m- ] unit-test @@ -64,15 +64,15 @@ vectors ; ] unit-test [ - M[ [ 6 ] ]M + M{ { 6 } }M ] [ - M[ [ 3 ] ]M M[ [ 2 ] ]M m. + M{ { 3 } }M M{ { 2 } }M m. ] unit-test [ - M[ [ 11 ] ]M + M{ { 11 } }M ] [ - M[ [ 1 3 ] ]M M[ [ 5 ] [ 2 ] ]M m. + M{ { 1 3 } }M M{ { 5 } { 2 } }M m. ] unit-test [ @@ -84,8 +84,8 @@ vectors ; [ { 3 4 } ] [ - M[ [ 1 0 ] - [ 0 1 ] ]M + M{ { 1 0 } + { 0 1 } }M { 3 4 } @@ -95,8 +95,8 @@ vectors ; [ { 4 3 } ] [ - M[ [ 0 1 ] - [ 1 0 ] ]M + M{ { 0 1 } + { 1 0 } }M { 3 4 } @@ -107,35 +107,35 @@ vectors ; [ { 1 0 0 } ] [ { 0 1 0 } { 0 0 1 } cross ] unit-test [ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test -[ M[ [ 1 2 ] [ 3 4 ] [ 5 6 ] ]M ] -[ M[ [ 1 2 ] [ 3 4 ] [ 5 6 ] ]M transpose transpose ] +[ M{ { 1 2 } { 3 4 } { 5 6 } }M ] +[ M{ { 1 2 } { 3 4 } { 5 6 } }M transpose transpose ] unit-test -[ M[ [ 1 3 5 ] [ 2 4 6 ] ]M ] -[ M[ [ 1 3 5 ] [ 2 4 6 ] ]M transpose transpose ] +[ M{ { 1 3 5 } { 2 4 6 } }M ] +[ M{ { 1 3 5 } { 2 4 6 } }M transpose transpose ] unit-test -[ M[ [ 1 3 5 ] [ 2 4 6 ] ]M ] -[ M[ [ 1 2 ] [ 3 4 ] [ 5 6 ] ]M transpose ] +[ M{ { 1 3 5 } { 2 4 6 } }M ] +[ M{ { 1 2 } { 3 4 } { 5 6 } }M transpose ] unit-test [ - M[ [ 28 ] ]M + M{ { 28 } }M ] [ - M[ [ 2 4 6 ] ]M + M{ { 2 4 6 } }M - M[ [ 1 ] - [ 2 ] - [ 3 ] ]M + M{ { 1 } + { 2 } + { 3 } }M m. ] unit-test [ - [ { 7 } { 4 8 } { 1 5 9 } { 2 6 } { 3 } ] + { { 7 } { 4 8 } { 1 5 9 } { 2 6 } { 3 } } ] [ - M[ [ 1 2 3 ] [ 4 5 6 ] [ 7 8 9 ] ]M - 5 [ 2 - swap ] project-with [ >vector ] map + M{ { 1 2 3 } { 4 5 6 } { 7 8 9 } }M + 5 [ 2 - swap >vector ] map-with ] unit-test [ { t t t } ] diff --git a/library/test/memory.factor b/library/test/memory.factor index 4ea4baedf3..4fd8d04cdd 100644 --- a/library/test/memory.factor +++ b/library/test/memory.factor @@ -2,6 +2,10 @@ IN: temporary USING: generic kernel lists math memory words prettyprint sequences test ; +TUPLE: testing x y z ; + +[ f 1 2 3 ] [ 1 2 3 [ ] each-slot ] unit-test + [ ] [ num-types [ [ diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 0bd1591bec..af90317719 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -4,7 +4,6 @@ sequences strings test vectors ; [ 3 ] [ [ t f t ] length ] unit-test [ 3 ] [ { t f t } length ] unit-test -[ 4 length ] unit-test-fails [ -3 { } nth ] unit-test-fails [ 3 { } nth ] unit-test-fails @@ -20,7 +19,6 @@ sequences strings test vectors ; [ 1 { } nth ] unit-test-fails [ -1 { } set-length ] unit-test-fails -[ 5 >vector ] unit-test-fails [ { } ] [ [ ] >vector ] unit-test [ { 1 2 } ] [ [ 1 2 ] >vector ] unit-test @@ -52,7 +50,7 @@ sequences strings test vectors ; [ { 1 2 3 4 } ] [ [ { 1 } [ 2 ] { 3 4 } ] concat ] unit-test [ { "" "a" "aa" "aaa" } ] -[ 4 [ CHAR: a fill ] project >vector ] +[ 4 [ CHAR: a fill ] map ] unit-test [ { } ] [ 0 { } tail ] unit-test @@ -95,5 +93,5 @@ unit-test [ 4 ] [ 5 { 1 2 3 4 5 } index ] unit-test [ t ] [ - 100 count dup >vector >list >r reverse r> = + 100 >list dup >vector >list >r reverse r> = ] unit-test diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index 2b584e96c7..c894d24699 100644 --- a/library/tools/inspector.factor +++ b/library/tools/inspector.factor @@ -9,17 +9,11 @@ SYMBOL: inspecting GENERIC: sheet ( obj -- sheet ) -: object-sheet ( obj -- names values ) +M: object sheet ( obj -- sheet ) dup class "slots" word-prop [ second ] map - tuck [ execute ] map-with ; - -M: object sheet object-sheet 2list ; - -M: tuple sheet - dup object-sheet - >r >r \ delegate swap delegate r> r> - 2cons 2list ; + tuck [ execute ] map-with + 2list ; PREDICATE: list nonvoid cons? ; @@ -37,7 +31,7 @@ M: hashtable sheet hash>alist unzip 2list ; [ swap CHAR: \s pad-right ] map-with ; : format-sheet ( sheet -- list ) - dup first length count swons + dup first length >vector swons dup peek over first [ set ] 2each [ column ] map seq-transpose diff --git a/library/tools/memory.factor b/library/tools/memory.factor index f803cf39f0..af0ffe0d81 100644 --- a/library/tools/memory.factor +++ b/library/tools/memory.factor @@ -52,25 +52,15 @@ vectors words ; ] each-object drop ] make-list ; -GENERIC: (each-slot) ( quot obj -- ) inline +G: each-slot ( obj quot -- ) [ over ] [ type ] ; inline -M: arrayed (each-slot) ( quot array -- ) - dup array-capacity [ - [ - ( quot obj n -- ) - swap array-nth swap dup slip - ] 2keep - ] repeat 2drop ; +M: array each-slot ( array quot -- ) each ; -M: object (each-slot) ( quot obj -- ) - dup class "slots" word-prop [ - pick pick >r >r car slot swap call r> r> +M: object each-slot ( obj quot -- ) + over class "slots" word-prop [ + -rot [ >r swap first slot r> call ] 2keep ] each 2drop ; -: each-slot ( obj quot -- ) - #! Apply the quotation to each slot value of the object. - swap (each-slot) ; inline - : refers? ( to obj -- ? ) f swap [ pick eq? or ] each-slot nip ; From 95a4fbb25f399b11c2ad635a01dac08b4a635317 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 25 Jul 2005 22:34:59 +0000 Subject: [PATCH 012/178] Various changes to get cont-responder examples working with 0.76 --- contrib/cont-responder/live-updater.factor | 2 +- contrib/cont-responder/todo-example.factor | 118 ++++++++++----------- contrib/cont-responder/todo.factor | 13 +-- 3 files changed, 67 insertions(+), 66 deletions(-) diff --git a/contrib/cont-responder/live-updater.factor b/contrib/cont-responder/live-updater.factor index 1e4ca45178..d4355948cd 100644 --- a/contrib/cont-responder/live-updater.factor +++ b/contrib/cont-responder/live-updater.factor @@ -34,7 +34,7 @@ USE: lists : get-live-updater-js* ( stream -- string ) #! Read all lines from the stream, creating a string of the result. - dup stream-readln dup [ , "\n" , get-live-updater-js* ] [ drop stream-close ] ifte ; + dup stream-readln dup [ % "\n" % get-live-updater-js* ] [ drop stream-close ] ifte ; : get-live-updater-js ( filename -- string ) #! Return the liveUpdater javascript code as a string. diff --git a/contrib/cont-responder/todo-example.factor b/contrib/cont-responder/todo-example.factor index 287e22b5ac..128dc80900 100644 --- a/contrib/cont-responder/todo-example.factor +++ b/contrib/cont-responder/todo-example.factor @@ -45,63 +45,63 @@ USE: sequences : todo-stylesheet ( -- string ) #! Return the stylesheet for the todo list [ - "table.list {" , - " text-align:center;" , - " font-family: Verdana;" , - " font-weight: normal;" , - " font-size: 11px;" , - " color: #404040;" , - " background-color: #fafafa;" , - " border: 1px #6699cc solid;" , - " border-collapse: collapse;" , - " boder-spacing: 0px;" , - "}" , - "tr.heading {" , - " border-bottom: 2px solid #6699cc;" , - " border-left: 1px solix #6699cc;" , - " background-color: #BEC8D1;" , - " text-align: left;" , - " text-indent: 0px;" , - " font-family: verdana;" , - " font-weight: bold;" , - " color: #404040;" , - "}" , - "tr.item {" , - " border-bottom: 1px solid #9cf;" , - " border-top: 0px;" , - " border-left: 1px solid #9cf;" , - " border-right: 0px;" , - " text-align: left;" , - " text-indent: 2px;" , - " font-family: verdana, sans-serif, arial;" , - " font-weight: normal;" , - " color: #404040;" , - " background-color: #fafafa;" , - "}" , - "tr.complete {" , - " border-bottom: 1px solid #9cf;" , - " border-top: 0px;" , - " border-left: 1px solid #9cf;" , - " border-right: 0px;" , - " text-align: left;" , - " text-indent: 2px;" , - " font-family: verdana, sans-serif, arial;" , - " font-weight: normal;" , - " color: #404040;" , - " background-color: #ccc;" , - "}" , - "td.lbl {" , - " font-weight: bold; text-align: right;" , - "}" , - "tr.required {" , - " background: #FCC;" , - "}" , - "input:focus {" , - " background: yellow;" , - "}" , - "textarea:focus {" , - " background: yellow;" , - "}" , + "table.list {" % + " text-align:center;" % + " font-family: Verdana;" % + " font-weight: normal;" % + " font-size: 11px;" % + " color: #404040;" % + " background-color: #fafafa;" % + " border: 1px #6699cc solid;" % + " border-collapse: collapse;" % + " boder-spacing: 0px;" % + "}" % + "tr.heading {" % + " border-bottom: 2px solid #6699cc;" % + " border-left: 1px solix #6699cc;" % + " background-color: #BEC8D1;" % + " text-align: left;" % + " text-indent: 0px;" % + " font-family: verdana;" % + " font-weight: bold;" % + " color: #404040;" % + "}" % + "tr.item {" % + " border-bottom: 1px solid #9cf;" % + " border-top: 0px;" % + " border-left: 1px solid #9cf;" % + " border-right: 0px;" % + " text-align: left;" % + " text-indent: 2px;" % + " font-family: verdana, sans-serif, arial;" % + " font-weight: normal;" % + " color: #404040;" % + " background-color: #fafafa;" % + "}" % + "tr.complete {" % + " border-bottom: 1px solid #9cf;" % + " border-top: 0px;" % + " border-left: 1px solid #9cf;" % + " border-right: 0px;" % + " text-align: left;" % + " text-indent: 2px;" % + " font-family: verdana, sans-serif, arial;" % + " font-weight: normal;" % + " color: #404040;" % + " background-color: #ccc;" % + "}" % + "td.lbl {" % + " font-weight: bold; text-align: right;" % + "}" % + "tr.required {" % + " background: #FCC;" % + "}" % + "input:focus {" % + " background: yellow;" % + "}" % + "textarea:focus {" % + " background: yellow;" % + "}" % ] make-string ; : todo-stylesheet-url ( -- url ) @@ -234,7 +234,7 @@ USE: sequences : get-todo-filename ( database-path -- filename ) #! Get the filename containing the todo list details. - [ swap , todo-username , ".todo" , ] make-string ; + [ swap % todo-username % ".todo" % ] make-string ; : add-default-todo-item ( -- ) #! Add a default todo item. This is a workaround for the @@ -473,7 +473,7 @@ USE: sequences : show-todo-list ( -- ) #! Show the current todo list. [ - [ "todo" get todo-username , "'s To Do list" , ] make-string + [ "todo" get todo-username % "'s To Do list" % ] make-string [ include-todo-stylesheet ] [ "todo" get write-item-table diff --git a/contrib/cont-responder/todo.factor b/contrib/cont-responder/todo.factor index 44507cec33..ad3a0473a0 100644 --- a/contrib/cont-responder/todo.factor +++ b/contrib/cont-responder/todo.factor @@ -36,6 +36,7 @@ USE: prettyprint USE: hashtables USE: sequences USE: http +USE: unparser : ( user password -- ) #! Create an empty todo list @@ -93,13 +94,13 @@ USE: http : read-todo ( -- ) #! Read a todo list from the current input stream. - read-line url-decode read-line url-decode - read-line str>number [ + readln url-decode readln url-decode + readln str>number [ dup [ - read-line url-decode "yes" = "complete?" set - read-line url-decode "priority" set - read-line url-decode "description" set + readln url-decode "yes" = "complete?" set + readln url-decode "priority" set + readln url-decode "description" set ] extend add-todo-item ] times ; @@ -149,7 +150,7 @@ USE: http : priority-comparator ( item1 item2 -- bool ) #! Return true if item1 is a higher priority than item2 - >r item-priority r> item-priority string> ; + >r item-priority r> item-priority lexi> ; : todo-items ( -- alist ) #! Return a list of items for the given todo list. From a1dba7ddc7fddc1d289e08094f406262508fac84 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 25 Jul 2005 22:35:29 +0000 Subject: [PATCH 013/178] Changes to get parser-combinators working with 0.76 --- contrib/parser-combinators/parser-combinators.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/contrib/parser-combinators/parser-combinators.factor b/contrib/parser-combinators/parser-combinators.factor index 621491c63b..9c756a4950 100644 --- a/contrib/parser-combinators/parser-combinators.factor +++ b/contrib/parser-combinators/parser-combinators.factor @@ -27,6 +27,7 @@ USE: sequences USE: strings USE: lists USE: math +USE: io GENERIC: phead From 6e51d61c336b42c1a331ceff0ca7b2db351aa2c9 Mon Sep 17 00:00:00 2001 From: Mackenzie Straight Date: Tue, 26 Jul 2005 14:41:55 +0000 Subject: [PATCH 014/178] add dllexports --- native/float.h | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/native/float.h b/native/float.h index ae61a867b9..d3d19b99a6 100644 --- a/native/float.h +++ b/native/float.h @@ -54,7 +54,7 @@ void primitive_bits_float(void); void primitive_double_bits(void); void primitive_bits_double(void); -void box_float(float flo); -float unbox_float(void); -void box_double(double flo); -double unbox_double(void); +DLLEXPORT void box_float(float flo); +DLLEXPORT float unbox_float(void); +DLLEXPORT void box_double(double flo); +DLLEXPORT double unbox_double(void); From 2283fee9601ffccc888faf89405e1aafda47ea9d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Jul 2005 20:39:14 +0000 Subject: [PATCH 015/178] some code cleanups, factorbot PING fix --- examples/factorbot.factor | 5 +- library/collections/cons.factor | 7 --- library/collections/sequences-epilogue.factor | 4 ++ library/inference/branches.factor | 54 ++++++++----------- library/test/lists/assoc.factor | 3 -- library/test/lists/cons.factor | 1 - library/test/memory.factor | 11 ++-- library/tools/inspector.factor | 4 +- native/io.c | 4 ++ 9 files changed, 45 insertions(+), 48 deletions(-) diff --git a/examples/factorbot.factor b/examples/factorbot.factor index f159747cf1..cf3da370d4 100644 --- a/examples/factorbot.factor +++ b/examples/factorbot.factor @@ -1,8 +1,8 @@ ! Simple IRC bot written in Factor. -IN: factorbot USING: generic hashtables http io kernel math namespaces prettyprint sequences strings words ; +IN: factorbot SYMBOL: irc-stream SYMBOL: nickname @@ -48,6 +48,9 @@ M: privmsg handle-irc ( line -- ) [ "factorbot-commands" ] search dup [ execute ] [ 2drop ] ifte ; +M: ping handle-irc ( line -- ) + "PING " ?head drop "PONG " swap append irc-print ; + : parse-irc ( line -- ) ":" ?head [ "!" split1 swap speaker set ] when handle-irc ; diff --git a/library/collections/cons.factor b/library/collections/cons.factor index 0b68ca0f3a..26e8fb1393 100644 --- a/library/collections/cons.factor +++ b/library/collections/cons.factor @@ -40,13 +40,6 @@ PREDICATE: general-list list ( list -- ? ) : 2car ( cons cons -- car car ) swap car swap car ; : 2cdr ( cons cons -- car car ) swap cdr swap cdr ; -: 2cons ( ca1 ca2 cd1 cd2 -- c1 c2 ) rot swons >r cons r> ; -: 2uncons ( c1 c2 -- ca1 ca2 cd1 cd2 ) [ 2car ] 2keep 2cdr ; - -: unzip ( assoc -- keys values ) - #! Split an association list into two lists of keys and - #! values. - [ uncons >r uncons r> unzip 2cons ] [ [ ] [ ] ] ifte* ; : unpair ( list -- list1 list2 ) [ uncons uncons unpair rot swons >r cons r> ] [ f f ] ifte* ; diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 82a5f8da72..7d5a25ab0b 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -239,6 +239,10 @@ M: object reverse ( seq -- seq ) [ ] keep like ; #! { { 1 2 3 } { 4 5 6 } } ==> { { 1 2 } { 3 4 } { 5 6 } } dup first length [ swap [ nth ] map-with ] map-with ; +: max-length ( seq -- n ) + #! Longest sequence length in a sequence of sequences. + 0 [ length max ] reduce ; + IN: kernel : depth ( -- n ) diff --git a/library/inference/branches.factor b/library/inference/branches.factor index ac43cb23fe..aff4ba6770 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -1,11 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: inference -USING: errors generic interpreter kernel lists math namespaces -sequences strings vectors words hashtables prettyprint ; - -: longest ( list -- length ) - [ length ] map 0 [ max ] reduce ; +USING: errors generic hashtables interpreter kernel lists math +matrices namespaces prettyprint sequences strings vectors words ; : computed-value-vector ( n -- vector ) empty-vector [ drop object ] map ; @@ -14,53 +11,48 @@ sequences strings vectors words hashtables prettyprint ; #! Add this many inputs to the given stack. [ length - computed-value-vector ] keep append ; -: unify-lengths ( list -- list ) +: unify-lengths ( seq -- list ) #! Pad all vectors to the same length. If one vector is #! shorter, pad it with unknown results at the bottom. - dup longest swap [ add-inputs ] map-with ; + dup max-length swap [ add-inputs ] map-with ; -: unify-results ( list -- value ) +: unify-results ( seq -- value ) #! If all values in list are equal, return the value. #! Otherwise, unify types. - dup [ eq? ] fiber? [ - car - ] [ - [ value-class ] map class-or-list - ] ifte ; + dup [ eq? ] fiber? + [ first ] + [ [ value-class ] map class-or-list ] ifte ; -: unify-stacks ( list -- stack ) +: unify-stacks ( seq -- stack ) #! Replace differing literals in stacks with unknown #! results. unify-lengths seq-transpose [ unify-results ] map ; -: balanced? ( list -- ? ) - #! Check if a list of [[ instack outstack ]] pairs is - #! balanced. - [ uncons length swap length - ] map [ = ] fiber? ; +: balanced? ( in out -- ? ) + swap [ length ] map swap [ length ] map v- [ = ] fiber? ; -: unify-effect ( list -- in out ) - #! Unify a list of [[ instack outstack ]] pairs. - dup balanced? [ - unzip unify-stacks >r unify-stacks r> - ] [ - "Unbalanced branches" inference-error - ] ifte ; +: unify-effect ( in out -- in out ) + 2dup balanced? + [ unify-stacks >r unify-stacks r> ] + [ "Unbalanced branches" inference-error ] ifte ; -: datastack-effect ( list -- ) - [ [ effect ] bind ] map +: datastack-effect ( seq -- ) + dup [ d-in swap hash ] map + swap [ meta-d swap hash ] map unify-effect meta-d set d-in set ; -: callstack-effect ( list -- ) - [ [ { } meta-r get ] bind cons ] map +: callstack-effect ( seq -- ) + dup length { } + swap [ meta-r swap hash ] map unify-effect meta-r set drop ; -: filter-terminators ( list -- list ) +: filter-terminators ( seq -- seq ) #! Remove branches that unconditionally throw errors. [ [ active? ] bind ] subset ; -: unify-effects ( list -- ) +: unify-effects ( seq -- ) filter-terminators [ dup datastack-effect callstack-effect ] [ diff --git a/library/test/lists/assoc.factor b/library/test/lists/assoc.factor index d68368dc8c..292ff9a5c4 100644 --- a/library/test/lists/assoc.factor +++ b/library/test/lists/assoc.factor @@ -45,6 +45,3 @@ USE: test [ [ [ "one" + ] [ "four" * ] ] ] [ "three" "quot-alist" get remove-assoc ] unit-test - -[ [ "one" "three" "four" ] [ [ + ] [ - ] [ * ] ] ] -[ "quot-alist" get unzip ] unit-test diff --git a/library/test/lists/cons.factor b/library/test/lists/cons.factor index 819b9a928d..662697de2e 100644 --- a/library/test/lists/cons.factor +++ b/library/test/lists/cons.factor @@ -34,4 +34,3 @@ USE: test [ 1 3 ] [ [[ 1 2 ]] [[ 3 4 ]] 2car ] unit-test [ 2 4 ] [ [[ 1 2 ]] [[ 3 4 ]] 2cdr ] unit-test -[ 1 3 2 4 ] [ [[ 1 2 ]] [[ 3 4 ]] 2uncons ] unit-test diff --git a/library/test/memory.factor b/library/test/memory.factor index 4fd8d04cdd..3202b86e68 100644 --- a/library/test/memory.factor +++ b/library/test/memory.factor @@ -10,9 +10,14 @@ TUPLE: testing x y z ; num-types [ [ builtin-type [ - "predicate" word-prop instances [ - class drop - ] each + dup \ cons = [ + ! too many conses! + drop + ] [ + "predicate" word-prop instances [ + class drop + ] each + ] ifte ] when* ] keep ] repeat diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index c894d24699..2dd2e824d0 100644 --- a/library/tools/inspector.factor +++ b/library/tools/inspector.factor @@ -23,11 +23,11 @@ M: vector sheet unit ; M: array sheet unit ; -M: hashtable sheet hash>alist unzip 2list ; +M: hashtable sheet dup hash-keys swap hash-values 2list ; : column ( list -- list ) [ unparse ] map - [ [ length ] map 0 [ max ] reduce ] keep + [ max-length ] keep [ swap CHAR: \s pad-right ] map-with ; : format-sheet ( sheet -- list ) diff --git a/native/io.c b/native/io.c index 34c2d7220a..47e02611cf 100644 --- a/native/io.c +++ b/native/io.c @@ -60,6 +60,10 @@ void primitive_fwrite(void) maybe_gc(0); file = (FILE*)unbox_alien(); text = untag_string(dpop()); + + if(string_capacity(text) == 0) + return; + if(fwrite(to_c_string_unchecked(text),1, untag_fixnum_fast(text->length), file) == 0) From 8c439fad2301e9805cc20c59803b36d8c1f05db9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 26 Jul 2005 23:54:43 +0000 Subject: [PATCH 016/178] Fix overflow in room primitive --- native/memory.c | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/native/memory.c b/native/memory.c index cde16bb442..8f8eaecf26 100644 --- a/native/memory.c +++ b/native/memory.c @@ -142,16 +142,15 @@ void primitive_room(void) { CELL list = F; int gen; - box_signed_cell(compiling.limit - compiling.here); - box_signed_cell(compiling.limit - compiling.base); - box_signed_cell(cards_end - cards); - box_signed_cell(prior.limit - prior.base); + box_unsigned_cell(compiling.limit - compiling.here); + box_unsigned_cell(compiling.limit - compiling.base); + box_unsigned_cell(cards_end - cards); + box_unsigned_cell(prior.limit - prior.base); for(gen = gen_count - 1; gen >= 0; gen--) { ZONE *z = &generations[gen]; - list = cons(cons( - tag_fixnum(z->limit - z->here), - tag_fixnum(z->limit - z->base)), + list = cons(cons(tag_cell(z->limit - z->here), + tag_cell(z->limit - z->base)), list); } dpush(list); From 0eb85fdd0dfd8114425f1973899dfcda8912d35f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 27 Jul 2005 05:46:06 +0000 Subject: [PATCH 017/178] working on dataflow optimizer --- doc/handbook.tex | 138 ++++++++++++++++++ library/bootstrap/boot-stage1.factor | 3 +- library/bootstrap/boot-stage3.factor | 4 +- library/collections/assoc.factor | 6 - library/collections/sequences-epilogue.factor | 18 ++- library/compiler/intrinsics.factor | 2 + library/inference/branches.factor | 47 +++--- library/inference/dataflow.factor | 14 +- library/inference/inference.factor | 36 +---- .../{compiler => inference}/optimizer.factor | 108 +++++++++----- library/inference/print-dataflow.factor | 70 +++++++++ library/inference/values.factor | 60 ++------ library/inference/words.factor | 2 +- library/syntax/prettyprint.factor | 5 +- library/test/sequences.factor | 6 + library/ui/editors.factor | 2 + library/ui/line-editor.factor | 8 + 17 files changed, 370 insertions(+), 159 deletions(-) rename library/{compiler => inference}/optimizer.factor (64%) create mode 100644 library/inference/print-dataflow.factor diff --git a/doc/handbook.tex b/doc/handbook.tex index a1cfe92da5..acffad2dd3 100644 --- a/doc/handbook.tex +++ b/doc/handbook.tex @@ -6271,6 +6271,144 @@ The compiler has two limitations you must be aware of. First, if an exception is The compiler consists of multiple stages -- first, a dataflow graph is inferred, then various optimizations are done on this graph, then it is transformed into a linear representation, further optimizations are done, and finally, machine code is generated from the linear representation. +\section{Dataflow intermediate representation} + +The dataflow IR represents nested control structure, and annotates all calls with stack input and output annotations. Such annotations consists of lists of values, where a value abstracts over a possibly unknown computation result. It has a tree shape, where each node is a tuple delegating to an instance of the \verb|node| tuple class. + +The \verb|node| tuple has the following slots: + +\begin{description} +\item[\texttt{param}] The meaning is determined by the tuple wrapping the node instance. For example with \verb|#call| nodes, this is the word being called. +\item[\texttt{in-d}] A list of input values popped the data stack. +\item[\texttt{in-r}] A list of input values popped the return stack. Only used by \verb|#call >r| nodes. +\item[\texttt{out-d}] A list of output values pushed on the data stack. +\item[\texttt{out-r}] A list of output values pushed on the return stack. Only used by \verb|#call r>| nodes. +\item[\texttt{node-successor}] The direct successor of the node. +\item[\texttt{node-children}] A list of the node's children, for example if this is a branch or label node. The number of children depends on the type of node. +\end{description} + +Note that nodes are linked by the \verb|node-successor| slot. Nested structure is realized by a list value in the \verb|node-children| slot. + +The stack effect inferencer transforms quotations into dataflow IR. + +\wordtable{ +\vocabulary{inference} +\ordinaryword{dataflow}{dataflow ( quot -- node )} +} + +Produces the dataflow IR of a quotation. + +\wordtable{ +\vocabulary{inference} +\ordinaryword{dataflow.}{dataflow.~( node -- )} +} + +Prints dataflow IR in human-readable form. + +\subsection{Values} + +Values are an abstraction over possibly known computation inputs and outputs. There are three types of values: + +\begin{description} +\item[Literal values] represent a known constant +\item[Computed values] represent inputs and outputs whose specific value is not known +\item[Joined values] represent a unification of possible values of a stack slot where branched control flow meets +\end{description} + +The \verb|value| tuple has the following slots: + +\begin{description} +\item[\texttt{recursion}] A list of nested lexical scopes, used to resolve recursive stack effects +\item[\texttt{safe?}] This is a hack. If this is false, the value's type at that point might not potentially be known, since a entry to this block from another entry point can potentially occur +\end{description} + +\subsection{Straight-line code} + +\begin{description} + +\item[\texttt{\#push}] Pushes literal values on the data stack. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-out-d|&A list of literals. +\end{tabular} + +\item[\texttt{\#drop}] Pops literal values from the data stack. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-in-d|&A list of literals. +\end{tabular} + +\item[\texttt{\#call}] Invokes the word identified by \verb|node-param|. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-param|&A word.\\ +\verb|node-in-d|&Input values.\\ +\verb|node-out-d|&Output values. +\end{tabular} + +\item[\texttt{\#call-label}] Like \verb|#call| but \verb|node-param| refers to a parent \verb|#label| node. + +\end{description} + +\subsection{Branching and recursion} + +\begin{description} + +\item[\texttt{\#ifte}] A conditional expression. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-in-d|&A singleton list holding the condition being tested.\\ +\verb|node-children|&A list of two nodes, the true and false branches. +\end{tabular} + +\item[\texttt{\#dispatch}] A jump table. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-in-d|&A singleton list holding the jump table index.\\ +\verb|node-children|&A list of nodes, in consecutive jump table order. +\end{tabular} + +\item[\texttt{\#values}] Found at the end of each branch in an \verb|#ifte| or \verb|#dispatch| node. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-out-d|&A list of values present on the data stack at the end of the branch.\\ +\end{tabular} + +\item[\texttt{\#label}] A named block of code. Child \verb|#call-label| nodes can recurse on this label. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-param|&A gensym identifying the label.\\ +\verb|node-children|&A singleton list whose sole element is the labelled node. +\end{tabular} + +\item[\texttt{\#return}] Found at the end of a word's dataflow IR. + +\begin{tabular}{l|l} +Slot&Role\\ +\hline +\verb|node-out-d|&Values present on the stack when the word returns. +\end{tabular} + +\end{description} + +\section{Dataflow optimizer} + +\subsection{Killing unused literals} + \section{Linear intermediate representation} The linear IR is the second of the two intermediate diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 8d16275738..80ad224844 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -90,11 +90,12 @@ parser prettyprint sequences io vectors words ; "/library/inference/words.factor" "/library/inference/stack.factor" "/library/inference/partial-eval.factor" + "/library/inference/optimizer.factor" + "/library/inference/print-dataflow.factor" "/library/compiler/assembler.factor" "/library/compiler/relocate.factor" "/library/compiler/xt.factor" - "/library/compiler/optimizer.factor" "/library/compiler/vops.factor" "/library/compiler/linearizer.factor" "/library/compiler/intrinsics.factor" diff --git a/library/bootstrap/boot-stage3.factor b/library/bootstrap/boot-stage3.factor index 2a9e7dcb0c..56eb3eff4a 100644 --- a/library/bootstrap/boot-stage3.factor +++ b/library/bootstrap/boot-stage3.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. USING: alien assembler command-line compiler compiler-backend -compiler-frontend io-internals kernel lists math namespaces -parser sequences io unparser words ; +compiler-frontend inference io-internals kernel lists math +namespaces parser sequences io unparser words ; "Compiling base..." print diff --git a/library/collections/assoc.factor b/library/collections/assoc.factor index fa44e5f7e8..2959adb23a 100644 --- a/library/collections/assoc.factor +++ b/library/collections/assoc.factor @@ -14,12 +14,6 @@ IN: lists USING: kernel sequences ; : assoc ( key alist -- value ) assoc* cdr ; -: assq* ( key alist -- [[ key value ]] ) - #! Looks up a key/value pair using identity comparison. - [ car eq? ] find-with nip ; - -: assq ( key alist -- value ) assq* cdr ; - : remove-assoc ( key alist -- alist ) #! Remove all key/value pairs with this key. [ car = not ] subset-with ; diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 7d5a25ab0b..4febc4ca6f 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -186,9 +186,13 @@ M: object peek ( sequence -- element ) : 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 ; + swap dup empty? [ + swap like + ] [ + dup length swap + [ over push 2dup push ] each nip >pop> + concat + ] ifte ; M: object reverse-slice ( seq -- seq ) ; @@ -243,6 +247,14 @@ M: object reverse ( seq -- seq ) [ ] keep like ; #! Longest sequence length in a sequence of sequences. 0 [ length max ] reduce ; +: subst ( new old seq -- seq ) + #! Substitute elements of old in seq with corresponding + #! elements from new. + [ + dup pick index dup -1 = + [ drop ] [ nip pick nth ] ifte + ] map 2nip ; + IN: kernel : depth ( -- n ) diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index f864fd5715..96701798c5 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -59,6 +59,8 @@ sequences words ; : peek-2 dup length 2 - swap nth ; : node-peek-2 ( node -- obj ) node-in-d peek-2 ; +: value-types drop f ; + : typed? ( value -- ? ) value-types length 1 = ; : slot@ ( node -- n ) diff --git a/library/inference/branches.factor b/library/inference/branches.factor index aff4ba6770..4a80177e79 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -4,9 +4,6 @@ IN: inference USING: errors generic hashtables interpreter kernel lists math matrices namespaces prettyprint sequences strings vectors words ; -: computed-value-vector ( n -- vector ) - empty-vector [ drop object ] map ; - : add-inputs ( count stack -- stack ) #! Add this many inputs to the given stack. [ length - computed-value-vector ] keep append ; @@ -18,10 +15,8 @@ matrices namespaces prettyprint sequences strings vectors words ; : unify-results ( seq -- value ) #! If all values in list are equal, return the value. - #! Otherwise, unify types. - dup [ eq? ] fiber? - [ first ] - [ [ value-class ] map class-or-list ] ifte ; + #! Otherwise, unify. + dup [ eq? ] fiber? [ first ] [ ] ifte ; : unify-stacks ( seq -- stack ) #! Replace differing literals in stacks with unknown @@ -53,24 +48,19 @@ matrices namespaces prettyprint sequences strings vectors words ; [ [ active? ] bind ] subset ; : unify-effects ( seq -- ) - filter-terminators [ - dup datastack-effect callstack-effect - ] [ - terminate - ] ifte* ; + filter-terminators + [ dup datastack-effect callstack-effect ] + [ terminate ] ifte* ; : unify-dataflow ( effects -- nodes ) [ [ dataflow-graph get ] bind ] map ; -: clone-values ( seq -- seq ) [ clone-value ] map ; - : copy-inference ( -- ) #! We avoid cloning the same object more than once in order #! to preserve identity structure. - cloned off - meta-r [ clone-values ] change - meta-d [ clone-values ] change - d-in [ clone-values ] change + meta-r [ clone ] change + meta-d [ clone ] change + d-in [ clone ] change dataflow-graph off current-node off ; @@ -82,34 +72,31 @@ matrices namespaces prettyprint sequences strings vectors words ; copy-inference dup value-recursion recursive-state set literal-value dup infer-quot - active? [ - #values node, - handle-terminator - ] [ - drop - ] ifte + active? [ #values node, handle-terminator ] [ drop ] ifte ] extend ; : (infer-branches) ( branchlist -- list ) - [ infer-branch ] map dup unify-effects unify-dataflow ; + [ infer-branch ] map dup unify-effects + unify-dataflow ; : infer-branches ( branches node -- ) #! Recursive stack effect inference is done here. If one of #! the branches has an undecidable stack effect, we set the #! base case to this stack effect and try again. - [ >r (infer-branches) r> set-node-children ] keep node, ; + [ >r (infer-branches) r> set-node-children ] keep + node, meta-d get >list #merge node, ; \ ifte [ - 2 #drop node, pop-d pop-d swap 2list + 2 #drop node, pop-d pop-d swap 2vector #ifte pop-d drop infer-branches ] "infer" set-word-prop -: vtable>list ( rstate vtable -- list ) - [ swap ] map-with >list ; +: vtable-value ( rstate vtable -- seq ) + [ swap ] map-with ; USE: kernel-internals \ dispatch [ - pop-literal vtable>list + pop-literal vtable-value #dispatch pop-d drop infer-branches ] "infer" set-word-prop diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index 72b295c1eb..d1438827e1 100644 --- a/library/inference/dataflow.factor +++ b/library/inference/dataflow.factor @@ -8,16 +8,16 @@ sequences vectors words ; ! representations used by Factor. It annotates concatenative ! code with stack flow information and types. -TUPLE: node effect param in-d out-d in-r out-r +TUPLE: node param in-d out-d in-r out-r successor children ; : make-node ( effect param in-d out-d in-r out-r node -- node ) [ >r f r> set-delegate ] keep ; -: empty-node f f f f f f f f f ; -: param-node ( label) f swap f f f f f ; -: in-d-node ( inputs) >r f f r> f f f f ; -: out-d-node ( outputs) >r f f f r> f f f ; +: empty-node f f f f f f f f ; +: param-node ( label) f f f f f ; +: in-d-node ( inputs) >r f r> f f f f ; +: out-d-node ( outputs) >r f f r> f f f ; : d-tail ( n -- list ) meta-d get tail* >list ; : r-tail ( n -- list ) meta-r get tail* >list ; @@ -58,6 +58,10 @@ TUPLE: #dispatch ; C: #dispatch make-node ; : #dispatch ( in -- node ) 1 d-tail in-d-node <#dispatch> ; +TUPLE: #merge ; +C: #merge make-node ; +: #merge ( values -- node ) in-d-node <#merge> ; + : node-inputs ( d-count r-count node -- ) tuck >r r-tail r> set-node-in-r diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 66e2c8df47..c413f41783 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -20,31 +20,14 @@ SYMBOL: d-in : pop-literal ( -- rstate obj ) 1 #drop node, pop-d >literal< ; -: (ensure-types) ( typelist n stack -- ) - pick [ - 3dup >r >r car r> r> nth value-class-and - >r >r cdr r> 1 + r> (ensure-types) - ] [ - 3drop - ] ifte ; - -: ensure-types ( typelist stack -- ) - dup length pick length - dup 0 < [ - swap >r neg swap tail 0 r> - ] [ - swap - ] ifte (ensure-types) ; +: computed-value-vector ( n -- vector ) + empty-vector dup [ drop ] nmap ; : required-inputs ( typelist stack -- values ) - >r dup length r> length - dup 0 > [ - swap head [ ] map - ] [ - 2drop f - ] ifte ; + >r length r> length - abs computed-value-vector ; : ensure-d ( typelist -- ) - dup meta-d get ensure-types - meta-d get required-inputs >vector dup + meta-d get required-inputs dup meta-d [ append ] change d-in [ append ] change ; @@ -54,16 +37,9 @@ SYMBOL: d-in 2slip second length 0 rot node-outputs ; inline -: (present-effect) ( vector -- list ) - >list [ value-class ] map ; - -: present-effect ( [[ d-in meta-d ]] -- [ in-types out-types ] ) +: present-effect ( [[ d-in meta-d ]] -- [[ in# out# ]] ) #! After inference is finished, collect information. - uncons >r (present-effect) r> (present-effect) 2list ; - -: simple-effect ( [[ d-in meta-d ]] -- [[ in# out# ]] ) - #! After inference is finished, collect information. - uncons length >r length r> cons ; + uncons length >r length r> 2list ; : init-inference ( recursive-state -- ) init-interpreter diff --git a/library/compiler/optimizer.factor b/library/inference/optimizer.factor similarity index 64% rename from library/compiler/optimizer.factor rename to library/inference/optimizer.factor index 8dc963bfe1..c788462a8f 100644 --- a/library/compiler/optimizer.factor +++ b/library/inference/optimizer.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. -IN: compiler-frontend +IN: inference USING: generic hashtables inference kernel lists matrices -namespaces sequences ; +namespaces sequences vectors ; ! The optimizer transforms dataflow IR to dataflow IR. Currently ! it removes literals that are eventually dropped, and never @@ -52,35 +52,31 @@ DEFER: kill-node 2drop ] ifte ; -GENERIC: useless-node? ( node -- ? ) +GENERIC: optimize-node* ( node -- node ) -DEFER: prune-nodes +DEFER: optimize-node ( node -- node/t ) -: prune-children ( node -- ) - [ node-children [ prune-nodes ] map ] keep - set-node-children ; +: optimize-children ( node -- ) + dup node-children [ optimize-node ] map + swap set-node-children ; -: (prune-nodes) ( node -- ) - [ - dup prune-children - dup node-successor dup useless-node? [ - node-successor over set-node-successor - ] [ - nip - ] ifte (prune-nodes) - ] when* ; +: keep-optimizing ( node -- node ) + dup optimize-node* dup t = + [ drop ] [ nip keep-optimizing ] ifte ; -: prune-nodes ( node -- node ) - dup useless-node? [ - node-successor prune-nodes - ] [ - [ (prune-nodes) ] keep - ] ifte ; +: optimize-node ( node -- node ) + keep-optimizing dup [ + dup optimize-children + dup node-successor optimize-node over set-node-successor + ] when ; : optimize ( dataflow -- dataflow ) #! Remove redundant literals from the IR. The original IR #! is destructively modified. - dup kill-set over kill-node prune-nodes ; + dup kill-set over kill-node optimize-node ; + +: prune-if ( node quot -- successor/t ) + over >r call [ r> node-successor ] [ r> drop t ] ifte ; ! Generic nodes M: node literals* ( node -- ) @@ -95,11 +91,10 @@ M: node can-kill* ( literal node -- ? ) M: node kill-node* ( literals node -- ) 2drop ; -M: f useless-node? ( node -- ? ) - drop f ; +M: f optimize-node* drop t ; -M: node useless-node? ( node -- ? ) - drop f ; +M: node optimize-node* ( node -- t ) + drop t ; ! #push M: #push literals* ( node -- ) @@ -111,8 +106,8 @@ M: #push can-kill* ( literal node -- ? ) M: #push kill-node* ( literals node -- ) [ node-out-d seq-diffq ] keep set-node-out-d ; -M: #push useless-node? ( node -- ? ) - node-out-d empty? ; +M: #push optimize-node* ( node -- node/t ) + [ node-out-d empty? ] prune-if ; ! #drop M: #drop can-kill* ( literal node -- ? ) @@ -121,8 +116,8 @@ M: #drop can-kill* ( literal node -- ? ) M: #drop kill-node* ( literals node -- ) [ node-in-d seq-diffq ] keep set-node-in-d ; -M: #drop useless-node? ( node -- ? ) - node-in-d empty? ; +M: #drop optimize-node* ( node -- node/t ) + [ node-in-d empty? ] prune-if ; ! #call M: #call can-kill* ( literal node -- ? ) @@ -174,8 +169,19 @@ M: #call kill-node* ( literals node -- ) dup node-param (kill-shuffle) [ kill-shuffle ] [ 2drop ] ifte ; -M: #call useless-node? ( node -- ? ) - node-param not ; +: optimize-not? ( #call -- ? ) + dup node-param \ not = + [ node-successor #ifte? ] [ drop f ] ifte ; + +: flip-branches ( #ifte -- ) + dup node-children 2unseq swap 2vector swap set-node-children ; + +M: #call optimize-node* ( node -- node ) + dup optimize-not? [ + node-successor dup flip-branches + ] [ + [ node-param not ] prune-if + ] ifte ; ! #call-label M: #call-label can-kill* ( literal node -- ? ) @@ -215,9 +221,45 @@ M: #values can-kill* ( literal node -- ? ) ] ifte ; ! #ifte +: static-branch? ( node -- lit ? ) + node-in-d first dup safe-literal? ; + +: static-branch ( conditional n -- node ) + >r [ node-in-d in-d-node <#drop> ] keep r> + over node-children nth + over node-successor over last-node set-node-successor + pick set-node-successor drop ; + M: #ifte can-kill* ( literal node -- ? ) can-kill-branches? ; +M: #ifte optimize-node* ( node -- node ) + dup static-branch? + [ f swap value= 1 0 ? static-branch ] [ 2drop t ] ifte ; + ! #dispatch M: #dispatch can-kill* ( literal node -- ? ) can-kill-branches? ; + +! #values +: subst-values ( new old node -- ) + dup [ + 3dup [ node-in-d subst ] keep set-node-in-d + 3dup [ node-in-r subst ] keep set-node-in-r + 3dup [ node-out-d subst ] keep set-node-out-d + 3dup [ node-out-r subst ] keep set-node-out-r + node-successor subst-values + ] [ + 3drop + ] ifte ; + +: post-split ( #values -- node ) + #! If a #values is followed by a #merge, we need to replace + #! meet values after the merge with their branch value in + #! #values. + dup node-successor dup node-successor + >r >r node-in-d reverse-slice r> node-in-d reverse-slice r> + [ subst-values ] keep ; + +M: #values optimize-node* ( node -- node ) + dup node-successor #merge? [ post-split ] [ drop t ] ifte ; diff --git a/library/inference/print-dataflow.factor b/library/inference/print-dataflow.factor new file mode 100644 index 0000000000..2c6aab9aaf --- /dev/null +++ b/library/inference/print-dataflow.factor @@ -0,0 +1,70 @@ +IN: inference +USING: generic inference io kernel kernel-internals math +namespaces prettyprint sequences vectors words ; + +! A simple tool for turning dataflow IR into quotations, for +! debugging purposes. + +GENERIC: node>quot ( node -- ) + +TUPLE: annotation node text ; + +M: annotation prettyprint* ( ann -- ) + "( " over annotation-text " )" append3 + swap annotation-node object. ; + +: value-str ( values -- str ) + length "x" " " join ; + +: effect-str ( node -- str ) + [ + dup node-in-d value-str % + "-" % + node-out-d value-str % + ] make-string ; + +M: #push node>quot ( node -- ) + node-out-d [ literal-value ] map % ; + +M: #drop node>quot ( node -- ) + node-in-d length dup 3 > [ + \ drop % + ] [ + { f drop 2drop 3drop } nth , + ] ifte ; + +DEFER: dataflow>quot + +M: #call node>quot ( node -- ) + dup node-param , dup effect-str , ; + +M: #call-label node>quot ( node -- ) + "#call-label: " over node-param word-name append , ; + +M: #label node>quot ( node -- ) + dup "#label: " over node-param word-name append , + node-children first dataflow>quot , \ call , ; + +M: #ifte node>quot ( node -- ) + dup "#ifte" , + node-children [ dataflow>quot ] map % \ ifte , ; + +M: #dispatch node>quot ( node -- ) + dup "#dispatch" , + node-children [ dataflow>quot ] map >vector % \ dispatch , ; + +M: #return node>quot ( node -- ) "#return" , ; + +M: #values node>quot ( node -- ) "#values" , ; + +M: #merge node>quot ( node -- ) "#merge" , ; + +: (dataflow>quot) ( node -- ) + [ dup node>quot node-successor (dataflow>quot) ] when* ; + +: dataflow>quot ( node -- quot ) + [ (dataflow>quot) ] make-list ; + +: dataflow. ( quot -- ) + #! Print dataflow IR for a word. + dataflow>quot prettyprint ; diff --git a/library/inference/values.factor b/library/inference/values.factor index c5e40e9a0d..58e86b21fc 100644 --- a/library/inference/values.factor +++ b/library/inference/values.factor @@ -4,12 +4,8 @@ IN: inference USING: generic kernel lists namespaces sequences unparser words ; GENERIC: value= ( literal value -- ? ) -GENERIC: value-class-and ( class value -- ) -SYMBOL: cloned -GENERIC: clone-value ( value -- value ) - -TUPLE: value class recursion safe? ; +TUPLE: value recursion safe? ; C: value ( recursion -- value ) [ t swap set-value-safe? ] keep @@ -17,62 +13,32 @@ C: value ( recursion -- value ) TUPLE: computed ; -C: computed ( class -- value ) - swap recursive-state get [ set-value-class ] keep - over set-delegate ; +C: computed ( -- value ) + recursive-state get over set-delegate ; M: computed value= ( literal value -- ? ) 2drop f ; -: failing-class-and ( class class -- class ) - 2dup class-and dup null = [ - -rot [ - word-name % " and " % word-name % - " do not intersect" % - ] make-string inference-warning - ] [ - 2nip - ] ifte ; - -M: computed value-class-and ( class value -- ) - [ - value-class failing-class-and - ] keep set-value-class ; - TUPLE: literal value ; C: literal ( obj rstate -- value ) - [ - >r [ >r dup class r> set-value-class ] keep - r> set-delegate - ] keep + [ >r r> set-delegate ] keep [ set-literal-value ] keep ; -M: literal clone-value ( value -- value ) ; - M: literal value= ( literal value -- ? ) literal-value = ; -M: literal value-class-and ( class value -- ) - value-class class-and drop ; - -M: literal set-value-class ( class value -- ) - 2drop ; - -M: computed clone-value ( value -- value ) - dup cloned get assq [ ] [ - dup clone [ swap cloned [ acons ] change ] keep - ] ?ifte ; - -M: computed literal-value ( value -- ) - "A literal value was expected where a computed value was" - " found: " rot unparse append3 inference-error ; - -: value-types ( value -- list ) - value-class builtin-supertypes ; - : >literal< ( literal -- rstate obj ) dup value-recursion swap literal-value ; +M: value literal-value ( value -- ) + "A literal value was expected where a computed value was found" + inference-error ; + +TUPLE: meet values ; + +C: meet ( values -- value ) + [ set-meet-values ] keep f over set-delegate ; + PREDICATE: tuple safe-literal ( obj -- ? ) dup literal? [ value-safe? ] [ drop f ] ifte ; diff --git a/library/inference/words.factor b/library/inference/words.factor index 7197fb82a1..7389034963 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -9,7 +9,7 @@ hashtables parser prettyprint ; [ pop-d 2drop ] each ; : produce-d ( typelist -- ) - [ push-d ] each ; + [ drop push-d ] each ; : consume/produce ( word effect -- ) #! Add a node to the dataflow graph that consumes and diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index 3ecabe8475..02d311c22d 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -12,8 +12,11 @@ SYMBOL: recursion-check GENERIC: prettyprint* ( indent obj -- indent ) +: object. ( str obj -- ) + presented swons unit format ; + : unparse. ( obj -- ) - dup unparse swap presented swons unit format ; + [ unparse ] keep object. ; M: object prettyprint* ( indent obj -- indent ) unparse. ; diff --git a/library/test/sequences.factor b/library/test/sequences.factor index 5211229b1f..e3b5a11774 100644 --- a/library/test/sequences.factor +++ b/library/test/sequences.factor @@ -58,3 +58,9 @@ USING: kernel lists math sequences strings test vectors ; [ "hello world how are you" ] [ { "hello" "world" "how" "are" "you" } " " join ] unit-test + +[ "" ] [ { } "" join ] unit-test + +[ { "three" "three" "two" "two" "one" "one" } ] +[ { "one" "two" "three" } { 1 2 3 } { 3 3 2 2 1 1 } subst ] +unit-test diff --git a/library/ui/editors.factor b/library/ui/editors.factor index d30c9cf356..5c0f5ac07d 100644 --- a/library/ui/editors.factor +++ b/library/ui/editors.factor @@ -54,6 +54,8 @@ TUPLE: editor line caret ; [[ [ "LEFT" ] [ [ left ] with-editor ] ]] [[ [ "RIGHT" ] [ [ right ] with-editor ] ]] [[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]] + [[ [ "HOME" ] [ [ home ] with-editor ] ]] + [[ [ "END" ] [ [ end ] with-editor ] ]] ] swap add-actions ; : ( -- caret ) diff --git a/library/ui/line-editor.factor b/library/ui/line-editor.factor index a05c9bb8e8..115b1c673f 100644 --- a/library/ui/line-editor.factor +++ b/library/ui/line-editor.factor @@ -117,3 +117,11 @@ SYMBOL: history-index : right ( -- ) #! Call this in the line editor scope. caret [ 1 + line-text get length min ] change ; + +: home ( -- ) + #! Call this in the line editor scope. + 0 caret set ; + +: end ( -- ) + #! Call this in the line editor scope. + line-text get length caret set ; From 03168a86e5402b19ac49468ae1aaa5a37ce755cf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 28 Jul 2005 00:13:11 +0000 Subject: [PATCH 018/178] dataflow optimizer work, phasing out 3list/3unlist --- CHANGES.html | 2 + TODO.FACTOR.txt | 4 +- library/alien/aliens.factor | 2 +- library/bootstrap/boot-stage2.factor | 2 + library/bootstrap/primitives.factor | 366 +++++++++--------- library/collections/cons.factor | 4 +- library/collections/hashtables.factor | 4 +- library/collections/sbuf.factor | 4 +- library/collections/sequences-epilogue.factor | 44 +-- library/collections/strings.factor | 2 +- library/collections/vectors.factor | 4 +- library/compiler/intrinsics.factor | 10 +- library/compiler/linearizer.factor | 5 +- library/compiler/vops.factor | 20 +- library/generic/slots.factor | 8 +- library/generic/tuple.factor | 18 +- library/help/tutorial.factor | 12 +- library/httpd/html.factor | 11 +- library/inference/branches.factor | 21 +- library/inference/dataflow.factor | 8 +- library/inference/inference.factor | 17 +- library/inference/optimizer.factor | 104 ++--- library/inference/print-dataflow.factor | 6 +- library/inference/words.factor | 2 +- library/math/complex.factor | 2 +- library/math/ratio.factor | 2 +- library/sdl/sdl-utils.factor | 4 +- library/styles.factor | 12 +- library/test/inference.factor | 214 +++++----- library/test/lists/combinators.factor | 4 +- library/test/lists/cons.factor | 3 - library/test/sequences.factor | 5 + library/ui/buttons.factor | 2 +- library/ui/fonts.factor | 6 +- library/ui/panes.factor | 15 +- library/ui/presentations.factor | 4 +- library/ui/scrolling.factor | 4 +- library/ui/text.factor | 2 +- library/ui/ui.factor | 10 +- library/words.factor | 6 +- 40 files changed, 488 insertions(+), 487 deletions(-) diff --git a/CHANGES.html b/CHANGES.html index f6c4a319f9..7a1b96ca75 100644 --- a/CHANGES.html +++ b/CHANGES.html @@ -14,6 +14,8 @@
  • join ( seq glue -- seq ) combinator. Takes a sequence of sequences, and constructs a new sequence with the glue in between each sequence. For example: 
      [ "usr" "bin" "grep" ] "/" join
 "usr/bin/grep"
    • +
  • indq ( elt seq -- i ) and indq* ( i elt seq -- i ) are like index and index*, except they compare elements for identity.
    • +
  • Integers now support the sequence protocol. An integer is an increasing sequence of its predecessors. This means the count ( n -- [ 0 ... n-1 ] ) word is gone; just use >vector instead. Also, project has been made redundant by map.
diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index d3636a2076..543828e71c 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -64,15 +64,15 @@ - merge inc-d's across VOPs that don't touch the stack - intrinsic char-slot set-char-slot integer-slot set-integer-slot - [ [ dup call ] dup call ] infer hangs -- more accurate types for various words - declarations -- type inference fails with some assembler words; displaced, register and other predicates need to inherit from list not cons, and need stronger branch partial eval - optimize away arithmetic dispatch - the invalid recursion form case needs to be fixed, for inlines too - #jump-f #jump-f-label - re-introduce #target-label => #target optimization +- recursion is iffy; no base case needs to throw an error, and if the + stack at the recursive call doesn't match up, throw an error + sequences diff --git a/library/alien/aliens.factor b/library/alien/aliens.factor index 5808e7f3b7..d1d83cc184 100644 --- a/library/alien/aliens.factor +++ b/library/alien/aliens.factor @@ -5,7 +5,7 @@ USING: hashtables io kernel kernel-internals lists math namespaces parser ; DEFER: dll? -BUILTIN: dll 15 dll? [ 1 "dll-path" f ] ; +BUILTIN: dll 15 dll? { 1 "dll-path" f } ; DEFER: alien? BUILTIN: alien 16 alien? ; diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index e2fca26979..ea713c7541 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -18,6 +18,8 @@ words ; "Loading compiler backend..." print cpu "x86" = [ + "/library/compiler/vops.factor" + "/library/compiler/intrinsics.factor" "/library/compiler/x86/assembler.factor" "/library/compiler/x86/generator.factor" "/library/compiler/x86/slots.factor" diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index a73264b410..20063c5984 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -26,201 +26,201 @@ vocabularies get [ reveal ] bind -: set-stack-effect ( [ vocab word effect ] -- ) - 3unlist >r unit search r> dup string? [ +: set-stack-effect ( { vocab word effect } -- ) + 3unseq >r unit search r> dup string? [ "stack-effect" set-word-prop ] [ "infer-effect" set-word-prop ] ifte ; -: make-primitive ( n [ vocab word effect ] -- n ) - [ 2unlist create >r 1 + r> over f define ] keep +: make-primitive ( n { vocab word effect } -- n ) + [ 2unseq create >r 1 + r> over f define ] keep set-stack-effect ; -2 [ - [ "execute" "words" [ [ word ] [ ] ] ] - [ "call" "kernel" [ [ general-list ] [ ] ] ] - [ "ifte" "kernel" [ [ object general-list general-list ] [ ] ] ] - [ "dispatch" "kernel-internals" [ [ fixnum vector ] [ ] ] ] - [ "cons" "lists" [ [ object object ] [ cons ] ] ] - [ "" "vectors" [ [ integer ] [ vector ] ] ] - [ "rehash-string" "strings" [ [ string ] [ ] ] ] - [ "" "strings" [ [ integer ] [ sbuf ] ] ] - [ "sbuf>string" "strings" [ [ sbuf ] [ string ] ] ] - [ "arithmetic-type" "math-internals" [ [ object object ] [ object object fixnum ] ] ] - [ ">fixnum" "math" [ [ number ] [ fixnum ] ] ] - [ ">bignum" "math" [ [ number ] [ bignum ] ] ] - [ ">float" "math" [ [ number ] [ float ] ] ] - [ "(fraction>)" "math-internals" [ [ integer integer ] [ rational ] ] ] - [ "str>float" "parser" [ [ string ] [ float ] ] ] - [ "(unparse-float)" "unparser" [ [ float ] [ string ] ] ] - [ "float>bits" "math" [ [ real ] [ integer ] ] ] - [ "double>bits" "math" [ [ real ] [ integer ] ] ] - [ "bits>float" "math" [ [ integer ] [ float ] ] ] - [ "bits>double" "math" [ [ integer ] [ float ] ] ] - [ "" "math-internals" [ [ real real ] [ number ] ] ] - [ "fixnum+" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ] - [ "fixnum-" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ] - [ "fixnum*" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ] - [ "fixnum/i" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ] - [ "fixnum/f" "math-internals" [ [ fixnum fixnum ] [ integer ] ] ] - [ "fixnum-mod" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] ] - [ "fixnum/mod" "math-internals" [ [ fixnum fixnum ] [ integer fixnum ] ] ] - [ "fixnum-bitand" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] ] - [ "fixnum-bitor" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] ] - [ "fixnum-bitxor" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] ] - [ "fixnum-bitnot" "math-internals" [ [ fixnum ] [ fixnum ] ] ] - [ "fixnum-shift" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] ] - [ "fixnum<" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] ] - [ "fixnum<=" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] ] - [ "fixnum>" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] ] - [ "fixnum>=" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] ] - [ "bignum=" "math-internals" [ [ bignum bignum ] [ boolean ] ] ] - [ "bignum+" "math-internals" [ [ bignum bignum ] [ bignum ] ] ] - [ "bignum-" "math-internals" [ [ bignum bignum ] [ bignum ] ] ] - [ "bignum*" "math-internals" [ [ bignum bignum ] [ bignum ] ] ] - [ "bignum/i" "math-internals" [ [ bignum bignum ] [ bignum ] ] ] - [ "bignum/f" "math-internals" [ [ bignum bignum ] [ bignum ] ] ] - [ "bignum-mod" "math-internals" [ [ bignum bignum ] [ bignum ] ] ] - [ "bignum/mod" "math-internals" [ [ bignum bignum ] [ bignum bignum ] ] ] - [ "bignum-bitand" "math-internals" [ [ bignum bignum ] [ bignum ] ] ] - [ "bignum-bitor" "math-internals" [ [ bignum bignum ] [ bignum ] ] ] - [ "bignum-bitxor" "math-internals" [ [ bignum bignum ] [ bignum ] ] ] - [ "bignum-bitnot" "math-internals" [ [ bignum ] [ bignum ] ] ] - [ "bignum-shift" "math-internals" [ [ bignum bignum ] [ bignum ] ] ] - [ "bignum<" "math-internals" [ [ bignum bignum ] [ boolean ] ] ] - [ "bignum<=" "math-internals" [ [ bignum bignum ] [ boolean ] ] ] - [ "bignum>" "math-internals" [ [ bignum bignum ] [ boolean ] ] ] - [ "bignum>=" "math-internals" [ [ bignum bignum ] [ boolean ] ] ] - [ "float=" "math-internals" [ [ bignum bignum ] [ boolean ] ] ] - [ "float+" "math-internals" [ [ float float ] [ float ] ] ] - [ "float-" "math-internals" [ [ float float ] [ float ] ] ] - [ "float*" "math-internals" [ [ float float ] [ float ] ] ] - [ "float/f" "math-internals" [ [ float float ] [ float ] ] ] - [ "float<" "math-internals" [ [ float float ] [ boolean ] ] ] - [ "float<=" "math-internals" [ [ float float ] [ boolean ] ] ] - [ "float>" "math-internals" [ [ float float ] [ boolean ] ] ] - [ "float>=" "math-internals" [ [ float float ] [ boolean ] ] ] - [ "facos" "math-internals" [ [ real ] [ float ] ] ] - [ "fasin" "math-internals" [ [ real ] [ float ] ] ] - [ "fatan" "math-internals" [ [ real ] [ float ] ] ] - [ "fatan2" "math-internals" [ [ real real ] [ float ] ] ] - [ "fcos" "math-internals" [ [ real ] [ float ] ] ] - [ "fexp" "math-internals" [ [ real ] [ float ] ] ] - [ "fcosh" "math-internals" [ [ real ] [ float ] ] ] - [ "flog" "math-internals" [ [ real ] [ float ] ] ] - [ "fpow" "math-internals" [ [ real real ] [ float ] ] ] - [ "fsin" "math-internals" [ [ real ] [ float ] ] ] - [ "fsinh" "math-internals" [ [ real ] [ float ] ] ] - [ "fsqrt" "math-internals" [ [ real ] [ float ] ] ] - [ "" "words" [ [ ] [ word ] ] ] - [ "update-xt" "words" [ [ word ] [ ] ] ] - [ "compiled?" "words" [ [ word ] [ boolean ] ] ] - [ "drop" "kernel" [ [ object ] [ ] ] ] - [ "dup" "kernel" [ [ object ] [ object object ] ] ] - [ "swap" "kernel" [ [ object object ] [ object object ] ] ] - [ "over" "kernel" [ [ object object ] [ object object object ] ] ] - [ "pick" "kernel" [ [ object object object ] [ object object object object ] ] ] - [ ">r" "kernel" [ [ object ] [ ] ] ] - [ "r>" "kernel" [ [ ] [ object ] ] ] - [ "eq?" "kernel" [ [ object object ] [ boolean ] ] ] - [ "getenv" "kernel-internals" [ [ fixnum ] [ object ] ] ] - [ "setenv" "kernel-internals" [ [ object fixnum ] [ ] ] ] - [ "stat" "io" [ [ string ] [ general-list ] ] ] - [ "(directory)" "io" [ [ string ] [ general-list ] ] ] - [ "gc" "memory" [ [ fixnum ] [ ] ] ] - [ "gc-time" "memory" [ [ string ] [ ] ] ] - [ "save-image" "memory" [ [ string ] [ ] ] ] - [ "datastack" "kernel" " -- ds " ] - [ "callstack" "kernel" " -- cs " ] - [ "set-datastack" "kernel" " ds -- " ] - [ "set-callstack" "kernel" " cs -- " ] - [ "exit" "kernel" [ [ integer ] [ ] ] ] - [ "room" "memory" [ [ ] [ integer integer integer integer general-list ] ] ] - [ "os-env" "kernel" [ [ string ] [ object ] ] ] - [ "millis" "kernel" [ [ ] [ integer ] ] ] - [ "(random-int)" "math" [ [ ] [ integer ] ] ] - [ "type" "kernel" [ [ object ] [ fixnum ] ] ] - [ "cwd" "io" [ [ ] [ string ] ] ] - [ "cd" "io" [ [ string ] [ ] ] ] - [ "compiled-offset" "assembler" [ [ ] [ integer ] ] ] - [ "set-compiled-offset" "assembler" [ [ integer ] [ ] ] ] - [ "literal-top" "assembler" [ [ ] [ integer ] ] ] - [ "set-literal-top" "assembler" [ [ integer ] [ ] ] ] - [ "address" "memory" [ [ object ] [ integer ] ] ] - [ "dlopen" "alien" [ [ string ] [ dll ] ] ] - [ "dlsym" "alien" [ [ string object ] [ integer ] ] ] - [ "dlclose" "alien" [ [ dll ] [ ] ] ] - [ "" "alien" [ [ integer ] [ alien ] ] ] - [ "" "kernel-internals" [ [ integer ] [ byte-array ] ] ] - [ "" "alien" [ [ integer c-ptr ] [ displaced-alien ] ] ] - [ "alien-signed-cell" "alien" [ [ c-ptr integer ] [ integer ] ] ] - [ "set-alien-signed-cell" "alien" [ [ integer c-ptr integer ] [ ] ] ] - [ "alien-unsigned-cell" "alien" [ [ c-ptr integer ] [ integer ] ] ] - [ "set-alien-unsigned-cell" "alien" [ [ integer c-ptr integer ] [ ] ] ] - [ "alien-signed-8" "alien" [ [ c-ptr integer ] [ integer ] ] ] - [ "set-alien-signed-8" "alien" [ [ integer c-ptr integer ] [ ] ] ] - [ "alien-unsigned-8" "alien" [ [ c-ptr integer ] [ integer ] ] ] - [ "set-alien-unsigned-8" "alien" [ [ integer c-ptr integer ] [ ] ] ] - [ "alien-signed-4" "alien" [ [ c-ptr integer ] [ integer ] ] ] - [ "set-alien-signed-4" "alien" [ [ integer c-ptr integer ] [ ] ] ] - [ "alien-unsigned-4" "alien" [ [ c-ptr integer ] [ integer ] ] ] - [ "set-alien-unsigned-4" "alien" [ [ integer c-ptr integer ] [ ] ] ] - [ "alien-signed-2" "alien" [ [ c-ptr integer ] [ integer ] ] ] - [ "set-alien-signed-2" "alien" [ [ integer c-ptr integer ] [ ] ] ] - [ "alien-unsigned-2" "alien" [ [ c-ptr integer ] [ integer ] ] ] - [ "set-alien-unsigned-2" "alien" [ [ integer c-ptr integer ] [ ] ] ] - [ "alien-signed-1" "alien" [ [ c-ptr integer ] [ integer ] ] ] - [ "set-alien-signed-1" "alien" [ [ integer c-ptr integer ] [ ] ] ] - [ "alien-unsigned-1" "alien" [ [ c-ptr integer ] [ integer ] ] ] - [ "set-alien-unsigned-1" "alien" [ [ integer c-ptr integer ] [ ] ] ] - [ "alien-float" "alien" [ [ c-ptr integer ] [ float ] ] ] - [ "set-alien-float" "alien" [ [ float c-ptr integer ] [ ] ] ] - [ "alien-double" "alien" [ [ c-ptr integer ] [ float ] ] ] - [ "set-alien-double" "alien" [ [ float c-ptr integer ] [ ] ] ] - [ "alien-c-string" "alien" [ [ c-ptr integer ] [ string ] ] ] - [ "set-alien-c-string" "alien" [ [ string c-ptr integer ] [ ] ] ] - [ "throw" "errors" [ [ object ] [ ] ] ] - [ "string>memory" "kernel-internals" [ [ string integer ] [ ] ] ] - [ "memory>string" "kernel-internals" [ [ integer integer ] [ string ] ] ] - [ "alien-address" "alien" [ [ alien ] [ integer ] ] ] - [ "slot" "kernel-internals" [ [ object fixnum ] [ object ] ] ] - [ "set-slot" "kernel-internals" [ [ object object fixnum ] [ ] ] ] - [ "integer-slot" "kernel-internals" [ [ object fixnum ] [ integer ] ] ] - [ "set-integer-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] ] - [ "char-slot" "kernel-internals" [ [ object fixnum ] [ fixnum ] ] ] - [ "set-char-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] ] - [ "resize-array" "kernel-internals" [ [ integer array ] [ array ] ] ] - [ "resize-string" "strings" [ [ integer string ] [ string ] ] ] - [ "" "hashtables" [ [ number ] [ hashtable ] ] ] - [ "" "kernel-internals" [ [ number ] [ array ] ] ] - [ "" "kernel-internals" [ [ number ] [ tuple ] ] ] - [ "begin-scan" "memory" [ [ ] [ ] ] ] - [ "next-object" "memory" [ [ ] [ object ] ] ] - [ "end-scan" "memory" [ [ ] [ ] ] ] - [ "size" "memory" [ [ object ] [ fixnum ] ] ] - [ "die" "kernel" [ [ ] [ ] ] ] - [ "flush-icache" "assembler" f ] +2 { + { "execute" "words" [ [ word ] [ ] ] } + { "call" "kernel" [ [ general-list ] [ ] ] } + { "ifte" "kernel" [ [ object general-list general-list ] [ ] ] } + { "dispatch" "kernel-internals" [ [ fixnum vector ] [ ] ] } + { "cons" "lists" [ [ object object ] [ cons ] ] } + { "" "vectors" [ [ integer ] [ vector ] ] } + { "rehash-string" "strings" [ [ string ] [ ] ] } + { "" "strings" [ [ integer ] [ sbuf ] ] } + { "sbuf>string" "strings" [ [ sbuf ] [ string ] ] } + { "arithmetic-type" "math-internals" [ [ object object ] [ object object fixnum ] ] } + { ">fixnum" "math" [ [ number ] [ fixnum ] ] } + { ">bignum" "math" [ [ number ] [ bignum ] ] } + { ">float" "math" [ [ number ] [ float ] ] } + { "(fraction>)" "math-internals" [ [ integer integer ] [ rational ] ] } + { "str>float" "parser" [ [ string ] [ float ] ] } + { "(unparse-float)" "unparser" [ [ float ] [ string ] ] } + { "float>bits" "math" [ [ real ] [ integer ] ] } + { "double>bits" "math" [ [ real ] [ integer ] ] } + { "bits>float" "math" [ [ integer ] [ float ] ] } + { "bits>double" "math" [ [ integer ] [ float ] ] } + { "" "math-internals" [ [ real real ] [ number ] ] } + { "fixnum+" "math-internals" [ [ fixnum fixnum ] [ integer ] ] } + { "fixnum-" "math-internals" [ [ fixnum fixnum ] [ integer ] ] } + { "fixnum*" "math-internals" [ [ fixnum fixnum ] [ integer ] ] } + { "fixnum/i" "math-internals" [ [ fixnum fixnum ] [ integer ] ] } + { "fixnum/f" "math-internals" [ [ fixnum fixnum ] [ integer ] ] } + { "fixnum-mod" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] } + { "fixnum/mod" "math-internals" [ [ fixnum fixnum ] [ integer fixnum ] ] } + { "fixnum-bitand" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] } + { "fixnum-bitor" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] } + { "fixnum-bitxor" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] } + { "fixnum-bitnot" "math-internals" [ [ fixnum ] [ fixnum ] ] } + { "fixnum-shift" "math-internals" [ [ fixnum fixnum ] [ fixnum ] ] } + { "fixnum<" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] } + { "fixnum<=" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] } + { "fixnum>" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] } + { "fixnum>=" "math-internals" [ [ fixnum fixnum ] [ boolean ] ] } + { "bignum=" "math-internals" [ [ bignum bignum ] [ boolean ] ] } + { "bignum+" "math-internals" [ [ bignum bignum ] [ bignum ] ] } + { "bignum-" "math-internals" [ [ bignum bignum ] [ bignum ] ] } + { "bignum*" "math-internals" [ [ bignum bignum ] [ bignum ] ] } + { "bignum/i" "math-internals" [ [ bignum bignum ] [ bignum ] ] } + { "bignum/f" "math-internals" [ [ bignum bignum ] [ bignum ] ] } + { "bignum-mod" "math-internals" [ [ bignum bignum ] [ bignum ] ] } + { "bignum/mod" "math-internals" [ [ bignum bignum ] [ bignum bignum ] ] } + { "bignum-bitand" "math-internals" [ [ bignum bignum ] [ bignum ] ] } + { "bignum-bitor" "math-internals" [ [ bignum bignum ] [ bignum ] ] } + { "bignum-bitxor" "math-internals" [ [ bignum bignum ] [ bignum ] ] } + { "bignum-bitnot" "math-internals" [ [ bignum ] [ bignum ] ] } + { "bignum-shift" "math-internals" [ [ bignum bignum ] [ bignum ] ] } + { "bignum<" "math-internals" [ [ bignum bignum ] [ boolean ] ] } + { "bignum<=" "math-internals" [ [ bignum bignum ] [ boolean ] ] } + { "bignum>" "math-internals" [ [ bignum bignum ] [ boolean ] ] } + { "bignum>=" "math-internals" [ [ bignum bignum ] [ boolean ] ] } + { "float=" "math-internals" [ [ bignum bignum ] [ boolean ] ] } + { "float+" "math-internals" [ [ float float ] [ float ] ] } + { "float-" "math-internals" [ [ float float ] [ float ] ] } + { "float*" "math-internals" [ [ float float ] [ float ] ] } + { "float/f" "math-internals" [ [ float float ] [ float ] ] } + { "float<" "math-internals" [ [ float float ] [ boolean ] ] } + { "float<=" "math-internals" [ [ float float ] [ boolean ] ] } + { "float>" "math-internals" [ [ float float ] [ boolean ] ] } + { "float>=" "math-internals" [ [ float float ] [ boolean ] ] } + { "facos" "math-internals" [ [ real ] [ float ] ] } + { "fasin" "math-internals" [ [ real ] [ float ] ] } + { "fatan" "math-internals" [ [ real ] [ float ] ] } + { "fatan2" "math-internals" [ [ real real ] [ float ] ] } + { "fcos" "math-internals" [ [ real ] [ float ] ] } + { "fexp" "math-internals" [ [ real ] [ float ] ] } + { "fcosh" "math-internals" [ [ real ] [ float ] ] } + { "flog" "math-internals" [ [ real ] [ float ] ] } + { "fpow" "math-internals" [ [ real real ] [ float ] ] } + { "fsin" "math-internals" [ [ real ] [ float ] ] } + { "fsinh" "math-internals" [ [ real ] [ float ] ] } + { "fsqrt" "math-internals" [ [ real ] [ float ] ] } + { "" "words" [ [ ] [ word ] ] } + { "update-xt" "words" [ [ word ] [ ] ] } + { "compiled?" "words" [ [ word ] [ boolean ] ] } + { "drop" "kernel" [ [ object ] [ ] ] } + { "dup" "kernel" [ [ object ] [ object object ] ] } + { "swap" "kernel" [ [ object object ] [ object object ] ] } + { "over" "kernel" [ [ object object ] [ object object object ] ] } + { "pick" "kernel" [ [ object object object ] [ object object object object ] ] } + { ">r" "kernel" [ [ object ] [ ] ] } + { "r>" "kernel" [ [ ] [ object ] ] } + { "eq?" "kernel" [ [ object object ] [ boolean ] ] } + { "getenv" "kernel-internals" [ [ fixnum ] [ object ] ] } + { "setenv" "kernel-internals" [ [ object fixnum ] [ ] ] } + { "stat" "io" [ [ string ] [ general-list ] ] } + { "(directory)" "io" [ [ string ] [ general-list ] ] } + { "gc" "memory" [ [ fixnum ] [ ] ] } + { "gc-time" "memory" [ [ string ] [ ] ] } + { "save-image" "memory" [ [ string ] [ ] ] } + { "datastack" "kernel" " -- ds " } + { "callstack" "kernel" " -- cs " } + { "set-datastack" "kernel" " ds -- " } + { "set-callstack" "kernel" " cs -- " } + { "exit" "kernel" [ [ integer ] [ ] ] } + { "room" "memory" [ [ ] [ integer integer integer integer general-list ] ] } + { "os-env" "kernel" [ [ string ] [ object ] ] } + { "millis" "kernel" [ [ ] [ integer ] ] } + { "(random-int)" "math" [ [ ] [ integer ] ] } + { "type" "kernel" [ [ object ] [ fixnum ] ] } + { "cwd" "io" [ [ ] [ string ] ] } + { "cd" "io" [ [ string ] [ ] ] } + { "compiled-offset" "assembler" [ [ ] [ integer ] ] } + { "set-compiled-offset" "assembler" [ [ integer ] [ ] ] } + { "literal-top" "assembler" [ [ ] [ integer ] ] } + { "set-literal-top" "assembler" [ [ integer ] [ ] ] } + { "address" "memory" [ [ object ] [ integer ] ] } + { "dlopen" "alien" [ [ string ] [ dll ] ] } + { "dlsym" "alien" [ [ string object ] [ integer ] ] } + { "dlclose" "alien" [ [ dll ] [ ] ] } + { "" "alien" [ [ integer ] [ alien ] ] } + { "" "kernel-internals" [ [ integer ] [ byte-array ] ] } + { "" "alien" [ [ integer c-ptr ] [ displaced-alien ] ] } + { "alien-signed-cell" "alien" [ [ c-ptr integer ] [ integer ] ] } + { "set-alien-signed-cell" "alien" [ [ integer c-ptr integer ] [ ] ] } + { "alien-unsigned-cell" "alien" [ [ c-ptr integer ] [ integer ] ] } + { "set-alien-unsigned-cell" "alien" [ [ integer c-ptr integer ] [ ] ] } + { "alien-signed-8" "alien" [ [ c-ptr integer ] [ integer ] ] } + { "set-alien-signed-8" "alien" [ [ integer c-ptr integer ] [ ] ] } + { "alien-unsigned-8" "alien" [ [ c-ptr integer ] [ integer ] ] } + { "set-alien-unsigned-8" "alien" [ [ integer c-ptr integer ] [ ] ] } + { "alien-signed-4" "alien" [ [ c-ptr integer ] [ integer ] ] } + { "set-alien-signed-4" "alien" [ [ integer c-ptr integer ] [ ] ] } + { "alien-unsigned-4" "alien" [ [ c-ptr integer ] [ integer ] ] } + { "set-alien-unsigned-4" "alien" [ [ integer c-ptr integer ] [ ] ] } + { "alien-signed-2" "alien" [ [ c-ptr integer ] [ integer ] ] } + { "set-alien-signed-2" "alien" [ [ integer c-ptr integer ] [ ] ] } + { "alien-unsigned-2" "alien" [ [ c-ptr integer ] [ integer ] ] } + { "set-alien-unsigned-2" "alien" [ [ integer c-ptr integer ] [ ] ] } + { "alien-signed-1" "alien" [ [ c-ptr integer ] [ integer ] ] } + { "set-alien-signed-1" "alien" [ [ integer c-ptr integer ] [ ] ] } + { "alien-unsigned-1" "alien" [ [ c-ptr integer ] [ integer ] ] } + { "set-alien-unsigned-1" "alien" [ [ integer c-ptr integer ] [ ] ] } + { "alien-float" "alien" [ [ c-ptr integer ] [ float ] ] } + { "set-alien-float" "alien" [ [ float c-ptr integer ] [ ] ] } + { "alien-double" "alien" [ [ c-ptr integer ] [ float ] ] } + { "set-alien-double" "alien" [ [ float c-ptr integer ] [ ] ] } + { "alien-c-string" "alien" [ [ c-ptr integer ] [ string ] ] } + { "set-alien-c-string" "alien" [ [ string c-ptr integer ] [ ] ] } + { "throw" "errors" [ [ object ] [ ] ] } + { "string>memory" "kernel-internals" [ [ string integer ] [ ] ] } + { "memory>string" "kernel-internals" [ [ integer integer ] [ string ] ] } + { "alien-address" "alien" [ [ alien ] [ integer ] ] } + { "slot" "kernel-internals" [ [ object fixnum ] [ object ] ] } + { "set-slot" "kernel-internals" [ [ object object fixnum ] [ ] ] } + { "integer-slot" "kernel-internals" [ [ object fixnum ] [ integer ] ] } + { "set-integer-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] } + { "char-slot" "kernel-internals" [ [ object fixnum ] [ fixnum ] ] } + { "set-char-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] } + { "resize-array" "kernel-internals" [ [ integer array ] [ array ] ] } + { "resize-string" "strings" [ [ integer string ] [ string ] ] } + { "" "hashtables" [ [ number ] [ hashtable ] ] } + { "" "kernel-internals" [ [ number ] [ array ] ] } + { "" "kernel-internals" [ [ number ] [ tuple ] ] } + { "begin-scan" "memory" [ [ ] [ ] ] } + { "next-object" "memory" [ [ ] [ object ] ] } + { "end-scan" "memory" [ [ ] [ ] ] } + { "size" "memory" [ [ object ] [ fixnum ] ] } + { "die" "kernel" [ [ ] [ ] ] } + { "flush-icache" "assembler" f } [ "fopen" "io-internals" [ [ string string ] [ alien ] ] ] - [ "fgetc" "io-internals" [ [ alien ] [ object ] ] ] - [ "fwrite" "io-internals" [ [ string alien ] [ ] ] ] - [ "fflush" "io-internals" [ [ alien ] [ ] ] ] - [ "fclose" "io-internals" [ [ alien ] [ ] ] ] - [ "expired?" "alien" [ [ object ] [ boolean ] ] ] -] [ + { "fgetc" "io-internals" [ [ alien ] [ object ] ] } + { "fwrite" "io-internals" [ [ string alien ] [ ] ] } + { "fflush" "io-internals" [ [ alien ] [ ] ] } + { "fclose" "io-internals" [ [ alien ] [ ] ] } + { "expired?" "alien" [ [ object ] [ boolean ] ] } +} [ make-primitive ] each drop ! These need a more descriptive comment. -[ - [ "drop" "kernel" " x -- " ] - [ "dup" "kernel" " x -- x x " ] - [ "swap" "kernel" " x y -- y x " ] - [ "over" "kernel" " x y -- x y x " ] - [ "pick" "kernel" " x y z -- x y z x " ] - [ ">r" "kernel" " x -- r: x " ] - [ "r>" "kernel" " r: x -- x " ] -] [ +{ + { "drop" "kernel" " x -- " } + { "dup" "kernel" " x -- x x " } + { "swap" "kernel" " x y -- y x " } + { "over" "kernel" " x y -- x y x " } + { "pick" "kernel" " x y z -- x y z x " } + { ">r" "kernel" " x -- r: x " } + { "r>" "kernel" " r: x -- x " } +} [ set-stack-effect ] each diff --git a/library/collections/cons.factor b/library/collections/cons.factor index 26e8fb1393..f81820b1da 100644 --- a/library/collections/cons.factor +++ b/library/collections/cons.factor @@ -7,7 +7,7 @@ IN: lists USING: generic kernel sequences ; ! lists.factor has everything else. DEFER: cons? -BUILTIN: cons 2 cons? [ 0 "car" f ] [ 1 "cdr" f ] ; +BUILTIN: cons 2 cons? { 0 "car" f } { 1 "cdr" f } ; ! We borrow an idiom from Common Lisp. The car/cdr of an empty ! list is the empty list. @@ -34,9 +34,7 @@ PREDICATE: general-list list ( list -- ? ) : swons ( cdr car -- [[ car cdr ]] ) swap cons ; : unit ( a -- [ a ] ) f cons ; : 2list ( a b -- [ a b ] ) unit cons ; -: 3list ( a b c -- [ a b c ] ) 2list cons ; : 2unlist ( [ a b ] -- a b ) uncons car ; -: 3unlist ( [ a b c ] -- a b c ) uncons uncons car ; : 2car ( cons cons -- car car ) swap car swap car ; : 2cdr ( cons cons -- car car ) swap cdr swap cdr ; diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index d8b74c6ede..0282a82882 100644 --- a/library/collections/hashtables.factor +++ b/library/collections/hashtables.factor @@ -13,8 +13,8 @@ USING: generic kernel lists math sequences vectors ; ! the other words in kernel-internals. DEFER: hashtable? BUILTIN: hashtable 10 hashtable? - [ 1 "hash-size" set-hash-size ] - [ 2 hash-array set-hash-array ] ; + { 1 "hash-size" set-hash-size } + { 2 hash-array set-hash-array } ; ! A hashtable is implemented as an array of buckets. The ! array index is determined using a hash function, and the diff --git a/library/collections/sbuf.factor b/library/collections/sbuf.factor index 29025ba397..a31fb0efe4 100644 --- a/library/collections/sbuf.factor +++ b/library/collections/sbuf.factor @@ -12,8 +12,8 @@ M: string resize resize-string ; DEFER: sbuf? BUILTIN: sbuf 13 sbuf? - [ 1 length set-capacity ] - [ 2 underlying set-underlying ] ; + { 1 length set-capacity } + { 2 underlying set-underlying } ; M: sbuf set-length ( n sbuf -- ) grow-length ; diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 4febc4ca6f..1ab81fca32 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -117,30 +117,14 @@ M: object empty? ( seq -- ? ) length 0 = ; M: object >list ( seq -- list ) dup length 0 rot (>list) ; -: index* ( obj i seq -- n ) - #! The index of the object in the sequence, starting from i. - [ = ] find-with* drop ; - -: index ( obj seq -- n ) - #! The index of the object in the sequence. - [ = ] find-with drop ; - -: member? ( obj seq -- ? ) - #! Tests for membership using =. - [ = ] contains-with? ; - -: memq? ( obj seq -- ? ) - #! Tests for membership using eq? - [ eq? ] contains-with? ; - -: remove ( obj list -- list ) - #! Remove all occurrences of objects equal to this one from - #! the list. - [ = not ] subset-with ; - -: remq ( obj list -- list ) - #! Remove all occurrences of the object from the list. - [ eq? not ] subset-with ; +: index ( obj seq -- n ) [ = ] find-with drop ; +: indq ( obj seq -- n ) [ eq? ] find-with drop ; +: index* ( obj i seq -- n ) [ = ] find-with* drop ; +: indq* ( obj i seq -- n ) [ eq? ] find-with* drop ; +: member? ( obj seq -- ? ) [ = ] contains-with? ; +: memq? ( obj seq -- ? ) [ eq? ] contains-with? ; +: remove ( obj list -- list ) [ = not ] subset-with ; +: remq ( obj list -- list ) [ eq? not ] subset-with ; : nappend ( s1 s2 -- ) #! Destructively append s2 to s1. @@ -238,10 +222,12 @@ M: object reverse ( seq -- seq ) [ ] keep like ; #! lexicographically. lexi 0 > ; -: seq-transpose ( seq -- list ) +: seq-transpose ( seq -- seq ) #! An example illustrates this word best: #! { { 1 2 3 } { 4 5 6 } } ==> { { 1 2 } { 3 4 } { 5 6 } } - dup first length [ swap [ nth ] map-with ] map-with ; + dup empty? [ + dup first length [ swap [ nth ] map-with ] map-with + ] unless ; : max-length ( seq -- n ) #! Longest sequence length in a sequence of sequences. @@ -251,10 +237,12 @@ M: object reverse ( seq -- seq ) [ ] keep like ; #! Substitute elements of old in seq with corresponding #! elements from new. [ - dup pick index dup -1 = - [ drop ] [ nip pick nth ] ifte + dup pick indq dup -1 = [ drop ] [ nip pick nth ] ifte ] map 2nip ; +: copy-into ( to from -- ) + dup length [ pick set-nth ] 2each drop ; + IN: kernel : depth ( -- n ) diff --git a/library/collections/strings.factor b/library/collections/strings.factor index 871f2e6fe8..da9512f323 100644 --- a/library/collections/strings.factor +++ b/library/collections/strings.factor @@ -5,7 +5,7 @@ USING: generic kernel kernel-internals lists math sequences ; ! Strings DEFER: string? -BUILTIN: string 12 string? [ 1 length f ] [ 2 hashcode f ] ; +BUILTIN: string 12 string? { 1 length f } { 2 hashcode f } ; M: string nth ( n str -- ch ) bounds-check char-slot ; diff --git a/library/collections/vectors.factor b/library/collections/vectors.factor index 6b1498b0e5..2ad9ddd90e 100644 --- a/library/collections/vectors.factor +++ b/library/collections/vectors.factor @@ -6,8 +6,8 @@ math-internals sequences ; DEFER: vector? BUILTIN: vector 11 vector? - [ 1 length set-capacity ] - [ 2 underlying set-underlying ] ; + { 1 length set-capacity } + { 2 underlying set-underlying } ; M: vector set-length ( len vec -- ) grow-length ; diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index 96701798c5..56cecf237c 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -3,7 +3,7 @@ IN: compiler-frontend USING: assembler compiler-backend generic hashtables inference kernel kernel-internals lists math math-internals namespaces -sequences words ; +sequences vectors words ; ! Architecture description : fixnum-imm? @@ -138,19 +138,19 @@ sequences words ; : value/vreg-list ( in -- list ) [ 0 swap length 1 - ] keep - [ >r 2dup r> 3list >r 1 - >r 1 + r> r> ] map 2nip ; + [ >r 2dup r> 3vector >r 1 - >r 1 + r> r> ] map 2nip ; : values>vregs ( in -- in ) value/vreg-list - dup [ 3unlist load-value ] each - [ car ] map ; + dup [ 3unseq load-value ] each + [ first ] map ; : load-inputs ( node -- in ) dup node-in-d values>vregs [ length swap node-out-d length - %dec-d , ] keep ; : binary-op-reg ( node op -- ) - >r load-inputs 2unlist swap dup r> execute , + >r load-inputs 2unseq swap dup r> execute , 0 0 %replace-d , ; inline : literal-fixnum? ( value -- ? ) diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor index d9f16b89c2..9a9cedeee8 100644 --- a/library/compiler/linearizer.factor +++ b/library/compiler/linearizer.factor @@ -70,7 +70,7 @@ M: #drop linearize-node* ( node -- ) M: #ifte linearize-node* ( node -- ) #! The parameter is a list of two lists, each one a dataflow #! IR. - node-children 2unlist