Merge branch 'master' of git://factorcode.org/git/factor

core/assocs/assocs.factor

@@ -155,6 +155,9 @@ M: assoc >alist [ 2array ] { } assoc>map ;
 : value-at ( value assoc -- key/f )
     swap [ = nip ] curry assoc-find 2drop ;
 
+: zip ( keys values -- alist )
+    2array flip ; inline
+
 : search-alist ( key alist -- pair i )
     [ first = ] with find swap ; inline
 
@@ -204,7 +207,7 @@ M: enum set-at seq>> set-nth ;
 M: enum delete-at enum-seq delete-nth ;
 
 M: enum >alist ( enum -- alist )
-    seq>> [ length ] keep 2array flip ;
+    seq>> [ length ] keep zip ;
 
 M: enum assoc-size seq>> length ;
 

core/classes/tuple/tuple-tests.factor

@@ -529,3 +529,12 @@ TUPLE: another-forget-accessors-test ;
 ] unit-test
 
 [ t ] [ \ another-forget-accessors-test class? ] unit-test
+
+! Shadowing test
+[ f ] [
+    t parser-notes? [
+        [
+            "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
+        ] with-string-writer empty?
+    ] with-variable
+] unit-test

core/classes/tuple/tuple.factor

@@ -55,6 +55,9 @@ PRIVATE>
     "slot-names" word-prop
     [ dup array? [ second ] when ] map ;
 
+: all-slot-names ( class -- slots )
+    superclasses [ slot-names ] map concat \ class prefix ;
+
 <PRIVATE
 
 : tuple= ( tuple1 tuple2 -- ? )
@@ -119,9 +122,6 @@ PRIVATE>
 : define-tuple-layout ( class -- )
     dup make-tuple-layout "layout" set-word-prop ;
 
-: all-slot-names ( class -- slots )
-    superclasses [ slot-names ] map concat \ class prefix ;
-
 : compute-slot-permutation ( class old-slot-names -- permutation )
     >r all-slot-names r> [ index ] curry map ;
 

core/combinators/combinators.factor

@@ -59,6 +59,10 @@ ERROR: no-case ;
 M: sequence hashcode*
     [ sequence-hashcode ] recursive-hashcode ;
 
