added new tuple metaclass, eventually to replace the traits metaclass

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:
 

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;

library/bootstrap/boot-stage2.factor

@@ -1,37 +1,6 @@
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
 ! Copyright (C) 2004, 2005 Slava Pestov.
-! 
+! See http://factor.sf.net/license.txt for BSD license.
-! Redistribution and use in source and binary forms, with or without
+USING: kernel lists parser stdio words namespaces ;
-! 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
 
 "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"

library/bootstrap/boot.factor

@@ -1,39 +1,7 @@
-! :folding=none:collapseFolds=1:
-
-! $Id$
-!
 ! Copyright (C) 2004, 2005 Slava Pestov.
-! 
+! See http://factor.sf.net/license.txt for BSD license.
-! Redistribution and use in source and binary forms, with or without
+USING: lists image parser namespaces stdio kernel vectors
-! modification, are permitted provided that the following conditions are met:
+words hashtables ;
-! 
-! 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
 
 "/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,

library/bootstrap/primitives.factor

@@ -1,40 +1,8 @@
-! :folding=none:collapseFolds=1:
+! Copyright (C) 2004, 2005 Slava Pestov.
-
+! See http://factor.sf.net/license.txt for BSD license.
-! $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.
-
 IN: image
-USE: kernel
+USING: kernel lists math namespaces parser words vectors
-USE: lists
+hashtables generic ;
-USE: math
-USE: namespaces
-USE: parser
-USE: words
-USE: vectors
-USE: hashtables
-USE: generic
 
 ! Bring up a bare cross-compiling vocabulary.
 "syntax" vocab
@@ -226,6 +194,7 @@ vocabularies get [
     [[ "kernel-internals" "grow-array" ]]
     [[ "hashtables" "<hashtable>" ]]
     [[ "kernel-internals" "<array>" ]]
+    [[ "kernel-internals" "<tuple>" ]]
 ] [
     unswons create swap 1 + [ f define ] keep
 ] each drop

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 ;

library/generic/generic.factor

@@ -1,50 +1,11 @@
-! :folding=indent:collapseFolds=1:
+! Copyright (C) 2004, 2005 Slava Pestov.
-
+! See http://factor.sf.net/license.txt for BSD license.
-! $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.
-
 IN: generic
-USE: errors
+USING: errors hashtables kernel kernel-internals lists
-USE: hashtables
+namespaces parser strings words vectors math math-internals ;
-USE: kernel
-USE: kernel-internals
-USE: lists
-USE: namespaces
-USE: parser
-USE: strings
-USE: words
-USE: vectors
-USE: math
-USE: math-internals
-USE: unparser
 
 ! 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 <vtable>
-    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 <vtable> define-generic ;
+    dup <vtable> 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
+    [ arithmetic-combination ]
-
+    \ 2GENERIC: CREATE define-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* ;
 
 : 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 [ <namespace> classes set ] unless
+
+GENERIC: class ( obj -- class )

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

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 <tuple>
+    [ 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

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.

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 , ;

library/primitives.factor

@@ -184,6 +184,7 @@ hashtables ;
     [ grow-array             [ [ integer array ] [ object ] ] ]
     [ <hashtable>            [ [ number ] [ hashtable ] ] ]
     [ <array>                [ [ number ] [ array ] ] ]
+    [ <tuple>                [ [ number ] [ tuple ] ] ]
 ] [
     2unlist dup string? [
         "stack-effect" set-word-property

library/test/benchmark/vectors.factor

@@ -20,4 +20,4 @@ USE: test
 : vector-benchmark ( n -- )
     0 <vector> over fill-vector rot copy-vector ; compiled
 
-[ ] [ 4000000 vector-benchmark ] unit-test
+[ ] [ 400000 vector-benchmark ] unit-test

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);

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);

native/factor.h

@@ -101,8 +101,8 @@ DLLEXPORT CELL cs;
 typedef unsigned char BYTE;
 
 /* Memory areas */
-#define DEFAULT_ARENA (64 * 1024 * 1024)
+#define DEFAULT_ARENA (8 * 1024 * 1024)
-#define COMPILE_ZONE_SIZE (64 * 1024 * 1024)
+#define COMPILE_ZONE_SIZE (8 * 1024 * 1024)
 #define STACK_SIZE (2 * 1024 * 1024)
 
 #include "memory.h"

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:

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;
 }
 

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)

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:

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:

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)
 {

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;
 }