From 69f9c80b5b1ef81594f191dffe63c7e05c4142d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 16 Oct 2009 14:41:40 -0500 Subject: [PATCH 1/4] vm: code heap: move mark bits to a separate bitmap --- vm/debug.cpp | 2 +- vm/full_collector.cpp | 41 +++++------ vm/gc.cpp | 3 - vm/heap.cpp | 91 +++++++----------------- vm/heap.hpp | 6 +- vm/image.cpp | 160 +++++++++++++++++++++--------------------- vm/layouts.hpp | 9 --- vm/mark_bits.hpp | 103 +++++++++++++++++++++++++++ vm/master.hpp | 1 + vm/vm.hpp | 2 - 10 files changed, 235 insertions(+), 183 deletions(-) create mode 100644 vm/mark_bits.hpp diff --git a/vm/debug.cpp b/vm/debug.cpp index da8c603254..4cb4444d41 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -296,7 +296,7 @@ void factor_vm::dump_code_heap() const char *status; if(scan->type() == FREE_BLOCK_TYPE) status = "free"; - else if(scan->marked_p()) + else if(code->state->is_marked_p(scan)) { reloc_size += object_size(((code_block *)scan)->relocation); literal_size += object_size(((code_block *)scan)->literals); diff --git a/vm/full_collector.cpp b/vm/full_collector.cpp index 86f3216e9c..59f87bb5a5 100644 --- a/vm/full_collector.cpp +++ b/vm/full_collector.cpp @@ -134,6 +134,8 @@ void factor_vm::collect_full_impl(bool trace_contexts_p) { full_collector collector(this); + code->state->clear_mark_bits(); + collector.trace_roots(); if(trace_contexts_p) { @@ -148,16 +150,6 @@ void factor_vm::collect_full_impl(bool trace_contexts_p) nursery.here = nursery.start; } -/* In both cases, compact code heap before updating code blocks so that -XTs are correct after */ - -void factor_vm::big_code_heap_update() -{ - big_code_heap_updater updater(this); - code->free_unmarked(updater); - code->clear_remembered_set(); -} - void factor_vm::collect_growing_heap(cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p) @@ -168,15 +160,18 @@ void factor_vm::collect_growing_heap(cell requested_bytes, collect_full_impl(trace_contexts_p); delete old; - if(compact_code_heap_p) compact_code_heap(trace_contexts_p); + if(compact_code_heap_p) + { + compact_code_heap(trace_contexts_p); + big_code_heap_updater updater(this); + iterate_code_heap(updater); + } + else + { + big_code_heap_updater updater(this); + code->free_unmarked(updater); + } - big_code_heap_update(); -} - -void factor_vm::small_code_heap_update() -{ - small_code_heap_updater updater(this); - code->free_unmarked(updater); code->clear_remembered_set(); } @@ -190,10 +185,16 @@ void factor_vm::collect_full(bool trace_contexts_p, bool compact_code_heap_p) if(compact_code_heap_p) { compact_code_heap(trace_contexts_p); - big_code_heap_update(); + big_code_heap_updater updater(this); + iterate_code_heap(updater); } else - small_code_heap_update(); + { + small_code_heap_updater updater(this); + code->free_unmarked(updater); + } + + code->clear_remembered_set(); } } diff --git a/vm/gc.cpp b/vm/gc.cpp index c89add6066..95a6857db6 100755 --- a/vm/gc.cpp +++ b/vm/gc.cpp @@ -54,9 +54,6 @@ void factor_vm::gc(gc_op op, current_gc->op = collect_full_op; break; case collect_full_op: - /* Since we start tracing again, any previously - marked code blocks must be re-marked and re-traced */ - code->clear_mark_bits(); current_gc->op = collect_growing_heap_op; break; default: diff --git a/vm/heap.cpp b/vm/heap.cpp index 0f0da63df0..71aac62704 100644 --- a/vm/heap.cpp +++ b/vm/heap.cpp @@ -16,9 +16,18 @@ heap::heap(bool secure_gc_, cell size, bool executable_p) : secure_gc(secure_gc_ if(size > (1L << (sizeof(cell) * 8 - 6))) fatal_error("Heap too large",size); seg = new segment(align_page(size),executable_p); if(!seg) fatal_error("Out of memory in heap allocator",size); + state = new mark_bits(seg->start,size); clear_free_list(); } +heap::~heap() +{ + delete seg; + seg = NULL; + delete state; + state = NULL; +} + void heap::add_to_free_list(free_heap_block *block) { if(block->size() < free_list_count * block_size_increment) @@ -34,52 +43,15 @@ void heap::add_to_free_list(free_heap_block *block) } } -/* Called after reading the code heap from the image file, and after code GC. - -In the former case, we must add a large free block from compiling.base + size to -compiling.limit. */ +/* Called after reading the code heap from the image file, and after code heap +compaction. Makes a free list consisting of one free block, at the very end. */ void heap::build_free_list(cell size) { - heap_block *prev = NULL; - clear_free_list(); - - size = (size + block_size_increment - 1) & ~(block_size_increment - 1); - - heap_block *scan = first_block(); free_heap_block *end = (free_heap_block *)(seg->start + size); - - /* Add all free blocks to the free list */ - while(scan && scan < (heap_block *)end) - { - if(scan->type() == FREE_BLOCK_TYPE) - add_to_free_list((free_heap_block *)scan); - - prev = scan; - scan = next_block(scan); - } - - /* If there is room at the end of the heap, add a free block. This - branch is only taken after loading a new image, not after code GC */ - if((cell)(end + 1) <= seg->end) - { - end->set_marked_p(false); - end->set_type(FREE_BLOCK_TYPE); - end->set_size(seg->end - (cell)end); - - /* add final free block */ - add_to_free_list(end); - } - /* This branch is taken if the newly loaded image fits exactly, or - after code GC */ - else - { - /* even if there's no room at the end of the heap for a new - free block, we might have to jigger it up by a few bytes in - case prev + prev->size */ - if(prev) prev->set_size(seg->end - (cell)prev); - } - + end->set_type(FREE_BLOCK_TYPE); + end->set_size(seg->end - (cell)end); + add_to_free_list(end); } void heap::assert_free_block(free_heap_block *block) @@ -154,7 +126,6 @@ heap_block *heap::heap_allot(cell size, cell type) { block = split_free_block(block,size); block->set_type(type); - block->set_marked_p(false); return block; } else @@ -170,18 +141,7 @@ void heap::heap_free(heap_block *block) void heap::mark_block(heap_block *block) { - block->set_marked_p(true); -} - -void heap::clear_mark_bits() -{ - heap_block *scan = first_block(); - - while(scan) - { - scan->set_marked_p(false); - scan = next_block(scan); - } + state->set_marked_p(block,true); } /* Compute total sum of sizes of free blocks, and size of largest free block */ @@ -210,20 +170,21 @@ void heap::heap_usage(cell *used, cell *total_free, cell *max_free) } } -/* The size of the heap, not including the last block if it's free */ +/* The size of the heap after compaction */ cell heap::heap_size() { heap_block *scan = first_block(); + + while(scan) + { + if(scan->type() == FREE_BLOCK_TYPE) break; + else scan = next_block(scan); + } - while(next_block(scan) != NULL) - scan = next_block(scan); + assert(scan->type() == FREE_BLOCK_TYPE); + assert((cell)scan + scan->size() == seg->end); - /* this is the last block in the heap, and it is free */ - if(scan->type() == FREE_BLOCK_TYPE) - return (cell)scan - seg->start; - /* otherwise the last block is allocated */ - else - return seg->size; + return (cell)scan - (cell)first_block(); } void heap::compact_heap() @@ -238,7 +199,7 @@ void heap::compact_heap() { heap_block *next = next_block(scan); - if(scan->type() != FREE_BLOCK_TYPE && scan->marked_p()) + if(state->is_marked_p(scan)) { cell size = scan->size(); memmove(address,scan,size); diff --git a/vm/heap.hpp b/vm/heap.hpp index ef09c2b238..bc8851bab1 100644 --- a/vm/heap.hpp +++ b/vm/heap.hpp @@ -13,9 +13,11 @@ struct heap { bool secure_gc; segment *seg; heap_free_list free; + mark_bits *state; unordered_map forwarding; explicit heap(bool secure_gc_, cell size, bool executable_p); + ~heap(); inline heap_block *next_block(heap_block *block) { @@ -46,7 +48,6 @@ struct heap { heap_block *heap_allot(cell size, cell type); void heap_free(heap_block *block); void mark_block(heap_block *block); - void clear_mark_bits(); void heap_usage(cell *used, cell *total_free, cell *max_free); cell heap_size(); void compact_heap(); @@ -71,11 +72,10 @@ struct heap { else prev = scan; } - else if(scan->marked_p()) + else if(state->is_marked_p(scan)) { if(prev && prev->type() == FREE_BLOCK_TYPE) add_to_free_list((free_heap_block *)prev); - scan->set_marked_p(false); prev = scan; iter(scan); } diff --git a/vm/image.cpp b/vm/image.cpp index 05e0d66724..527ed3901b 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -67,86 +67,6 @@ void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p) code->build_free_list(h->code_size); } -/* Save the current image to disk */ -bool factor_vm::save_image(const vm_char *filename) -{ - FILE* file; - image_header h; - - file = OPEN_WRITE(filename); - if(file == NULL) - { - print_string("Cannot open image file: "); print_native_string(filename); nl(); - print_string(strerror(errno)); nl(); - return false; - } - - h.magic = image_magic; - h.version = image_version; - h.data_relocation_base = data->tenured->start; - h.data_size = data->tenured->here - data->tenured->start; - h.code_relocation_base = code->seg->start; - h.code_size = code->heap_size(); - - h.t = T; - h.bignum_zero = bignum_zero; - h.bignum_pos_one = bignum_pos_one; - h.bignum_neg_one = bignum_neg_one; - - for(cell i = 0; i < USER_ENV; i++) - h.userenv[i] = (save_env_p(i) ? userenv[i] : F); - - bool ok = true; - - if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false; - if(fwrite((void*)data->tenured->start,h.data_size,1,file) != 1) ok = false; - if(fwrite(code->first_block(),h.code_size,1,file) != 1) ok = false; - if(fclose(file)) ok = false; - - if(!ok) - { - print_string("save-image failed: "); print_string(strerror(errno)); nl(); - } - - return ok; -} - -void factor_vm::primitive_save_image() -{ - /* do a full GC to push everything into tenured space */ - primitive_compact_gc(); - - gc_root path(dpop(),this); - path.untag_check(this); - save_image((vm_char *)(path.untagged() + 1)); -} - -void factor_vm::primitive_save_image_and_exit() -{ - /* We unbox this before doing anything else. This is the only point - where we might throw an error, so we have to throw an error here since - later steps destroy the current image. */ - gc_root path(dpop(),this); - path.untag_check(this); - - /* strip out userenv data which is set on startup anyway */ - for(cell i = 0; i < USER_ENV; i++) - { - if(!save_env_p(i)) userenv[i] = F; - } - - gc(collect_full_op, - 0, /* requested size */ - false, /* discard objects only reachable from stacks */ - true /* compact the code heap */); - - /* Save the image */ - if(save_image((vm_char *)(path.untagged() + 1))) - exit(0); - else - exit(1); -} - void factor_vm::data_fixup(cell *handle, cell data_relocation_base) { if(immediate_p(*handle)) @@ -353,4 +273,84 @@ void factor_vm::load_image(vm_parameters *p) userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path); } +/* Save the current image to disk */ +bool factor_vm::save_image(const vm_char *filename) +{ + FILE* file; + image_header h; + + file = OPEN_WRITE(filename); + if(file == NULL) + { + print_string("Cannot open image file: "); print_native_string(filename); nl(); + print_string(strerror(errno)); nl(); + return false; + } + + h.magic = image_magic; + h.version = image_version; + h.data_relocation_base = data->tenured->start; + h.data_size = data->tenured->here - data->tenured->start; + h.code_relocation_base = code->seg->start; + h.code_size = code->heap_size(); + + h.t = T; + h.bignum_zero = bignum_zero; + h.bignum_pos_one = bignum_pos_one; + h.bignum_neg_one = bignum_neg_one; + + for(cell i = 0; i < USER_ENV; i++) + h.userenv[i] = (save_env_p(i) ? userenv[i] : F); + + bool ok = true; + + if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false; + if(fwrite((void*)data->tenured->start,h.data_size,1,file) != 1) ok = false; + if(fwrite(code->first_block(),h.code_size,1,file) != 1) ok = false; + if(fclose(file)) ok = false; + + if(!ok) + { + print_string("save-image failed: "); print_string(strerror(errno)); nl(); + } + + return ok; +} + +void factor_vm::primitive_save_image() +{ + /* do a full GC to push everything into tenured space */ + primitive_compact_gc(); + + gc_root path(dpop(),this); + path.untag_check(this); + save_image((vm_char *)(path.untagged() + 1)); +} + +void factor_vm::primitive_save_image_and_exit() +{ + /* We unbox this before doing anything else. This is the only point + where we might throw an error, so we have to throw an error here since + later steps destroy the current image. */ + gc_root path(dpop(),this); + path.untag_check(this); + + /* strip out userenv data which is set on startup anyway */ + for(cell i = 0; i < USER_ENV; i++) + { + if(!save_env_p(i)) userenv[i] = F; + } + + gc(collect_full_op, + 0, /* requested size */ + false, /* discard objects only reachable from stacks */ + true /* compact the code heap */); + + /* Save the image */ + if(save_image((vm_char *)(path.untagged() + 1))) + exit(0); + else + exit(1); +} + } diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 2fba97d747..72b37249fe 100644 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -201,15 +201,6 @@ struct heap_block { cell header; - bool marked_p() { return header & 1; } - void set_marked_p(bool marked) - { - if(marked) - header |= 1; - else - header &= ~1; - } - cell type() { return (header >> 1) & 0x1f; } void set_type(cell type) { diff --git a/vm/mark_bits.hpp b/vm/mark_bits.hpp new file mode 100644 index 0000000000..7945be1850 --- /dev/null +++ b/vm/mark_bits.hpp @@ -0,0 +1,103 @@ +namespace factor +{ + +const int forwarding_granularity = 128; + +template struct mark_bits { + cell start; + cell size; + cell bits_size; + unsigned int *marked; + unsigned int *freed; + cell forwarding_size; + cell *forwarding; + + void clear_mark_bits() + { + memset(marked,0,bits_size * sizeof(unsigned int)); + } + + void clear_free_bits() + { + memset(freed,0,bits_size * sizeof(unsigned int)); + } + + void clear_forwarding() + { + memset(forwarding,0,forwarding_size * sizeof(cell)); + } + + explicit mark_bits(cell start_, cell size_) : + start(start_), + size(size_), + bits_size(size / Granularity / 32), + marked(new unsigned int[bits_size]), + freed(new unsigned int[bits_size]), + forwarding_size(size / Granularity / forwarding_granularity), + forwarding(new cell[forwarding_size]) + { + clear_mark_bits(); + clear_free_bits(); + clear_forwarding(); + } + + ~mark_bits() + { + delete[] marked; + marked = NULL; + delete[] freed; + freed = NULL; + delete[] forwarding; + forwarding = NULL; + } + + std::pair bitmap_deref(Block *address) + { + cell word_number = (((cell)address - start) / Granularity); + cell word_index = (word_number >> 5); + cell word_shift = (word_number & 31); + +#ifdef FACTOR_DEBUG + assert(word_index < bits_size); +#endif + + return std::make_pair(word_index,word_shift); + } + + bool bitmap_elt(unsigned int *bits, Block *address) + { + std::pair pair = bitmap_deref(address); + return (bits[pair.first] & (1 << pair.second)) != 0; + } + + void set_bitmap_elt(unsigned int *bits, Block *address, bool flag) + { + std::pair pair = bitmap_deref(address); + if(flag) + bits[pair.first] |= (1 << pair.second); + else + bits[pair.first] &= ~(1 << pair.second); + } + + bool is_marked_p(Block *address) + { + return bitmap_elt(marked,address); + } + + void set_marked_p(Block *address, bool marked_p) + { + set_bitmap_elt(marked,address,marked_p); + } + + bool is_free_p(Block *address) + { + return bitmap_elt(freed,address); + } + + void set_free_p(Block *address, bool free_p) + { + set_bitmap_elt(freed,address,free_p); + } +}; + +} diff --git a/vm/master.hpp b/vm/master.hpp index c5aed5e983..847980fac6 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -78,6 +78,7 @@ namespace factor #include "words.hpp" #include "float_bits.hpp" #include "io.hpp" +#include "mark_bits.hpp" #include "heap.hpp" #include "image.hpp" #include "alien.hpp" diff --git a/vm/vm.hpp b/vm/vm.hpp index c3d71dc6f2..5b949287b6 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -253,8 +253,6 @@ struct factor_vm void collect_nursery(); void collect_aging(); void collect_to_tenured(); - void big_code_heap_update(); - void small_code_heap_update(); void collect_full_impl(bool trace_contexts_p); void collect_growing_heap(cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p); void collect_full(bool trace_contexts_p, bool compact_code_heap_p); From fc317d7714439f11f3a322b883a14125eff77470 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 19 Oct 2009 19:17:38 -0500 Subject: [PATCH 2/4] help.tutorial: clarify role of ''reload'' word --- basis/help/tutorial/tutorial.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor index 2a5a9c640d..ee22782fdc 100644 --- a/basis/help/tutorial/tutorial.factor +++ b/basis/help/tutorial/tutorial.factor @@ -33,7 +33,7 @@ ARTICLE: "first-program-logic" "Writing some logic in your first program" $nl "In order to be able to call the words defined in the " { $snippet "palindrome" } " vocabulary, you need to issue the following command in the listener:" { $code "USE: palindrome" } -"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload:" +"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload, in case the refresh feature does not pick up changes from disk:" { $code "\"palindrome\" reload" } "We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "." $nl From 304496e03765038b7d18de2806bfded9e4b650aa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 19 Oct 2009 19:18:08 -0500 Subject: [PATCH 3/4] Build fixes --- core/generic/single/single-tests.factor | 3 ++- extra/cpu/8080/emulator/emulator.factor | 1 - extra/space-invaders/space-invaders.factor | 6 ++---- 3 files changed, 4 insertions(+), 6 deletions(-) diff --git a/core/generic/single/single-tests.factor b/core/generic/single/single-tests.factor index 554e287a3b..0f6c9bc0cd 100644 --- a/core/generic/single/single-tests.factor +++ b/core/generic/single/single-tests.factor @@ -4,7 +4,8 @@ accessors words byte-arrays bit-arrays parser namespaces make quotations stack-checker vectors growable hashtables sbufs prettyprint byte-vectors bit-vectors specialized-vectors definitions generic sets graphs assocs grouping see eval ; -SPECIALIZED-VECTOR: double +QUALIFIED-WITH: alien.c-types c +SPECIALIZED-VECTOR: c:double IN: generic.single.tests GENERIC: lo-tag-test ( obj -- obj' ) diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index 04c47caf4a..ddea7e762a 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -24,7 +24,6 @@ USING: quotations sequences sequences.deep - syntax words ; IN: cpu.8080.emulator diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index cb0f4319d6..cbe2241604 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -22,15 +22,13 @@ USING: ui.gadgets ui.gestures ui.render + specialized-arrays ; QUALIFIED: threads QUALIFIED: system +SPECIALIZED-ARRAY: uchar IN: space-invaders -<< - "uchar" require-c-array ->> - TUPLE: space-invaders < cpu port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ; CONSTANT: game-width 224 CONSTANT: game-height 256 From 08b683de61457c5948092564e392d15be12cb954 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 19 Oct 2009 22:46:46 -0500 Subject: [PATCH 4/4] ui.gadgets.editors: fix com-join-lines if there are more than two lines in the editor --- basis/ui/gadgets/editors/editors-tests.factor | 13 ++-- basis/ui/gadgets/editors/editors.factor | 59 +++++++++++++++---- 2 files changed, 57 insertions(+), 15 deletions(-) diff --git a/basis/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor index 3ba32dc3c2..3fbdf12cbe 100644 --- a/basis/ui/gadgets/editors/editors-tests.factor +++ b/basis/ui/gadgets/editors/editors-tests.factor @@ -1,8 +1,8 @@ -USING: accessors ui.gadgets.editors tools.test kernel io -io.streams.plain definitions namespaces ui.gadgets -ui.gadgets.grids prettyprint documents ui.gestures ui.gadgets.debug -models documents.elements ui.gadgets.scrollers ui.gadgets.line-support -sequences ; +USING: accessors ui.gadgets.editors ui.gadgets.editors.private +tools.test kernel io io.streams.plain definitions namespaces +ui.gadgets ui.gadgets.grids prettyprint documents ui.gestures +ui.gadgets.debug models documents.elements ui.gadgets.scrollers +ui.gadgets.line-support sequences ; IN: ui.gadgets.editors.tests [ "foo bar" ] [ @@ -55,6 +55,9 @@ IN: ui.gadgets.editors.tests [ ] [ com-join-lines ] unit-test [ ] [ "A" over set-editor-string com-join-lines ] unit-test [ "A B" ] [ "A\nB" over set-editor-string [ com-join-lines ] [ editor-string ] bi ] unit-test +[ "A B\nC\nD" ] [ "A\nB\nC\nD" over set-editor-string { 0 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test +[ "A\nB C\nD" ] [ "A\nB\nC\nD" over set-editor-string { 1 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test +[ "A\nB\nC D" ] [ "A\nB\nC\nD" over set-editor-string { 2 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test [ 2 ] [ 20 >>min-rows 20 >>min-cols pref-viewport-dim length ] unit-test diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index f83c5d710a..071ac1cffe 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -17,6 +17,8 @@ caret-color caret mark focused? blink blink-alarm ; + ( -- loc ) { 0 0 } ; : init-editor-locs ( editor -- editor ) @@ -27,6 +29,8 @@ focused? blink blink-alarm ; COLOR: red >>caret-color monospace-font >>font ; inline +PRIVATE> + : new-editor ( class -- editor ) new-line-gadget >>model @@ -36,6 +40,8 @@ focused? blink blink-alarm ; : ( -- editor ) editor new-editor ; + + M: editor graft* [ dup caret>> activate-editor-model ] [ dup mark>> activate-editor-model ] bi ; @@ -142,6 +150,8 @@ M: editor ungraft* ] keep scroll>rect ] [ drop ] if ; +> ] [ blink>> ] } 1&& ; @@ -189,6 +199,8 @@ TUPLE: selected-line start end first? last? ; ] 3bi ] if ; +PRIVATE> + M: editor draw-line ( line index editor -- ) [ selected-lines get at ] dip over [ draw-selected-line ] [ nip draw-unselected-line ] if ; @@ -206,6 +218,8 @@ M: editor baseline font>> font-metrics ascent>> ; M: editor cap-height font>> font-metrics cap-height>> ; +> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ] [ [ nip mark>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ] @@ -214,6 +228,8 @@ M: editor cap-height font>> font-metrics cap-height>> ; : caret/mark-changed ( editor -- ) [ restart-blinking ] keep scroll>caret ; +PRIVATE> + M: editor model-changed { { [ 2dup model>> eq? ] [ contents-changed ] } @@ -513,6 +529,8 @@ PRIVATE> : change-selection ( editor quot -- ) '[ gadget-selection @ ] [ user-input* drop ] bi ; inline + [ " " join ] tri ; -: this-line-and-next ( document line -- start end ) - [ nip 0 swap 2array ] - [ 1 + [ nip ] [ swap doc-line length ] 2bi 2array ] - 2bi ; - : last-line? ( document line -- ? ) [ last-line# ] dip = ; +: prev-line-and-this ( document line -- start end ) + swap + [ drop 1 - 0 2array ] + [ [ drop ] [ doc-line length ] 2bi 2array ] + 2bi ; + +: join-with-prev ( document line -- ) + [ prev-line-and-this ] [ drop ] 2bi + [ join-lines ] change-doc-range ; + +: this-line-and-next ( document line -- start end ) + swap + [ drop 0 2array ] + [ [ 1 + ] dip [ drop ] [ doc-line length ] 2bi 2array ] + 2bi ; + +: join-with-next ( document line -- ) + [ this-line-and-next ] [ drop ] 2bi + [ join-lines ] change-doc-range ; + +PRIVATE> + : com-join-lines ( editor -- ) dup gadget-selection? [ [ join-lines ] change-selection ] [ - [ model>> ] [ editor-caret first ] bi - 2dup last-line? [ 2drop ] [ - [ this-line-and-next ] [ drop ] 2bi - [ join-lines ] change-doc-range - ] if + [ model>> ] [ editor-caret first ] bi { + { [ over last-line# 0 = ] [ 2drop ] } + { [ 2dup last-line? ] [ join-with-prev ] } + [ join-with-next ] + } cond ] if ; multiline-editor "multiline" f { @@ -566,6 +601,8 @@ TUPLE: source-editor < multiline-editor ; ! Fields wrap an editor TUPLE: field < border editor min-cols max-cols ; +>size { 1 0 } >>fill @@ -576,6 +613,8 @@ TUPLE: field < border editor min-cols max-cols ; { 1 0 } >>fill field-theme ; +PRIVATE> + : new-field ( class -- gadget ) [ ] dip new-border dup gadget-child >>editor