+M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
 M: hashtable hashcode*
     [
         dup assoc-size 1 number=

core/compiler/compiler.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces arrays sequences io inference.backend
-inference.state generator debugger math.parser prettyprint words
+inference.state generator debugger words compiler.units
-compiler.units continuations vocabs assocs alien.compiler dlists
+continuations vocabs assocs alien.compiler dlists optimizer
-optimizer definitions math compiler.errors threads graphs
+definitions math compiler.errors threads graphs generic
-generic inference ;
+inference ;
 IN: compiler
 
 : ripple-up ( word -- )

core/cpu/ppc/architecture/architecture.factor

@@ -146,7 +146,7 @@ M: int-regs %save-param-reg drop 1 rot local@ STW ;
 
 M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
 
-GENERIC: STF ( src dst reg-class -- )
+GENERIC: STF ( src dst off reg-class -- )
 
 M: single-float-regs STF drop STFS ;
 
@@ -154,7 +154,7 @@ M: double-float-regs STF drop STFD ;
 
 M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
 
-GENERIC: LF ( src dst reg-class -- )
+GENERIC: LF ( dst src off reg-class -- )
 
 M: single-float-regs LF drop LFS ;
 

core/generator/registers/registers.factor

@@ -322,7 +322,7 @@ M: phantom-retainstack finalize-height
 
 : (live-locs) ( phantom -- seq )
     #! Discard locs which haven't moved
-    [ phantom-locs* ] [ stack>> ] bi 2array flip
+    [ phantom-locs* ] [ stack>> ] bi zip
     [ live-loc? ] assoc-subset
     values ;
 
@@ -421,7 +421,7 @@ M: loc lazy-store
 
 : slow-shuffle-mapping ( locs tmp -- pairs )
     >r dup length r>
-    [ swap - <ds-loc> ] curry map 2array flip ;
+    [ swap - <ds-loc> ] curry map zip ;
 
 : slow-shuffle ( locs -- )
     #! We don't have enough free registers to load all shuffle

core/inference/known-words/known-words.factor

@@ -373,7 +373,7 @@ set-primitive-effect
 \ data-room { } { integer array } <effect> set-primitive-effect
 \ data-room make-flushable
 
-\ code-room { } { integer integer } <effect> set-primitive-effect
+\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
 \ code-room  make-flushable
 
 \ os-env { string } { object } <effect> set-primitive-effect

core/mirrors/mirrors.factor

@@ -42,7 +42,7 @@ M: mirror delete-at ( key mirror -- )
 M: mirror >alist ( mirror -- alist )
     >mirror<
     [ [ slot-spec-offset slot ] with map ] keep
-    [ slot-spec-name ] map swap 2array flip ;
+    [ slot-spec-name ] map swap zip ;
 
 M: mirror assoc-size mirror-slots length ;
 

core/optimizer/optimizer-tests.factor

@@ -370,4 +370,7 @@ HINTS: recursive-inline-hang-2 array ;
 
 HINTS: recursive-inline-hang-3 array ;
 
+! Regression
+USE: sequences.private
 
+[ ] [ { (3append) } compile ] unit-test

core/parser/parser-docs.factor

@@ -153,6 +153,8 @@ ARTICLE: "parser-files" "Parsing source files"
 { $subsection parse-file }
 { $subsection bootstrap-file }
 "The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions."
+$nl
+"While the above words are useful for one-off experiments, real programs should be written to use the vocabulary system instead; see " { $link "vocabs.loader" } "."
 { $see-also "source-files" } ;
 
 ARTICLE: "parser-usage" "Reflective parser usage"
@@ -161,6 +163,13 @@ ARTICLE: "parser-usage" "Reflective parser usage"
 "The parser can also parse from a stream:"
 { $subsection parse-stream } ;
 
+ARTICLE: "top-level-forms" "Top level forms"
+"Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file."
+$nl
+"Top-level forms do not have access to the " { $link in } " and " { $link use } " variables that were set at parse time, nor do they run inside " { $link with-compilation-unit } "; so meta-programming might require extra work in a top-level form compared with a parsing word."
+$nl
+"Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ;
+
 ARTICLE: "parser" "The parser"
 "This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies."
 $nl
@@ -168,6 +177,7 @@ $nl
 { $subsection "vocabulary-search" }
 { $subsection "parser-files" }
 { $subsection "parser-usage" }
+{ $subsection "top-level-forms" }
 "The parser can be extended."
 { $subsection "parsing-words" }
 { $subsection "parser-lexer" }

core/parser/parser.factor

@@ -1,12 +1,11 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions generic assocs kernel math
+USING: arrays definitions generic assocs kernel math namespaces
-namespaces prettyprint sequences strings vectors words
+prettyprint sequences strings vectors words quotations inspector
-quotations inspector io.styles io combinators sorting
+io.styles io combinators sorting splitting math.parser effects
-splitting math.parser effects continuations debugger 
+continuations debugger io.files io.streams.string vocabs
-io.files io.streams.string vocabs io.encodings.utf8
+io.encodings.utf8 source-files classes classes.tuple hashtables
-source-files classes hashtables compiler.errors compiler.units
+compiler.errors compiler.units accessors ;
-accessors ;
 IN: parser
 
 TUPLE: lexer text line line-text line-length column ;
@@ -285,13 +284,27 @@ M: no-word-error summary
 : CREATE-METHOD ( -- method )
     scan-word bootstrap-word scan-word create-method-in ;
 
+: shadowed-slots ( superclass slots -- shadowed )
+    >r all-slot-names r> seq-intersect ;
+
+: check-slot-shadowing ( class superclass slots -- )
+    shadowed-slots [
+        [
+            "Definition of slot ``" %
+            %
+            "'' in class ``" %
+            word-name %
+            "'' shadows a superclass slot" %
+        ] "" make note.
+    ] with each ;
+
 : parse-tuple-definition ( -- class superclass slots )
     CREATE-CLASS
     scan {
         { ";" [ tuple f ] }
         { "<" [ scan-word ";" parse-tokens ] }
         [ >r tuple ";" parse-tokens r> prefix ]
-    } case ;
+    } case 3dup check-slot-shadowing ;
 
 ERROR: staging-violation word ;
 

core/sequences/sequences-tests.factor

@@ -1,6 +1,6 @@
 USING: arrays kernel math namespaces sequences kernel.private
 sequences.private strings sbufs tools.test vectors bit-arrays
