diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index 6b6bd3d51a..adb69d317c 100755 --- a/core/assocs/assocs.factor +++ b/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 ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 729997d3b2..2575570d2f 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 608fb8cf6c..aa8ef6cdb7 100755 --- a/core/classes/tuple/tuple.factor +++ b/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 ; + : 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 ; diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 139c6d8fdf..96c4009ba9 100755 --- a/core/combinators/combinators.factor +++ b/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= diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index a0599f79a1..6f75ca873d 100755 --- a/core/compiler/compiler.factor +++ b/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 -compiler.units continuations vocabs assocs alien.compiler dlists -optimizer definitions math compiler.errors threads graphs -generic inference ; +inference.state generator debugger words compiler.units +continuations vocabs assocs alien.compiler dlists optimizer +definitions math compiler.errors threads graphs generic +inference ; IN: compiler : ripple-up ( word -- ) diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index bd5273efcb..09ffead029 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/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 ; diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index b5b3f0b2c0..f3dc0fb10e 100755 --- a/core/generator/registers/registers.factor +++ b/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 - ] curry map 2array flip ; + [ swap - ] curry map zip ; : slow-shuffle ( locs -- ) #! We don't have enough free registers to load all shuffle diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 8f505c21a1..33a5da87f4 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -373,7 +373,7 @@ set-primitive-effect \ data-room { } { integer array } set-primitive-effect \ data-room make-flushable -\ code-room { } { integer integer } set-primitive-effect +\ code-room { } { integer integer integer integer } set-primitive-effect \ code-room make-flushable \ os-env { string } { object } set-primitive-effect diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index a13e1331fa..61cdbdad24 100755 --- a/core/mirrors/mirrors.factor +++ b/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 ; diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 6c6adfa3e6..c8d7a0a0a0 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/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 diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index d11f036445..e7984f7ec3 100755 --- a/core/parser/parser-docs.factor +++ b/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" } diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6d091fd1c0..6c09e08f84 100755 --- a/core/parser/parser.factor +++ b/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 -namespaces prettyprint sequences strings vectors words -quotations inspector io.styles io combinators sorting -splitting math.parser effects continuations debugger -io.files io.streams.string vocabs io.encodings.utf8 -source-files classes hashtables compiler.errors compiler.units -accessors ; +USING: arrays definitions generic assocs kernel math namespaces +prettyprint sequences strings vectors words quotations inspector +io.styles io combinators sorting splitting math.parser effects +continuations debugger io.files io.streams.string vocabs +io.encodings.utf8 source-files classes classes.tuple hashtables +compiler.errors compiler.units 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 ; diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 3a30824084..281b27d540 100755 --- a/core/sequences/sequences-tests.factor +++ b/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 >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" "bye" append ] unit-test +[ t ] [ "hi" SBUF" hi" = ] unit-test + +[ t ] [ "hi" SBUF" hi" = ] unit-test + +[ t ] [ "hi" SBUF" hi" [ 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 diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 01a1cb9b6a..996aba8e6e 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -172,7 +172,9 @@ TUPLE: reversed seq ; C: 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) ; @@ -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 [ 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 diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index b23ee1f830..92fb9aac81 100755 --- a/extra/assocs/lib/lib.factor +++ b/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 ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index ee9037ff25..3b1d408ae2 100755 --- a/extra/peg/peg.factor +++ b/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 - unicode.categories sequences.lib compiler.units parser + vectors arrays math.parser + unicode.categories compiler.units parser words quotations effects memoize accessors locals effects splitting ; IN: peg diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index ac50d3f6c6..0221d9b99a 100755 --- a/extra/sequences/lib/lib.factor +++ b/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 ; diff --git a/extra/tools/memory/memory-tests.factor b/extra/tools/memory/memory-tests.factor index 9efbf63f7f..60b54c2a0d 100644 --- a/extra/tools/memory/memory-tests.factor +++ b/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 diff --git a/extra/tools/memory/memory.factor b/extra/tools/memory/memory.factor index 2077ea497e..b8fdcab280 100644 --- a/extra/tools/memory/memory.factor +++ b/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 +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 - over - number>string write-cell - number>string write-cell + dup write-size + over - write-size + 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 0 [ - "Generation " pick number>string append - >r first2 r> write-total/used/free 1+ - ] reduce drop + data-room 2 dup length [ + [ first2 ] [ number>string "Generation " prepend ] bi* + write-total/used/free + ] 2each "Cards" write-total ; -: (code-room.) ( -- ) - code-room "Code space" write-total/used/free ; +: write-labelled-size ( n string -- ) + [ write-cell write-size ] with-row ; -: room. ( -- ) - standard-table-style [ - { "" "Total" "Used" "Free" } write-headings - (data-room.) - (code-room.) - ] tabular-output ; +: (code-room.) ( -- ) + code-room { + [ "Size:" write-labelled-size ] + [ "Used:" write-labelled-size ] + [ "Total free space:" write-labelled-size ] + [ "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 ; diff --git a/vm/code_gc.c b/vm/code_gc.c index 93eb49c1be..141f4abbfe 100755 --- a/vm/code_gc.c +++ b/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 */ -CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status) +/* Compute total sum of sizes of free blocks, and size of largest free block */ +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) - size += scan->size; + switch(scan->status) + { + 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 */ diff --git a/vm/code_gc.h b/vm/code_gc.h index 32f304c16c..658dc990ae 100644 --- a/vm/code_gc.h +++ b/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) diff --git a/vm/code_heap.c b/vm/code_heap.c index ec63441bcb..92915e49d1 100755 --- a/vm/code_heap.c +++ b/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;