diff --git a/Makefile b/Makefile index 417c47a299..879eca23bc 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ CC = gcc -DEFAULT_CFLAGS = -Wall -g $(SITE_CFLAGS) +DEFAULT_CFLAGS = -Wall -Os -fomit-frame-pointer $(SITE_CFLAGS) DEFAULT_LIBS = -lm STRIP = strip @@ -68,7 +68,7 @@ solaris: f: $(OBJS) $(CC) $(LIBS) $(CFLAGS) -o $@ $(OBJS) - #$(STRIP) $@ + $(STRIP) $@ clean: rm -f $(OBJS) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index c7c527da70..3ec887c84f 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -17,6 +17,9 @@ + ffi: +- value type structs +- unicode strings +- out parameters - figure out how to load an image referring to missing libraries - is signed -vs- unsigned pointers an issue? - bitfields in C structs @@ -49,13 +52,12 @@ + kernel: - ppc register decls -- do partial objects cause problems? -- remove sbufs - cat, reverse-cat primitives - first-class hashtables + misc: +- make-vector and make-string should not need a reverse step - perhaps /i should work with all numbers - jedit ==> jedit-word, jedit takes a file name - browser responder for word links in HTTPd diff --git a/examples/grad-demo.factor b/examples/grad-demo.factor new file mode 100644 index 0000000000..efacf32e31 --- /dev/null +++ b/examples/grad-demo.factor @@ -0,0 +1,45 @@ +! Gradient rendering demo. +! +! To run this code, bootstrap Factor like so: +! +! ./f boot.image.le32 +! -libraries:sdl:name=libSDL.so +! -libraries:sdl-gfx:name=libSDL_gfx.so +! -libraries:sdl-ttf:name=libSDL_ttf.so +! +! (But all on one line) +! +! Then, start Factor as usual (./f factor.image) and enter this +! at the listener: +! +! "examples/grad-demo.factor" run-file + +IN: grad-demo +USE: streams +USE: sdl +USE: sdl-event +USE: sdl-gfx +USE: sdl-video +USE: sdl-ttf +USE: namespaces +USE: math +USE: kernel +USE: test +USE: compiler +USE: strings +USE: alien +USE: prettyprint +USE: lists + +: draw-grad ( -- ) + [ over rgb ] with-pixels ; compiled + +: grad-demo ( -- ) + 640 480 0 SDL_HWSURFACE [ + TTF_Init + [ draw-grad ] with-surface + event-loop + SDL_Quit + ] with-screen ; + +grad-demo diff --git a/examples/mandel.factor b/examples/mandel.factor index a4384c2878..5ee2fcaf6f 100644 --- a/examples/mandel.factor +++ b/examples/mandel.factor @@ -32,7 +32,7 @@ USE: test : scale 255 * >fixnum ; -: scale-rgb ( r g b -- n ) +: scale-rgb ( r g b a -- n ) scale swap scale 8 shift bitor swap scale 16 shift bitor @@ -44,10 +44,10 @@ USE: test : ( nb-cols -- map ) [ dup [ - dup 360 * over 1 + / 360 / sat val + dup 360 * pick 1 + / 360 / sat val hsv>rgb 1.0 scale-rgb , ] repeat - ] make-list list>vector nip ; + ] make-vector nip ; : absq >rect swap sq swap sq + ; inline @@ -72,7 +72,7 @@ SYMBOL: center height get 150000 zoom-fact get * / y-inc set nb-iter get max-color min cols set ; -: c ( #{ i j }# -- c ) +: c ( i j -- c ) >r x-inc get * center get real x-inc get width get 2 / * - + >float r> @@ -89,7 +89,7 @@ SYMBOL: center ] with-pixels ; compiled : mandel ( -- ) - 640 480 32 SDL_HWSURFACE [ + 640 480 0 SDL_HWSURFACE [ [ 0.8 zoom-fact set -0.65 center set diff --git a/library/arrays.factor b/library/arrays.factor new file mode 100644 index 0000000000..3026f58f4c --- /dev/null +++ b/library/arrays.factor @@ -0,0 +1,53 @@ +! :folding=none:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2005 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: kernel-internals +USE: generic +USE: math-internals +USE: kernel + +! An array is a range of memory storing pointers to other +! objects. Arrays are not used directly, and their access words +! are not bounds checked. Examples of abstractions built on +! arrays include vectors, hashtables, and tuples. + +! These words are unsafe. I'd say "do not call them", but that +! Java-esque. By all means, do use arrays if you need something +! low-level... but be aware that vectors are usually a better +! choice. + +BUILTIN: array 8 + +: array-capacity ( array -- n ) 1 integer-slot ; inline +: vector-array ( vec -- array ) 2 slot ; inline +: set-vector-array ( array vec -- ) 2 set-slot ; inline + +: array-nth ( n array -- obj ) + swap 2 fixnum+ slot ; inline + +: set-array-nth ( obj n array -- ) + swap 2 fixnum+ set-slot ; inline diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 2456ed93f7..fdd77c2046 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -48,6 +48,7 @@ USE: namespaces "/version.factor" "/library/stack.factor" "/library/combinators.factor" + "/library/arrays.factor" "/library/kernel.factor" "/library/cons.factor" "/library/assoc.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 49a272f6c5..d991caa709 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -42,6 +42,7 @@ USE: hashtables "/version.factor" parse-resource append, "/library/stack.factor" parse-resource append, "/library/combinators.factor" parse-resource append, + "/library/arrays.factor" parse-resource append, "/library/kernel.factor" parse-resource append, "/library/cons.factor" parse-resource append, "/library/assoc.factor" parse-resource append, diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor index edf3b32046..32a38e6ac1 100644 --- a/library/bootstrap/init-stage2.factor +++ b/library/bootstrap/init-stage2.factor @@ -114,6 +114,5 @@ unparse write " words total" print ! Save a bit of space global [ stdio off ] bind -garbage-collection "factor.image" save-image 0 exit* diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 2017b45a23..0b45a454ae 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -59,8 +59,6 @@ vocabularies get [ [[ "kernel" "ifte" ]] [[ "lists" "cons" ]] [[ "vectors" "" ]] - [[ "vectors" "vector-nth" ]] - [[ "vectors" "set-vector-nth" ]] [[ "strings" "str-nth" ]] [[ "strings" "str-compare" ]] [[ "strings" "str=" ]] diff --git a/library/hashtables.factor b/library/hashtables.factor index 33e65a94cf..9750f2430e 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -25,13 +25,24 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: hashtables +IN: kernel-internals USE: generic USE: kernel USE: lists USE: math USE: vectors +: hash-array vector-array ; inline +: bucket-count >vector hash-array array-capacity ; inline + +: hash-bucket ( n hash -- alist ) + swap >fixnum swap >vector hash-array array-nth ; inline + +: set-hash-bucket ( obj n hash -- ) + >r >fixnum r> hash-array set-array-nth ; inline + +IN: hashtables + ! Note that the length of a hashtable vector must not change ! for the lifetime of the hashtable, otherwise problems will ! occur. Do not use vector words with hashtables. @@ -48,13 +59,13 @@ PREDICATE: vector hashtable ( obj -- ? ) : (hashcode) ( key table -- index ) #! Compute the index of the bucket for a key. - >r hashcode r> vector-length rem ; inline + >r hashcode r> bucket-count rem ; inline : hash* ( key table -- [[ key value ]] ) #! Look up a value in the hashtable. First the bucket is #! determined using the hash function, then the association #! list therein is searched linearly. - 2dup (hashcode) swap vector-nth assoc* ; + 2dup (hashcode) swap hash-bucket assoc* ; : hash ( key table -- value ) #! Unlike hash*, this word cannot distinglish between an @@ -67,9 +78,9 @@ PREDICATE: vector hashtable ( obj -- ? ) 2dup (hashcode) r> pick >r over >r - >r swap vector-nth r> call + >r swap hash-bucket r> call r> - r> set-vector-nth ; inline + r> set-hash-bucket ; inline : set-hash ( value key table -- ) #! Store the value in the hashtable. Either replaces an @@ -85,12 +96,6 @@ PREDICATE: vector hashtable ( obj -- ? ) #! Apply the code to each key/value pair of the hashtable. swap [ swap dup >r each r> ] vector-each drop ; inline -: hash-subset ( hash code -- hash ) - #! Return a new hashtable containing all key/value pairs - #! for which the predicate yielded a true value. The - #! predicate must have stack effect ( obj -- ? ). - swap [ swap dup >r subset r> swap ] vector-map nip ; inline - : hash-keys ( hash -- list ) #! Push a list of keys in a hashtable. [ ] swap [ car swons ] hash-each ; diff --git a/library/inference/branches.factor b/library/inference/branches.factor index c54e1c07a8..d78fe2a164 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -73,7 +73,7 @@ USE: prettyprint : unify-stacks ( list -- stack ) #! Replace differing literals in stacks with unknown #! results. - unify-lengths vector-transpose [ unify-results ] vector-map ; + unify-lengths vector-transpose [ unify-results ] vector-map ; : balanced? ( list -- ? ) #! Check if a list of [[ instack outstack ]] pairs is @@ -104,7 +104,7 @@ USE: prettyprint ] unless* ; : unify-effects ( list -- ) - filter-terminators dup datastack-effect callstack-effect ; + filter-terminators dup datastack-effect callstack-effect ; SYMBOL: cloned diff --git a/library/inference/types.factor b/library/inference/types.factor index 5e6b19d114..7acdc8e7b8 100644 --- a/library/inference/types.factor +++ b/library/inference/types.factor @@ -63,15 +63,15 @@ USE: prettyprint \ >string \ string infer-check ] "infer" set-word-property -\ slot [ - [ object fixnum ] ensure-d - dataflow-drop, pop-d literal-value - peek-d value-class builtin-supertypes dup length 1 = [ - cons \ slot [ [ object ] [ object ] ] (consume/produce) - ] [ - "slot called without static type knowledge" throw - ] ifte -] "infer" set-word-property +! \ slot [ +! [ object fixnum ] ensure-d +! dataflow-drop, pop-d literal-value +! peek-d value-class builtin-supertypes dup length 1 = [ +! cons \ slot [ [ object ] [ object ] ] (consume/produce) +! ] [ +! "slot called without static type knowledge" throw +! ] ifte +! ] "infer" set-word-property : type-value-map ( value -- ) num-types [ dup builtin-type pick swons cons ] project diff --git a/library/kernel.factor b/library/kernel.factor index fe37533502..fb3c4544af 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -31,9 +31,9 @@ USE: kernel USE: vectors : dispatch ( n vtable -- ) - #! This word is unsafe in compiled code since n is not - #! bounds-checked. Do not call it directly. - vector-nth call ; + #! This word is unsafe since n is not bounds-checked. Do not + #! call it directly. + vector-array array-nth call ; IN: kernel diff --git a/library/namespaces.factor b/library/namespaces.factor index e1632b9c47..362f0f3754 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -153,6 +153,11 @@ SYMBOL: list-buffer #! was called. make-rlist reverse ; inline +: make-vector ( quot -- list ) + #! Return a vector whose entries are in the same order that + #! , was called. + make-list list>vector ; inline + : , ( obj -- ) #! Append an object to the currently constructing list. list-buffer cons@ ; diff --git a/library/primitives.factor b/library/primitives.factor index b37e757da9..14fe6e7421 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -55,8 +55,6 @@ USE: words [ ifte [ [ object general-list general-list ] [ ] ] ] [ cons [ [ object object ] [ cons ] ] ] [ [ [ integer ] [ vector ] ] ] - [ vector-nth [ [ integer vector ] [ object ] ] ] - [ set-vector-nth [ [ object integer vector ] [ ] ] ] [ str-nth [ [ integer string ] [ integer ] ] ] [ str-compare [ [ string string ] [ integer ] ] ] [ str= [ [ string string ] [ boolean ] ] ] @@ -222,7 +220,7 @@ USE: words [ set-slot [ [ object object fixnum ] [ ] ] ] [ integer-slot [ [ object fixnum ] [ integer ] ] ] [ set-integer-slot [ [ integer object fixnum ] [ ] ] ] - [ grow-array [ [ integer array ] [ integer ] ] ] + [ grow-array [ [ integer array ] [ object ] ] ] ] [ 2unlist dup string? [ "stack-effect" set-word-property diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 0b901472e3..8a8afb976c 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -6,10 +6,12 @@ USE: test USE: vectors USE: strings USE: namespaces +USE: kernel-internals [ [ t f t ] vector-length ] unit-test-fails [ 3 ] [ { t f t } vector-length ] unit-test +[ -3 { } vector-nth ] unit-test-fails [ 3 { } vector-nth ] unit-test-fails [ 3 #{ 1 2 }# vector-nth ] unit-test-fails @@ -74,3 +76,9 @@ unit-test [ "funny-stack" get vector-pop ] unit-test-fails [ ] [ "funky" "funny-stack" get vector-push ] unit-test [ "funky" ] [ "funny-stack" get vector-pop ] unit-test + +[ t ] [ + 10 dup vector-array array-capacity + >r vector-clone vector-array array-capacity r> + = +] unit-test diff --git a/library/ui/console.factor b/library/ui/console.factor index 9418826963..1b97d2bfaf 100644 --- a/library/ui/console.factor +++ b/library/ui/console.factor @@ -83,6 +83,9 @@ SYMBOL: input-line SYMBOL: console-font #! Font height. SYMBOL: line-height +#! If this is on, the console will be redrawn on the next event +#! refresh cycle. +SYMBOL: redraw-console #! The font size is hardcoded here. : char-width 8 ; @@ -174,8 +177,10 @@ SYMBOL: line-height 0 y set clear-display draw-lines - draw-current - draw-input + height get y get - line-height get >= [ + draw-current + draw-input + ] when draw-scrollbar ] with-surface ; @@ -186,7 +191,7 @@ SYMBOL: line-height lines get vector-push scroll-to-bottom ; : console-write ( text -- ) - "\n" split1 [ + "\n" split1 [ swap output-line get sbuf-append output-line get empty-buffer add-line ] when* @@ -215,7 +220,7 @@ M: console-stream fflush ( stream -- ) M: console-stream fauto-flush ( stream -- ) [ - console get [ draw-console ] bind + console get [ redraw-console on ] bind ] bind ; M: console-stream freadln ( stream -- line ) @@ -280,10 +285,10 @@ SYMBOL: keymap M: key-down-event handle-event ( event -- ? ) dup keyboard-event>binding keymap get hash [ - call draw-console + call redraw-console on ] [ dup input-key? [ - keyboard-event-unicode user-input draw-console + keyboard-event-unicode user-input redraw-console on ] [ drop ] ifte @@ -296,10 +301,10 @@ SYMBOL: drag-start-line : scrollbar-click ( y -- ) dup scrollbar-top < [ - drop page-scroll-up draw-console + drop page-scroll-up redraw-console on ] [ dup scrollbar-bottom > [ - drop page-scroll-down draw-console + drop page-scroll-down redraw-console on ] [ drag-start-y set first-line get drag-start-line set @@ -323,7 +328,7 @@ M: motion-event handle-event ( event -- ? ) motion-event-y drag-start-y get - height get / total-lines * drag-start-line get + >fixnum fix-first-line first-line set - draw-console + redraw-console on ] [ drop ] ifte t ; @@ -332,7 +337,7 @@ M: resize-event handle-event ( event -- ? ) dup resize-event-w swap resize-event-h 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen scroll-to-bottom - draw-console t ; + redraw-console on t ; M: quit-event handle-event ( event -- ? ) drop f ; @@ -366,6 +371,7 @@ M: alien handle-event ( event -- ? ) SDL_EnableKeyRepeat drop ; : console-loop ( -- ) + redraw-console get [ draw-console redraw-console off ] when check-event [ console-loop ] when ; : console-quit ( -- ) @@ -395,7 +401,7 @@ IN: shells ] callcc0 console get [ - draw-console + redraw-console on console-loop console-quit ] bind diff --git a/library/vectors.factor b/library/vectors.factor index ffa7ce67d8..48f149c7ad 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2004 Slava Pestov. +! Copyright (C) 2004, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -25,41 +25,66 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +IN: vectors USE: generic USE: kernel USE: lists USE: math - -IN: errors -DEFER: throw - -IN: kernel-internals - -BUILTIN: array 8 - -! UNSAFE! -: array-capacity ( array -- n ) 1 integer-slot ; inline -: vector-array ( vec -- array ) 2 slot ; inline -: set-vector-array ( array vec -- ) 2 set-slot ; inline - -: grow-vector-array ( len vec -- ) - [ vector-array grow-array ] keep set-vector-array ; inline - -: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline - -IN: vectors +USE: kernel-internals +USE: errors +USE: math-internals BUILTIN: vector 11 : vector-length ( vec -- len ) >vector 1 integer-slot ; inline -: set-vector-length ( len vec -- ) - >vector over 0 < [ - "Vector length must be positive" throw 2drop +IN: kernel-internals + +: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline + +: assert-positive ( fx -- ) + 0 fixnum< + [ "Vector index must be positive" throw ] when ; inline + +: assert-bounds ( fx vec -- ) + over assert-positive + vector-length fixnum>= + [ "Vector index out of bounds" throw ] when ; inline + +: grow-capacity ( len vec -- ) + #! If the vector cannot accomodate len elements, resize it + #! to exactly len. + [ vector-array grow-array ] keep set-vector-array ; inline + +: ensure-capacity ( n vec -- ) + #! If n is beyond the vector's length, increase the length, + #! growing the array if necessary, with an optimistic + #! doubling of its size. + 2dup vector-length fixnum>= [ + >r 1 fixnum+ r> + 2dup vector-array array-capacity fixnum> [ + over 2 fixnum* over grow-capacity + ] when + (set-vector-length) ] [ - 2dup (set-vector-length) grow-vector-array + 2drop ] ifte ; inline +IN: vectors + +: vector-nth ( n vec -- obj ) + swap >fixnum swap >vector + 2dup assert-bounds vector-array array-nth ; + +: set-vector-nth ( obj n vec -- ) + swap >fixnum dup assert-positive swap >vector + 2dup ensure-capacity vector-array + set-array-nth ; + +: set-vector-length ( len vec -- ) + swap >fixnum dup assert-positive swap >vector + 2dup grow-capacity (set-vector-length) ; + : empty-vector ( len -- vec ) #! Creates a vector with 'len' elements set to f. Unlike #! , which gives an empty vector with a certain diff --git a/native/array.h b/native/array.h index 74d56506e7..acc77a0991 100644 --- a/native/array.h +++ b/native/array.h @@ -21,17 +21,5 @@ F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); #define ASIZE(pointer) align8(sizeof(F_ARRAY) + \ ((F_ARRAY*)(pointer))->capacity * CELLS) -/* untagged & unchecked */ -INLINE CELL array_nth(F_ARRAY* array, CELL index) -{ - return get(AREF(array,index)); -} - -/* untagged & unchecked */ -INLINE void set_array_nth(F_ARRAY* array, CELL index, CELL value) -{ - put(AREF(array,index),value); -} - void fixup_array(F_ARRAY* array); void collect_array(F_ARRAY* array); diff --git a/native/gc.c b/native/gc.c index 784677928c..b075429cad 100644 --- a/native/gc.c +++ b/native/gc.c @@ -119,7 +119,7 @@ void primitive_gc(void) fflush(stderr); flip_zones(); - scan = active.here = active.base; + scan = active.base; collect_roots(); collect_io_tasks(); /* collect literal objects referenced from compiled code */ diff --git a/native/image.c b/native/image.c index 75cd0bd0ef..650d8e67d8 100644 --- a/native/image.c +++ b/native/image.c @@ -115,6 +115,8 @@ bool save_image(char* filename) void primitive_save_image(void) { - F_STRING* filename = untag_string(dpop()); + F_STRING* filename; + primitive_gc(); + filename = untag_string(dpop()); save_image(to_c_string(filename)); } diff --git a/native/memory.c b/native/memory.c index 8173732863..62e10b63dc 100644 --- a/native/memory.c +++ b/native/memory.c @@ -87,6 +87,7 @@ void flip_zones() ZONE z = active; active = prior; prior = z; + active.here = active.base; } bool in_zone(ZONE* z, CELL pointer) diff --git a/native/primitives.c b/native/primitives.c index dd7d6a652a..07dd50f034 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -9,8 +9,6 @@ void* primitives[] = { primitive_ifte, primitive_cons, primitive_vector, - primitive_vector_nth, - primitive_set_vector_nth, primitive_string_nth, primitive_string_compare, primitive_string_eq, diff --git a/native/primitives.h b/native/primitives.h index 60736374aa..353fbfe10a 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern void* primitives[]; -#define PRIMITIVE_COUNT 195 +#define PRIMITIVE_COUNT 194 CELL primitive_to_xt(CELL primitive); diff --git a/native/unix/signal.c b/native/unix/signal.c index 40818072c2..d65acfe7c1 100644 --- a/native/unix/signal.c +++ b/native/unix/signal.c @@ -9,6 +9,8 @@ void signal_handler(int signal, siginfo_t* siginfo, void* uap) fprintf(stderr,"active.here = %ld\n",active.here); fprintf(stderr,"active.limit = %ld\n",active.limit); fflush(stderr); + flip_zones(); + dump_stacks(); exit(1); } else diff --git a/native/vector.c b/native/vector.c index 921ea3444d..2b2e4a6866 100644 --- a/native/vector.c +++ b/native/vector.c @@ -22,47 +22,6 @@ void primitive_to_vector(void) type_check(VECTOR_TYPE,dpeek()); } -void primitive_vector_nth(void) -{ - F_VECTOR* vector = untag_vector(dpop()); - CELL index = to_fixnum(dpop()); - - if(index < 0 || index >= vector->top) - range_error(tag_object(vector),0,tag_fixnum(index),vector->top); - dpush(array_nth(untag_array(vector->array),index)); -} - -void vector_ensure_capacity(F_VECTOR* vector, CELL index) -{ - F_ARRAY* array = untag_array(vector->array); - CELL capacity = array->capacity; - if(index >= capacity) - array = grow_array(array,index * 2 + 1,F); - vector->top = index + 1; - vector->array = tag_object(array); -} - -void primitive_set_vector_nth(void) -{ - F_VECTOR* vector; - F_FIXNUM index; - CELL value; - - maybe_garbage_collection(); - - vector = untag_vector(dpop()); - index = to_fixnum(dpop()); - value = dpop(); - - if(index < 0) - range_error(tag_object(vector),0,tag_fixnum(index),vector->top); - else if(index >= vector->top) - vector_ensure_capacity(vector,index); - - /* the following does not check bounds! */ - set_array_nth(untag_array(vector->array),index,value); -} - void fixup_vector(F_VECTOR* vector) { data_fixup(&vector->array); diff --git a/native/vector.h b/native/vector.h index a851779c16..cffc5a7ff4 100644 --- a/native/vector.h +++ b/native/vector.h @@ -17,8 +17,5 @@ F_VECTOR* vector(F_FIXNUM capacity); void primitive_vector(void); void primitive_to_vector(void); -void primitive_vector_nth(void); -void vector_ensure_capacity(F_VECTOR* vector, CELL index); -void primitive_set_vector_nth(void); void fixup_vector(F_VECTOR* vector); void collect_vector(F_VECTOR* vector);