-generic ;
+generic vocabs.loader ;
 IN: sequences.tests
 
 [ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
@@ -100,6 +100,16 @@ unit-test
 [ [ ] ] [ [ 1 2 3 ] 3 tail ] unit-test
 [ [ 3 ] ] [ [ 1 2 3 ] 2 tail ] unit-test
 
+[ "blah" ] [ "blahxx" 2 head* ] unit-test
+
+[ "xx" ] [ "blahxx" 2 tail* ] unit-test
+
+[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice = ] unit-test
+[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice [ hashcode ] bi@ = ] unit-test
+
+[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* = ] unit-test
+[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* [ hashcode ] bi@ = ] unit-test
+
 [ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
 [ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
 [ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
@@ -195,6 +205,12 @@ unit-test
 ! Pathological case
 [ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
 
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
+
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
+
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> [ hashcode ] bi@ = ] unit-test
+
 [ -10 "hi" "bye" copy ] must-fail
 [ 10 "hi" "bye" copy ] must-fail
 
@@ -244,3 +260,5 @@ unit-test
 [ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
 [ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
 
+! Hardcore
+[ ] [ "sequences" reload ] unit-test

core/sequences/sequences.factor

@@ -172,7 +172,9 @@ TUPLE: reversed seq ;
 C: <reversed> reversed
 
 M: reversed virtual-seq reversed-seq ;
+
 M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
+
 M: reversed length reversed-seq length ;
 
 INSTANCE: reversed virtual-sequence
@@ -198,7 +200,9 @@ ERROR: slice-error reason ;
     slice construct-boa ; inline
 
 M: slice virtual-seq slice-seq ;
+
 M: slice virtual@ [ slice-from + ] keep slice-seq ;
+
 M: slice length dup slice-to swap slice-from - ;
 
 : head-slice ( seq n -- slice ) (head) <slice> ;
@@ -466,6 +470,21 @@ M: sequence <=>
     2dup [ length ] bi@ number=
     [ mismatch not ] [ 2drop f ] if ; inline
 
+: sequence-hashcode-step ( oldhash newpart -- newhash )
+    swap [
+        dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
+        fixnum+fast fixnum+fast
+    ] keep fixnum-bitxor ; inline
+
+: sequence-hashcode ( n seq -- x )
+    0 -rot [
+        hashcode* >fixnum sequence-hashcode-step
+    ] with each ; inline
+
+M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
+
+M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
+
 : move ( to from seq -- )
     2over number=
     [ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
@@ -692,14 +711,3 @@ PRIVATE>
         dup [ length ] map infimum
         [ <column> dup like ] with map
     ] unless ;
-
-: sequence-hashcode-step ( oldhash newpart -- newhash )
-    swap [
-        dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
-        fixnum+fast fixnum+fast
-    ] keep fixnum-bitxor ; inline
-
-: sequence-hashcode ( n seq -- x )
-    0 -rot [
-        hashcode* >fixnum sequence-hashcode-step
-    ] with each ; inline

extra/assocs/lib/lib.factor

@@ -37,9 +37,6 @@ IN: assocs.lib
 
 : insert ( value variable -- ) namespace insert-at ;
 
-: 2seq>assoc ( keys values exemplar -- assoc )
-    >r 2array flip r> assoc-like ;
-
 : generate-key ( assoc -- str )
     >r 256 random-bits >hex r>
     2dup key? [ nip generate-key ] [ drop ] if ;

extra/peg/peg.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2007, 2008 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences strings fry namespaces math assocs shuffle 
-       vectors arrays combinators.lib math.parser 
+       vectors arrays math.parser 
-       unicode.categories sequences.lib compiler.units parser
+       unicode.categories compiler.units parser
        words quotations effects memoize accessors locals effects splitting ;
 IN: peg
 

extra/sequences/lib/lib.factor

@@ -4,7 +4,7 @@
 USING: combinators.lib kernel sequences math namespaces assocs 
 random sequences.private shuffle math.functions mirrors
 arrays math.parser math.private sorting strings ascii macros
-assocs.lib quotations ;
+assocs.lib quotations hashtables ;
 IN: sequences.lib
 
 : each-withn ( seq quot n -- ) nwith each ; inline
@@ -231,7 +231,7 @@ PRIVATE>
     [ swap nth ] with map ;
 
 : replace ( str oldseq newseq -- str' )
-    H{ } 2seq>assoc substitute ;
+    zip >hashtable substitute ;
 
 : remove-nth ( seq n -- seq' )
     cut-slice 1 tail-slice append ;

extra/tools/memory/memory-tests.factor

@@ -1,4 +1,8 @@
 USING: tools.test tools.memory ;
 IN: tools.memory.tests
 
+\ room. must-infer
+[ ] [ room. ] unit-test
+
+\ heap-stats. must-infer
 [ ] [ heap-stats. ] unit-test

extra/tools/memory/memory.factor

@@ -1,22 +1,29 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences vectors arrays generic assocs io math
 namespaces parser prettyprint strings io.styles vectors words
-system sorting splitting math.parser classes memory ;
+system sorting splitting math.parser classes memory combinators ;
 IN: tools.memory
 
+<PRIVATE
+
+: write-size ( n -- )
+    number>string
+    dup length 4 > [ 3 cut* "," swap 3append ] when
+    " KB" append write-cell ;
+
 : write-total/used/free ( free total str -- )
     [
         write-cell
-        dup number>string write-cell
+        dup write-size
-        over - number>string write-cell
+        over - write-size
-        number>string write-cell
+        write-size
     ] with-row ;
 
 : write-total ( n str -- )
     [
         write-cell
-        number>string write-cell
+        write-size
         [ ] with-cell
         [ ] with-cell
     ] with-row ;
@@ -25,26 +32,41 @@ IN: tools.memory
     [ [ write-cell ] each ] with-row ;
 
 : (data-room.) ( -- )
-    data-room 2 <groups> 0 [
+    data-room 2 <groups> dup length [
-        "Generation " pick number>string append
+        [ first2 ] [ number>string "Generation " prepend ] bi*
-        >r first2 r> write-total/used/free 1+
+        write-total/used/free
-    ] reduce drop
+    ] 2each
     "Cards" write-total ;
 
-: (code-room.) ( -- )
+: write-labelled-size ( n string -- )
-    code-room "Code space" write-total/used/free ;
+    [ write-cell write-size ] with-row ;
 
-: room. ( -- )
+: (code-room.) ( -- )
-    standard-table-style [
+    code-room {
-        { "" "Total" "Used" "Free" } write-headings
+        [ "Size:" write-labelled-size ]
-        (data-room.)
+        [ "Used:" write-labelled-size ]
-        (code-room.)
+        [ "Total free space:" write-labelled-size ]
-    ] tabular-output ;
+        [ "Largest free block:" write-labelled-size ]
+    } spread ;
 
 : heap-stat-step ( counts sizes obj -- )
     [ dup size swap class rot at+ ] keep
     1 swap class rot at+ ;
 
+PRIVATE>
+
+: room. ( -- )
+    "==== DATA HEAP" print
+    standard-table-style [
+        { "" "Total" "Used" "Free" } write-headings
+        (data-room.)
+    ] tabular-output
+    nl
+    "==== CODE HEAP" print
+    standard-table-style [
+        (code-room.)
+    ] tabular-output ;
+
 : heap-stats ( -- counts sizes )
     H{ } clone H{ } clone
     [ >r 2dup r> heap-stat-step ] each-object ;

vm/code_gc.c

@@ -198,20 +198,33 @@ void free_unmarked(F_HEAP *heap)
 	build_free_list(heap,heap->segment->size);
 }
 
-/* Compute total sum of sizes of free blocks */
+/* Compute total sum of sizes of free blocks, and size of largest free block */
-CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status)
+void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free)
 {
-	CELL size = 0;
+	*used = 0;
+	*total_free = 0;
+	*max_free = 0;
+
 	F_BLOCK *scan = first_block(heap);
 
 	while(scan)
 	{
-		if(scan->status == status)
+		switch(scan->status)
-			size += scan->size;
+		{
+		case B_ALLOCATED:
+			*used += scan->size;
+			break;
+		case B_FREE:
+			*total_free += scan->size;
+			if(scan->size > *max_free)
+				*max_free = scan->size;
+			break;
+		default:
+			critical_error("Invalid scan->status",(CELL)scan);
+		}
+
 		scan = next_block(heap,scan);
 	}
-
-	return size;
 }
 
 /* The size of the heap, not including the last block if it's free */
@@ -283,8 +296,12 @@ void recursive_mark(F_BLOCK *block)
 /* Push the free space and total size of the code heap */
 DEFINE_PRIMITIVE(code_room)
 {
-	dpush(tag_fixnum(heap_usage(&code_heap,B_FREE) / 1024));
+	CELL used, total_free, max_free;
+	heap_usage(&code_heap,&used,&total_free,&max_free);
 	dpush(tag_fixnum((code_heap.segment->size) / 1024));
+	dpush(tag_fixnum(used / 1024));
+	dpush(tag_fixnum(total_free / 1024));
+	dpush(tag_fixnum(max_free / 1024));
 }
 
 /* Dump all code blocks for debugging */

vm/code_gc.h

@@ -32,7 +32,7 @@ void build_free_list(F_HEAP *heap, CELL size);
 CELL heap_allot(F_HEAP *heap, CELL size);
 void unmark_marked(F_HEAP *heap);
 void free_unmarked(F_HEAP *heap);
-CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status);
+void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
 CELL heap_size(F_HEAP *heap);
 
 INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)

vm/code_heap.c

@@ -229,7 +229,16 @@ CELL allot_code_block(CELL size)
 
 		/* Insufficient room even after code GC, give up */
 		if(start == 0)
+		{
+			CELL used, total_free, max_free;
+			heap_usage(&code_heap,&used,&total_free,&max_free);
+
+			fprintf(stderr,"Code heap stats:\n");
+			fprintf(stderr,"Used: %ld\n",used);
+			fprintf(stderr,"Total free space: %ld\n",total_free);
+			fprintf(stderr,"Largest free block: %ld\n",max_free);
 			fatal_error("Out of memory in add-compiled-block",0);
+		}
 	}
 
 	return start;