From 93dc7ce736de64ea1138ca7bbe3cbef43e7d2090 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 29 Jan 2005 21:39:30 +0000 Subject: [PATCH] added new tuple metaclass, eventually to replace the traits metaclass --- TODO.FACTOR.txt | 1 + factor/parser/Using.java | 4 +- library/bootstrap/boot-stage2.factor | 36 +---------- library/bootstrap/boot.factor | 39 ++---------- library/bootstrap/primitives.factor | 41 ++---------- library/generic/builtin.factor | 2 +- library/generic/generic.factor | 78 ++++++----------------- library/generic/traits.factor | 2 +- library/generic/tuple.factor | 91 +++++++++++++++++++++++++++ library/kernel.factor | 4 +- library/namespaces.factor | 5 ++ library/primitives.factor | 1 + library/test/benchmark/vectors.factor | 2 +- native/array.c | 17 +++-- native/array.h | 3 +- native/factor.h | 4 +- native/gc.c | 1 + native/hashtable.c | 2 +- native/primitives.c | 3 +- native/relocate.c | 1 + native/types.c | 1 + native/types.h | 5 +- native/vector.c | 2 +- 23 files changed, 163 insertions(+), 182 deletions(-) create mode 100644 library/generic/tuple.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 705daa5a99..be31f5fcbd 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -39,6 +39,7 @@ - maple-like: press enter at old commands to evaluate there - completion in the listener - special completion for USE:/IN: +- support USING: + i/o: diff --git a/factor/parser/Using.java b/factor/parser/Using.java index 9f36bfc470..b4af3a3d35 100644 --- a/factor/parser/Using.java +++ b/factor/parser/Using.java @@ -3,7 +3,7 @@ /* * $Id$ * - * Copyright (C) 2004 Slava Pestov. + * 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: @@ -44,7 +44,7 @@ public class Using extends FactorParsingDefinition for(;;) { Object next = reader.next(false,false); - if(next == null) + if(next == FactorScanner.EOF) reader.getScanner().error("Expected ;"); if(next.equals(";")) break; diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index d7cc3a86e3..2ba7557c7b 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -1,37 +1,6 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! ! 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: -! -! 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: init -USE: kernel -USE: lists -USE: parser -USE: stdio -USE: words -USE: namespaces +! See http://factor.sf.net/license.txt for BSD license. +USING: kernel lists parser stdio words namespaces ; "Cold boot in progress..." print @@ -44,6 +13,7 @@ USE: namespaces "/library/generic/union.factor" "/library/generic/complement.factor" "/library/generic/traits.factor" + "/library/generic/tuple.factor" "/version.factor" "/library/stack.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 981d27daa9..64de946fe1 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -1,39 +1,7 @@ -! :folding=none:collapseFolds=1: - -! $Id$ -! ! 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: -! -! 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. - -USE: lists -USE: image -USE: parser -USE: namespaces -USE: stdio -USE: kernel -USE: vectors -USE: words -USE: hashtables +! See http://factor.sf.net/license.txt for BSD license. +USING: lists image parser namespaces stdio kernel vectors +words hashtables ; "/library/bootstrap/primitives.factor" run-resource @@ -88,6 +56,7 @@ USE: hashtables "/library/generic/union.factor" parse-resource append, "/library/generic/complement.factor" parse-resource append, "/library/generic/traits.factor" parse-resource append, + "/library/generic/tuple.factor" parse-resource append, "/library/bootstrap/init.factor" parse-resource append, "/library/syntax/parse-syntax.factor" parse-resource append, diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 8484cc844a..744f4e7576 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -1,40 +1,8 @@ -! :folding=none:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: image -USE: kernel -USE: lists -USE: math -USE: namespaces -USE: parser -USE: words -USE: vectors -USE: hashtables -USE: generic +USING: kernel lists math namespaces parser words vectors +hashtables generic ; ! Bring up a bare cross-compiling vocabulary. "syntax" vocab @@ -226,6 +194,7 @@ vocabularies get [ [[ "kernel-internals" "grow-array" ]] [[ "hashtables" "" ]] [[ "kernel-internals" "" ]] + [[ "kernel-internals" "" ]] ] [ unswons create swap 1 + [ f define ] keep ] each drop diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index 9d53bb2f14..d61dc5369d 100644 --- a/library/generic/builtin.factor +++ b/library/generic/builtin.factor @@ -83,7 +83,7 @@ builtin [ 2drop t ] "class<" set-word-property : builtin-type ( n -- symbol ) unit classes get hash ; -: class ( obj -- class ) +M: object class ( obj -- class ) #! Analogous to the type primitive. Pushes the builtin #! class of an object. type builtin-type ; diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 24cac9d733..83410dc1ef 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -1,50 +1,11 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2004 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. - +! Copyright (C) 2004, 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. IN: generic -USE: errors -USE: hashtables -USE: kernel -USE: kernel-internals -USE: lists -USE: namespaces -USE: parser -USE: strings -USE: words -USE: vectors -USE: math -USE: math-internals -USE: unparser +USING: errors hashtables kernel kernel-internals lists +namespaces parser strings words vectors math math-internals ; ! A simple single-dispatch generic word system. -! "if I say I'd rather eat cheese than shit... doesn't mean -! those are the only two things I can eat." - Tac - : predicate-word ( word -- word ) word-name "?" cat2 "in" get create ; @@ -60,7 +21,7 @@ USE: unparser ! The class of an object with traits is determined by the object ! identity of the traits method map. ! - metaclass: a metaclass is a symbol with a handful of word -! properties: "define-method" "builtin-types" "priority" +! properties: "builtin-types" "priority" ! Metaclasses have priority -- this induces an order in which ! methods are added to the vtable. @@ -107,12 +68,13 @@ USE: unparser >r 2dup r> unswons add-method ] each nip ; -: define-generic ( word vtable -- ) +: make-generic ( word vtable -- ) over "combination" word-property cons define-compound ; -: (define-method) ( definition class generic -- ) +: define-method ( class generic definition -- ) + -rot [ "methods" word-property set-hash ] keep dup - define-generic ; + make-generic ; : init-methods ( word -- ) dup "methods" word-property [ @@ -122,15 +84,14 @@ USE: unparser ] ifte ; ! Defining generic words -: (GENERIC) ( combination definer -- ) +: define-generic ( combination definer word -- ) #! Takes a combination parameter. A combination is a #! quotation that takes some objects and a vtable from the #! stack, and calls the appropriate row of the vtable. - CREATE [ swap "definer" set-word-property ] keep [ swap "combination" set-word-property ] keep dup init-methods - dup define-generic ; + dup make-generic ; : single-combination ( obj vtable -- ) >r dup type r> dispatch ; inline @@ -138,7 +99,8 @@ USE: unparser : GENERIC: #! GENERIC: bar creates a generic word bar. Add methods to #! the generic word using M:. - [ single-combination ] \ GENERIC: (GENERIC) ; parsing + [ single-combination ] + \ GENERIC: CREATE define-generic ; parsing : arithmetic-combination ( n n vtable -- ) #! Note that the numbers remain on the stack, possibly after @@ -150,19 +112,13 @@ USE: unparser #! the generic word using M:. 2GENERIC words dispatch on #! arithmetic types and should not be used for non-numerical #! types. - [ arithmetic-combination ] \ 2GENERIC: (GENERIC) ; parsing - -: define-method ( class -- quotation ) - #! In a vain attempt at something resembling a "meta object - #! protocol", we call the "define-method" word property with - #! stack ( class generic definition -- ). - metaclass "define-method" word-property - [ [ -rot (define-method) ] ] unless* ; + [ arithmetic-combination ] + \ 2GENERIC: CREATE define-generic ; parsing : M: ( -- class generic [ ] ) #! M: foo bar begins a definition of the bar generic word #! specialized to the foo type. - scan-word dup define-method scan-word swap [ ] ; parsing + scan-word scan-word [ define-method ] [ ] ; parsing ! Maps lists of builtin type numbers to class objects. SYMBOL: classes @@ -210,3 +166,5 @@ SYMBOL: object classes get set-hash ; classes get [ classes set ] unless + +GENERIC: class ( obj -- class ) diff --git a/library/generic/traits.factor b/library/generic/traits.factor index 2bafb8053c..12c2c88cf2 100644 --- a/library/generic/traits.factor +++ b/library/generic/traits.factor @@ -67,7 +67,7 @@ SYMBOL: delegate ] "add-method" set-word-property \ traits [ - drop vector "builtin-type" word-property unit + drop hashtable "builtin-type" word-property unit ] "builtin-supertypes" set-word-property \ traits 10 "priority" set-word-property diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor new file mode 100644 index 0000000000..e6224559d8 --- /dev/null +++ b/library/generic/tuple.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2005 Slava Pestov. +! See http://factor.sf.net/license.txt for BSD license. +IN: generic +USING: words parser kernel namespaces lists strings +kernel-internals math hashtables errors ; + +: make-tuple ( class -- ) + dup "tuple-size" word-property + [ 0 swap set-array-nth ] keep ; + +: define-tuple-generic ( tuple word def -- ) + over >r \ single-combination \ GENERIC: r> define-generic + define-method ; + +: define-accessor ( word name n -- ) + >r [ >r dup word-name , "-" , r> , ] make-string + "in" get create r> [ slot ] cons define-tuple-generic ; + +: define-mutator ( word name n -- ) + >r [ "set-" , >r dup word-name , "-" , r> , ] make-string + "in" get create r> [ set-slot ] cons define-tuple-generic ; + +: define-field ( word name n -- ) + 3dup define-accessor define-mutator ; + +: tuple-predicate ( word -- ) + #! Make a foo? word for testing the tuple class at the top + #! of the stack. + dup predicate-word swap + [ swap dup tuple? [ class eq? ] [ 2drop f ] ifte ] cons + define-compound ; + +: define-tuple ( word fields -- ) + 2dup length 1 + "tuple-size" set-word-property + dup length [ 3 + ] project zip + [ uncons define-field ] each-with ; + +: TUPLE: + #! Followed by a tuple name, then field names, then ; + CREATE + dup intern-symbol + dup tuple-predicate + dup define-promise + dup tuple "metaclass" set-word-property + string-mode on + [ string-mode off define-tuple ] + f ; parsing + +: constructor-word ( word -- word ) + word-name "<" swap ">" cat3 "in" get create ; + +: tuple-constructor ( word def -- ) + over constructor-word >r + [ swap literal, \ make-tuple , append, ] make-list + r> swap define-compound ; + +: TC: + #! Followed by a tuple name, then constructor code, then ; + #! Constructor code executes with the empty tuple on the + #! stack. + scan-word [ tuple-constructor ] f ; parsing + +: tuple-dispatch ( object selector -- object quot ) + over class over "methods" word-property hash* dup [ + nip cdr ( method is defined ) + ] [ + ! drop delegate rot hash [ + ! swap tuple-dispatch ( check delegate ) + ! ] [ + [ undefined-method ] ( no delegate ) + ! ] ifte* + ] ifte ; + +: add-tuple-dispatch ( word vtable -- ) + >r unit [ car tuple-dispatch call ] cons tuple r> + set-vtable ; + +M: tuple class ( obj -- class ) 2 slot ; + +tuple [ + ( generic vtable definition class -- ) + 2drop add-tuple-dispatch +] "add-method" set-word-property + +tuple [ + drop tuple "builtin-type" word-property unit +] "builtin-supertypes" set-word-property + +tuple 10 "priority" set-word-property + +tuple [ 2drop t ] "class<" set-word-property diff --git a/library/kernel.factor b/library/kernel.factor index d5e298a28e..6002ab66c5 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -7,6 +7,8 @@ IN: kernel-internals USING: generic kernel vectors ; #! call it directly. vector-array array-nth call ; +BUILTIN: tuple 18 + IN: kernel GENERIC: hashcode ( obj -- n ) @@ -32,7 +34,7 @@ M: object clone ; : num-types ( -- n ) #! One more than the maximum value from type primitive. - 18 ; + 19 ; : ? ( cond t f -- t/f ) #! Push t if cond is true, otherwise push f. diff --git a/library/namespaces.factor b/library/namespaces.factor index 93a4f99307..1519c2fdd0 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -141,3 +141,8 @@ SYMBOL: list-buffer : append, ( list -- ) [ , ] each ; + +: literal, ( word -- ) + #! Append some code that pushes the word on the stack. Used + #! when building quotations. + unit , \ car , ; diff --git a/library/primitives.factor b/library/primitives.factor index 3594354fa5..3a9f4d3b80 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -184,6 +184,7 @@ hashtables ; [ grow-array [ [ integer array ] [ object ] ] ] [ [ [ number ] [ hashtable ] ] ] [ [ [ number ] [ array ] ] ] + [ [ [ number ] [ tuple ] ] ] ] [ 2unlist dup string? [ "stack-effect" set-word-property diff --git a/library/test/benchmark/vectors.factor b/library/test/benchmark/vectors.factor index 8d6a767991..2afe570946 100644 --- a/library/test/benchmark/vectors.factor +++ b/library/test/benchmark/vectors.factor @@ -20,4 +20,4 @@ USE: test : vector-benchmark ( n -- ) 0 over fill-vector rot copy-vector ; compiled -[ ] [ 4000000 vector-benchmark ] unit-test +[ ] [ 400000 vector-benchmark ] unit-test diff --git a/native/array.c b/native/array.c index 191d234470..d7e7b97510 100644 --- a/native/array.c +++ b/native/array.c @@ -10,11 +10,11 @@ F_ARRAY* allot_array(CELL type, CELL capacity) } /* untagged */ -F_ARRAY* array(CELL capacity, CELL fill) +F_ARRAY* array(CELL type, CELL capacity, CELL fill) { int i; - F_ARRAY* array = allot_array(ARRAY_TYPE, capacity); + F_ARRAY* array = allot_array(type, capacity); for(i = 0; i < capacity; i++) put(AREF(array,i),fill); @@ -28,7 +28,16 @@ void primitive_array(void) if(capacity < 0) general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity)); maybe_garbage_collection(); - dpush(tag_object(array(capacity,F))); + dpush(tag_object(array(ARRAY_TYPE,capacity,F))); +} + +void primitive_tuple(void) +{ + F_FIXNUM capacity = to_fixnum(dpop()); + if(capacity < 0) + general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity)); + maybe_garbage_collection(); + dpush(tag_object(array(TUPLE_TYPE,capacity,F))); } F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill) @@ -43,7 +52,7 @@ F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill) new_array = allot_array(untag_header(array->header),capacity); - memcpy(new_array + 1,array + 1,array->capacity * CELLS); + memcpy(new_array + 1,array + 1,curr_cap * CELLS); for(i = curr_cap; i < capacity; i++) put(AREF(new_array,i),fill); diff --git a/native/array.h b/native/array.h index 28d71a4b41..7f048c0f0f 100644 --- a/native/array.h +++ b/native/array.h @@ -11,8 +11,9 @@ INLINE F_ARRAY* untag_array(CELL tagged) } F_ARRAY* allot_array(CELL type, CELL capacity); -F_ARRAY* array(CELL capacity, CELL fill); +F_ARRAY* array(CELL type, CELL capacity, CELL fill); void primitive_array(void); +void primitive_tuple(void); F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill); void primitive_grow_array(void); F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); diff --git a/native/factor.h b/native/factor.h index 49f7ed2a60..d0749dc2be 100644 --- a/native/factor.h +++ b/native/factor.h @@ -101,8 +101,8 @@ DLLEXPORT CELL cs; typedef unsigned char BYTE; /* Memory areas */ -#define DEFAULT_ARENA (64 * 1024 * 1024) -#define COMPILE_ZONE_SIZE (64 * 1024 * 1024) +#define DEFAULT_ARENA (8 * 1024 * 1024) +#define COMPILE_ZONE_SIZE (8 * 1024 * 1024) #define STACK_SIZE (2 * 1024 * 1024) #include "memory.h" diff --git a/native/gc.c b/native/gc.c index 5e2c880970..6c33083a43 100644 --- a/native/gc.c +++ b/native/gc.c @@ -69,6 +69,7 @@ INLINE void collect_object(CELL scan) collect_word((F_WORD*)scan); break; case ARRAY_TYPE: + case TUPLE_TYPE: collect_array((F_ARRAY*)scan); break; case HASHTABLE_TYPE: diff --git a/native/hashtable.c b/native/hashtable.c index cb27bd4c01..25ce2e72bc 100644 --- a/native/hashtable.c +++ b/native/hashtable.c @@ -7,7 +7,7 @@ F_HASHTABLE* hashtable(F_FIXNUM capacity) general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity)); hash = allot_object(HASHTABLE_TYPE,sizeof(F_VECTOR)); hash->count = tag_fixnum(0); - hash->array = tag_object(array(capacity,F)); + hash->array = tag_object(array(ARRAY_TYPE,capacity,F)); return hash; } diff --git a/native/primitives.c b/native/primitives.c index bf0723d7a9..3a426e454c 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -175,7 +175,8 @@ void* primitives[] = { primitive_set_integer_slot, primitive_grow_array, primitive_hashtable, - primitive_array + primitive_array, + primitive_tuple }; CELL primitive_to_xt(CELL primitive) diff --git a/native/relocate.c b/native/relocate.c index c6dfd0e73b..63abe8940c 100644 --- a/native/relocate.c +++ b/native/relocate.c @@ -8,6 +8,7 @@ void relocate_object(CELL relocating) fixup_word((F_WORD*)relocating); break; case ARRAY_TYPE: + case TUPLE_TYPE: fixup_array((F_ARRAY*)relocating); break; case HASHTABLE_TYPE: diff --git a/native/types.c b/native/types.c index a4048d22ed..d034b67be2 100644 --- a/native/types.c +++ b/native/types.c @@ -53,6 +53,7 @@ CELL untagged_object_size(CELL pointer) break; case ARRAY_TYPE: case BIGNUM_TYPE: + case TUPLE_TYPE: size = ASIZE(pointer); break; case HASHTABLE_TYPE: diff --git a/native/types.h b/native/types.h index ac481e47da..a5c51fb60a 100644 --- a/native/types.h +++ b/native/types.h @@ -12,7 +12,7 @@ #define RATIO_TYPE 4 #define FLOAT_TYPE 5 #define COMPLEX_TYPE 6 -#define HEADER_TYPE 7 +#define HEADER_TYPE 7 /* anything less than this is a tag */ #define GC_COLLECTED 7 /* See gc.c */ /*** Header types ***/ @@ -35,8 +35,9 @@ CELL T; #define DLL_TYPE 15 #define ALIEN_TYPE 16 #define WORD_TYPE 17 +#define TUPLE_TYPE 18 -#define TYPE_COUNT 18 +#define TYPE_COUNT 19 INLINE bool headerp(CELL cell) { diff --git a/native/vector.c b/native/vector.c index 010c1f6b58..e75b6b4ffc 100644 --- a/native/vector.c +++ b/native/vector.c @@ -7,7 +7,7 @@ F_VECTOR* vector(F_FIXNUM capacity) general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity)); vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR)); vector->top = tag_fixnum(0); - vector->array = tag_object(array(capacity,F)); + vector->array = tag_object(array(ARRAY_TYPE,capacity,F)); return vector; }