diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 7452e31cf8..4468ecf7d1 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -136,7 +136,7 @@ SYMBOL: undefined-quot : here-as ( tag -- pointer ) here swap bitor ; : align-here ( -- ) - here 8 mod 4 = [ 0 emit ] when ; + here 8 mod 4 = [ heap-size drop 0 emit ] when ; : emit-fixnum ( n -- ) tag-fixnum emit ; @@ -177,6 +177,7 @@ GENERIC: ' ( obj -- ptr ) [ dup bignum-bits neg shift swap bignum-radix bitand ] [ ] unfold nip ; +USE: continuations : emit-bignum ( n -- ) dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq dup length 1+ emit-fixnum @@ -214,10 +215,6 @@ M: f ' : 1, 1 >bignum ' 1-offset fixup ; : -1, -1 >bignum ' -1-offset fixup ; -! Beginning of the image - -: begin-image ( -- ) emit-header t, 0, 1, -1, ; - ! Words : emit-word ( word -- ) @@ -385,7 +382,10 @@ M: curry ' : fixup-header ( -- ) heap-size data-heap-size-offset fixup ; -: end-image ( -- ) +: build-image ( -- image ) + 800000 image set + 20000 objects set + emit-header t, 0, 1, -1, "Serializing words..." print flush emit-words "Serializing JIT data..." print flush @@ -400,7 +400,8 @@ M: curry ' fixup-header "Image length: " write image get length . "Object cache size: " write objects get assoc-size . - \ word global delete-at ; + \ word global delete-at + image get ; ! Image output @@ -411,28 +412,23 @@ M: curry ' [ >le write ] curry each ] if ; -: write-image ( image filename -- ) - "Writing image to " write dup write "..." print flush +: write-image ( image -- ) + "Writing image to " write + architecture get boot-image-name resource-path + dup write "..." print flush [ (write-image) ] with-stream ; -: prepare-image ( -- ) - bootstrapping? on - load-help? off - 800000 image set - 20000 objects set ; - PRIVATE> : make-image ( arch -- ) - architecture [ - prepare-image - begin-image + [ + architecture set + bootstrapping? on + load-help? off "resource:/core/bootstrap/stage1.factor" run-file - end-image - image get - architecture get boot-image-name resource-path + build-image write-image - ] with-variable ; + ] with-scope ; : make-images ( -- ) images [ make-image ] each ; diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 745b6efd2d..2996a3feeb 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -4,7 +4,8 @@ USING: alien.c-types arrays cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2 cpu.x86.allot cpu.architecture kernel kernel.private math namespaces sequences generator.registers generator.fixup system -alien alien.compiler alien.structs slots splitting assocs ; +alien alien.accessors alien.compiler alien.structs slots +splitting assocs ; IN: cpu.x86.64 PREDICATE: x86-backend amd64-backend diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 20564bbde3..49b05ea48f 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -96,7 +96,7 @@ M: x86-backend %dispatch ( -- ) "n" operand "offset" operand ADD "n" operand HEX: 7f [+] JMP ! Fix up the displacement above - code-alignment dup bootstrap-cell 8 = 14 9 ? + + code-alignment dup bootstrap-cell 8 = 15 9 ? + building get dup pop* push align-code ] H{ diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index b839b047d6..ba65d2508c 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -370,6 +370,7 @@ TUPLE: effect-error word effect ; init-inference dependencies off dup word-def over dup infer-quot-recursive + end-infer finish-word current-effect ] with-scope diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 2691be8c3a..7a4176abfb 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -537,3 +537,8 @@ TUPLE: custom-error ; ! This was a false trigger of the undecidable quotation ! recursion bug { 2 1 } [ find-last-sep ] must-infer-as + +! Regression +: missing->r-check >r ; + +[ [ missing->r-check ] infer ] must-fail diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 64ce296a0b..68c4768c87 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -41,6 +41,9 @@ DEFER: base> ) ( str -- n ) radix get base> ; : whole-part ( str -- m n ) - "+" split1 >r (base>) r> + sign split1 >r (base>) r> dup [ (base>) ] [ drop 0 swap ] if ; : string>ratio ( str -- a/b ) @@ -70,7 +73,7 @@ PRIVATE> : base> ( str radix -- n/f ) [ - "-" ?head >r + "-" ?head dup negative? set >r { { [ CHAR: / over member? ] [ string>ratio ] } { [ CHAR: . over member? ] [ string>float ] } @@ -114,9 +117,9 @@ M: integer >base M: ratio >base [ [ - dup 0 < [ "-" % neg ] when + dup 0 < dup negative? set [ "-" % neg ] when 1 /mod - >r dup zero? [ drop ] [ (>base) % "+" % ] if r> + >r dup zero? [ drop ] [ (>base) % sign % ] if r> dup numerator (>base) % "/" % denominator (>base) % diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index ddc92a4bdd..001f59368e 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -8,15 +8,14 @@ TUPLE: lapse entry timeout cutoff ; : f 0 0 \ lapse construct-boa ; +! Won't need this with new slot accessors GENERIC: get-lapse ( obj -- lapse ) + GENERIC: set-timeout ( ms obj -- ) -M: object set-timeout get-lapse set-lapse-timeout ; +M: object set-timeout get-lapse set-timeout ; -M: duplex-stream set-timeout - 2dup - duplex-stream-in set-timeout - duplex-stream-out set-timeout ; +M: lapse set-timeout set-lapse-timeout ; : timeout ( obj -- ms ) get-lapse lapse-timeout ; : entry ( obj -- dlist-node ) get-lapse lapse-entry ; @@ -24,6 +23,16 @@ M: duplex-stream set-timeout : cutoff ( obj -- ms ) get-lapse lapse-cutoff ; : set-cutoff ( ms obj -- ) get-lapse set-lapse-cutoff ; +! Won't need this with inheritance +TUPLE: duplex-stream-lapse stream ; + +M: duplex-stream-lapse set-timeout + duplex-stream-lapse-stream 2dup + duplex-stream-in set-timeout + duplex-stream-out set-timeout ; + +M: duplex-stream get-lapse duplex-stream-lapse construct-boa ; + SYMBOL: timeout-queue : timeout? ( lapse -- ? ) diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index d79eca3495..09c6763657 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -42,7 +42,7 @@ SYMBOL: insomniac-recipients : email-log-report ( service word-names -- ) "logging.insomniac" [ (email-log-report) ] with-logging ; -: schedule-insomniac ( alist -- ) +: schedule-insomniac ( service word-names -- ) { 25 } { 6 } f f f -rot [ [ email-log-report ] assoc-each rotate-logs ] 2curry schedule ; diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index d4f0bd1fbf..fec0c3660f 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -4,7 +4,7 @@ USING: logging.server sequences namespaces concurrency words kernel arrays shuffle tools.annotations prettyprint.config prettyprint debugger io.streams.string splitting continuations effects arrays.lib parser strings -combinators.lib ; +combinators.lib quotations ; IN: logging SYMBOL: DEBUG @@ -112,9 +112,13 @@ PRIVATE> : log-critical ( error word -- ) CRITICAL (log-error) ; +: stack-balancer ( effect word -- quot ) + >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry + swap effect-out length f append >quotation ; + : error-logging-quot ( quot word -- quot' ) - dup stack-effect effect-in length - [ >r log-error r> ndrop ] 2curry + [ [ log-error ] curry ] keep + [ stack-effect ] keep stack-balancer compose [ recover ] 2curry ; : add-error-logging ( word level -- ) diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 198ae47a79..05029df1d0 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -84,7 +84,7 @@ SYMBOL: log-files (close-logs) log-root directory [ drop rotate-log ] assoc-each ; -: log-server-loop +: log-server-loop ( -- ) [ receive unclip { { "log-message" [ (log-message) ] } diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor index 858a7b0544..4dba49b908 100755 --- a/extra/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -107,6 +107,6 @@ unit-test unit-test [ 3 ] [ "1+1/2" string>number 2 * ] unit-test -[ -3 ] [ "-1+1/2" string>number 2 * ] unit-test +[ -3 ] [ "-1-1/2" string>number 2 * ] unit-test [ "2+1/7" ] [ 1 7 / 2 + number>string ] unit-test [ "1/8" ] [ 1 8 / number>string ] unit-test diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index 6dee51cbc0..eed23e8bc1 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel words parser io inspector quotations sequences -prettyprint continuations effects definitions compiler.units ; +prettyprint continuations effects definitions compiler.units +namespaces assocs ; IN: tools.annotations : reset ( word -- ) @@ -49,6 +50,16 @@ IN: tools.annotations : watch ( word -- ) dup [ (watch) ] annotate ; +: (watch-vars) ( quot word vars -- newquot ) + [ + "--- Entering: " write swap . + "--- Variable values:" print + [ dup get ] H{ } map>assoc describe + ] 2curry swap compose ; + +: watch-vars ( word vars -- ) + dupd [ (watch-vars) ] 2curry annotate ; + : breakpoint ( word -- ) [ \ break add* ] annotate ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 0b5e436e44..5673e41c62 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -40,14 +40,8 @@ SYMBOL: this-test dup word? [ 1quotation ] when [ infer drop ] curry [ ] swap unit-test ; -TUPLE: expected-error ; - -M: expected-error summary - drop - "The unit test expected the quotation to throw an error" ; - : must-fail-with ( quot pred -- ) - >r [ expected-error construct-empty throw ] compose r> + >r [ f ] compose r> [ recover ] 2curry [ t ] swap unit-test ; diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index e2df6a343b..a6674aef5f 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -363,9 +363,21 @@ editor "clipboard" f { { T{ cut-action } cut } } define-command-map -: previous-character T{ char-elt } editor-prev ; +: previous-character ( editor -- ) + dup gadget-selection? [ + dup selection-start/end drop + over set-caret mark>caret + ] [ + T{ char-elt } editor-prev + ] if ; -: next-character T{ char-elt } editor-next ; +: next-character ( editor -- ) + dup gadget-selection? [ + dup selection-start/end nip + over set-caret mark>caret + ] [ + T{ char-elt } editor-next + ] if ; : previous-line T{ line-elt } editor-prev ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index a9fd443fe6..3e008d049d 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -86,8 +86,8 @@ SYMBOL: last-update \ fetch-feed DEBUG add-error-logging : fetch-blogroll ( blogroll -- entries ) - dup 0 - swap [ fetch-feed ] parallel-map + dup 0 swap 1 + [ fetch-feed ] parallel-map [ [ ] with map ] 2map concat ; : sort-entries ( entries -- entries' ) @@ -120,9 +120,6 @@ SYMBOL: last-update { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" } { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" } { "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" } - { "Kevin Marshall" - "http://blog.botfu.com/?cat=9&feed=atom" - "http://blog.botfu.com/" } { "Kio M. Smallwood" "http://sekenre.wordpress.com/feed/atom/" "http://sekenre.wordpress.com/" } diff --git a/vm/debug.c b/vm/debug.c index 01e1ab0f43..a080a6cab2 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -21,7 +21,7 @@ void print_word(F_WORD* word, CELL nesting) else { printf("#name,nesting - 1); + print_nested_obj(word->name,nesting); printf(">"); } } @@ -44,13 +44,13 @@ void print_array(F_ARRAY* array, CELL nesting) for(i = 0; i < length; i++) { printf(" "); - print_nested_obj(array_nth(array,i),nesting - 1); + print_nested_obj(array_nth(array,i),nesting); } } -void print_nested_obj(CELL obj, CELL nesting) +void print_nested_obj(CELL obj, F_FIXNUM nesting) { - if(nesting == 0) + if(nesting <= 0) { printf(" ... "); return; @@ -204,7 +204,7 @@ void dump_objects(F_FIXNUM type) if(type == -1 || type_of(obj) == type) { printf("%lx ",obj); - print_nested_obj(obj,1); + print_nested_obj(obj,2); printf("\n"); } } @@ -213,36 +213,58 @@ void dump_objects(F_FIXNUM type) gc_off = false; } -CELL obj; -CELL look_for; - -void find_references_step(CELL *scan) +void find_data_references(CELL look_for) { - if(look_for == *scan) + CELL obj; + + void find_references_step(CELL *scan) { - printf("%lx ",obj); - print_nested_obj(obj,1); - printf("\n"); + if(look_for == *scan) + { + printf("%lx ",obj); + print_nested_obj(obj,2); + printf("\n"); + } } -} - -void find_references(CELL look_for_) -{ - look_for = look_for_; begin_scan(); - CELL obj_; - while((obj_ = next_object()) != F) - { - obj = obj_; - do_slots(obj_,find_references_step); - } + while((obj = next_object()) != F) + do_slots(UNTAG(obj),find_references_step); /* end scan */ gc_off = false; } +void find_code_references(CELL look_for) +{ + void find_references_step(F_COMPILED *compiled, CELL code_start, + CELL reloc_start, CELL literals_start) + { + CELL scan; + CELL literal_end = literals_start + compiled->literals_length; + + for(scan = literals_start; scan < literal_end; scan += CELLS) + { + CELL code_start = (CELL)(compiled + 1); + CELL literal_start = code_start + + compiled->code_length + + compiled->reloc_length; + + CELL obj = get(literal_start); + + if(look_for == get(scan)) + { + printf("%lx ",obj); + print_nested_obj(obj,2); + printf("\n"); + } + } + } + + iterate_code_heap(find_references_step); +} + void factorbug(void) { reset_stdio(); @@ -265,6 +287,9 @@ void factorbug(void) printf("addr -- print address containing card\n"); printf("data -- data heap dump\n"); printf("words -- words dump\n"); + printf("tuples -- tuples dump\n"); + printf("refs -- find data heap references to object\n"); + printf("push -- push object on data stack - NOT SAFE\n"); printf("code -- code heap dump\n"); for(;;) @@ -335,8 +360,26 @@ void factorbug(void) save_image(STR_FORMAT("fep.image")); else if(strcmp(cmd,"data") == 0) dump_objects(-1); + else if(strcmp(cmd,"refs") == 0) + { + CELL addr; + scanf("%lx",&addr); + printf("Data heap references:\n"); + find_data_references(addr); + printf("Code heap references:\n"); + find_code_references(addr); + printf("\n"); + } else if(strcmp(cmd,"words") == 0) dump_objects(WORD_TYPE); + else if(strcmp(cmd,"tuples") == 0) + dump_objects(TUPLE_TYPE); + else if(strcmp(cmd,"push") == 0) + { + CELL addr; + scanf("%lx",&addr); + dpush(addr); + } else if(strcmp(cmd,"code") == 0) dump_heap(&code_heap); else diff --git a/vm/debug.h b/vm/debug.h old mode 100644 new mode 100755 index cfd928bb51..ff8075c457 --- a/vm/debug.h +++ b/vm/debug.h @@ -1,5 +1,5 @@ void print_obj(CELL obj); -void print_nested_obj(CELL obj, CELL nesting); +void print_nested_obj(CELL obj, F_FIXNUM nesting); void dump_generations(void); void factorbug(void); diff --git a/vm/factor.c b/vm/factor.c index 0754067b95..826ad65324 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -154,6 +154,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded init_factor(&p); + nest_stacks(); + F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F); for(i = 1; i < argc; i++) @@ -173,8 +175,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded userenv[EXECUTABLE_ENV] = tag_object(from_native_string(executable_path)); userenv[EMBEDDED_ENV] = (embedded ? T : F); - nest_stacks(); - if(p.console) open_console();