Menu
▾
▴
clisp-cvs digest, Vol 1 #360 - 7 msgs
|
From: <cli...@li...> - 2004-02-22 17:02:00
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. "clisp/src predtype.d,1.84,1.85 pathname.d,1.295,1.296 lispbibl.d,1.416,1.417 encoding.d,1.101,1.102 array.d,1.80,1.81" (sd...@us...) 2. "clisp/ffcall ffcall.spec,1.1,1.2" (ha...@us...) 3. "clisp/src loadform.lisp,1.13,1.14 ChangeLog,1.2597,1.2598" (ha...@us...) 4. "clisp/src ChangeLog,1.2598,1.2599 lispbibl.d,1.417,1.418" (ha...@us...) 5. "clisp/src genclisph.d,1.89,1.90 ChangeLog,1.2599,1.2600" (ha...@us...) 6. "clisp/src array.d,1.81,1.82" (ha...@us...) 7. "clisp/src io.d,1.190,1.191 array.d,1.82,1.83 lispbibl.d,1.418,1.419 sequence.d,1.68,1.69 spvw_circ.d,1.22,1.23 spvw_garcol.d,1.57,1.58 spvw_genera1.d,1.21,1.22 spvw_objsize.d,1.15,1.16 spvw_typealloc.d,1.29,1.30 spvw_update.d,1.17,1.18 type.lisp,1.50,1.51 hashtabl.d,1.63,1.64 predtype.d,1.85,1.86 genclisph.d,1.90,1.91 ChangeLog,1.2600,1.2601" (ha...@us...) --__--__-- Message: 1 From: sd...@us... To: cli...@li... Subject: "clisp/src predtype.d,1.84,1.85 pathname.d,1.295,1.296 lispbibl.d,1.416,1.417 encoding.d,1.101,1.102 array.d,1.80,1.81" Date: Sat, 21 Feb 2004 23:23:25 -0800 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18882/src Modified Files: predtype.d pathname.d lispbibl.d encoding.d array.d Log Message: restored G++ compilability Index: predtype.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/predtype.d,v retrieving revision 1.84 retrieving revision 1.85 diff -u -d -r1.84 -r1.85 --- predtype.d 17 Feb 2004 23:51:18 -0000 1.84 +++ predtype.d 22 Feb 2004 07:23:21 -0000 1.85 @@ -1552,8 +1552,9 @@ this means that TYPE-OF must distinguish between positive and negative integers: */ case_fixnum: /* Fixnum -> BIT or FIXNUM+ or FIXNUM- */ - value1 = (eq(arg,Fixnum_0) || eq(arg,Fixnum_1) ? S(bit) : - positivep(arg) ? O(type_posfixnum) : O(type_negfixnum)); + value1 = (eq(arg,Fixnum_0) || eq(arg,Fixnum_1) ? (object)S(bit) + : positivep(arg) ? (object)O(type_posfixnum) + : (object)O(type_negfixnum)); break; case_bignum: /* Bignum -> BIGNUM+ or BIGNUM- */ value1 = positivep(arg) ? O(type_posbignum) : O(type_negbignum); break; Index: pathname.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/pathname.d,v retrieving revision 1.295 retrieving revision 1.296 diff -u -d -r1.295 -r1.296 --- pathname.d 20 Feb 2004 22:13:13 -0000 1.295 +++ pathname.d 22 Feb 2004 07:23:21 -0000 1.296 @@ -5908,7 +5908,7 @@ } }); /* file existed, was deleted -> pathname (/=NIL) as value */ - VALUES1(nullp(O(ansi)) ? STACK_1 : T); skipSTACK(2); + VALUES1(nullp(O(ansi)) ? (object)STACK_1 : T); skipSTACK(2); } /* error-message because of renaming attempt of an opened file Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.416 retrieving revision 1.417 diff -u -d -r1.416 -r1.417 --- lispbibl.d 19 Feb 2004 18:17:55 -0000 1.416 +++ lispbibl.d 22 Feb 2004 07:23:22 -0000 1.417 @@ -10230,7 +10230,7 @@ # > obj: a Symbol or (SETF symbol) # < result: Block-name, a Symbol #define funname_blockname(obj) \ - (atomp(obj) ? (obj) : Car(Cdr(obj))) + (atomp(obj) ? (object)obj : (object)Car(Cdr(obj))) # UP: Determines, whether a Symbol is a Macro in the current Environment. # sym_macrop(symbol) Index: encoding.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/encoding.d,v retrieving revision 1.101 retrieving revision 1.102 diff -u -d -r1.101 -r1.102 --- encoding.d 20 Jan 2004 11:32:04 -0000 1.101 +++ encoding.d 22 Feb 2004 07:23:22 -0000 1.102 @@ -2354,7 +2354,7 @@ { "UTF-8", Symbol_value(S(utf_8)) } }; int ii; - name = canonicalize_encoding(name); + name = canonicalize_encoding((char*)name); for (ii=0; ii < sizeof(encoding_table)/sizeof(struct enc_tab); ii++) if (asciz_equal(name,encoding_table[ii].name)) break; if (ii < sizeof(encoding_table)/sizeof(struct enc_tab)) /* found! */ Couldn't generate diff; no version number found in filespec: array.d,1.80,1.81" --__--__-- Message: 2 From: ha...@us... To: cli...@li... Subject: "clisp/ffcall ffcall.spec,1.1,1.2" Date: Sun, 22 Feb 2004 05:35:05 -0800 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/ffcall In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv25263 Modified Files: ffcall.spec Log Message: Forgot to bump the version number. Couldn't generate diff; no version number found in filespec: ffcall.spec,1.1,1.2" --__--__-- Message: 3 From: ha...@us... To: cli...@li... Subject: "clisp/src loadform.lisp,1.13,1.14 ChangeLog,1.2597,1.2598" Date: Sun, 22 Feb 2004 08:32:55 -0800 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31743/src Modified Files: loadform.lisp ChangeLog Log Message: Provide a condition type with a format-control. Index: loadform.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/loadform.lisp,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- loadform.lisp 1 Feb 2004 20:49:19 -0000 1.13 +++ loadform.lisp 22 Feb 2004 16:32:50 -0000 1.14 @@ -33,12 +33,13 @@ ;; doesn't work when make-load-form is traced. (define-condition missing-load-form (simple-error) (($object :initarg :object :reader missing-load-form-object))) +(define-condition simple-missing-load-form (simple-error missing-load-form) ()) (defun signal-missing-load-form (object) (let ((class (class-name (class-of object)))) - (error-of-type 'missing-load-form :object object - (TEXT "A method on ~S for class ~S is necessary for externalizing an object of class ~S, according to ANSI CL 3.2.4.4, but no such method is defined.") - 'make-load-form class class))) + (error-of-type 'simple-missing-load-form :object object + (TEXT "A method on ~S for class ~S is necessary for externalizing the object ~S, according to ANSI CL 3.2.4.4, but no such method is defined.") + 'make-load-form class object))) (defgeneric make-load-form (object &optional environment) ;; <http://www.lisp.org/HyperSpec/Body/stagenfun_make-load-form.html> Couldn't generate diff; no version number found in filespec: ChangeLog,1.2597,1.2598" --__--__-- Message: 4 From: ha...@us... To: cli...@li... Subject: "clisp/src ChangeLog,1.2598,1.2599 lispbibl.d,1.417,1.418" Date: Sun, 22 Feb 2004 08:34:35 -0800 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv32126/src Modified Files: ChangeLog lispbibl.d Log Message: Fix a compilation error when TYPECODES is in use. Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.2598 retrieving revision 1.2599 diff -u -d -r1.2598 -r1.2599 --- ChangeLog 22 Feb 2004 16:32:51 -0000 1.2598 +++ ChangeLog 22 Feb 2004 16:34:30 -0000 1.2599 @@ -1,5 +1,9 @@ 2004-02-14 Bruno Haible <br...@cl...> + * lispbibl.d (cclosure_flags) [TYPECODES]: Fix. + +2004-02-14 Bruno Haible <br...@cl...> + * loadform.lisp (simple-missing-load-form): New type. (signal-missing-load-form): Show the object as well. Couldn't generate diff; no version number found in filespec: lispbibl.d,1.417,1.418" --__--__-- Message: 5 From: ha...@us... To: cli...@li... Subject: "clisp/src genclisph.d,1.89,1.90 ChangeLog,1.2599,1.2600" Date: Sun, 22 Feb 2004 08:37:04 -0800 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv32697/src Modified Files: genclisph.d ChangeLog Log Message: Make consistent with lispbibl.d. Fix various compilation errors. Index: genclisph.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/genclisph.d,v retrieving revision 1.89 retrieving revision 1.90 diff -u -d -r1.89 -r1.90 --- genclisph.d 1 Feb 2004 20:48:53 -0000 1.89 +++ genclisph.d 22 Feb 2004 16:37:00 -0000 1.90 @@ -1,6 +1,6 @@ /* * Export CLISP internals for modules - * Bruno Haible 1994-2002 + * Bruno Haible 1994-2004 * Sam Steingold 1998-2003 */ @@ -865,7 +865,7 @@ printf1("#define make_machine(ptr) as_object((oint)(ptr)+%d)\n",machine_bias); #endif #endif - printf3("#define make_system(data) type_data_object(%d,%x | (%x & (data)))\n",(tint)system_type,(oint)(bit(oint_data_len-1) | bit(0)),(oint)(bit(oint_data_len)-1)); + printf3("#define make_system(data) type_data_object(%d,%x | (%x & (data)))\n",(tint)system_type,(oint)(bit(oint_data_len-1) | bit(0)),(oint)(bitm(oint_data_len)-1)); printf("#define unbound make_system(0x%x)\n",0xFFFFFFUL); printf("#define nullobj make_machine(0)\n"); #ifdef TYPECODES @@ -1040,20 +1040,20 @@ #ifdef TYPECODES printf2("#define vectorp(obj) ((tint)(typecode(obj) - %d) <= (tint)%d)\n",(tint)sbvector_type,(tint)(vector_type-sbvector_type)); #else - printf1("#define vectorp(obj) (varobjectp(obj) && ((uintB)(Record_type(obj) - 1) <= %d))\n",23-1); + printf2("#define vectorp(obj) (varobjectp(obj) && ((uintB)(Record_type(obj) - %d) <= %d))\n",Rectype_vector,Rectype_string-Rectype_vector); #endif #ifdef TYPECODES - printf2("#define simple_vector_p(obj) (typecode(obj) == %d)\n",(tint)svector_type); + printf1("#define simple_vector_p(obj) (typecode(obj) == %d)\n",(tint)svector_type); #else printf1("#define simple_vector_p(obj) (varobjectp(obj) && (Record_type(obj) == %d))\n",Rectype_Svector); #endif -/* #ifdef TYPECODES - printf2("#define general_vector_p(obj) ((typecode(obj) & ~%d) == %d)\n",(tint)bit(notsimple_bit_t),(tint)svector_type); - #else - printf2("#define general_vector_p(obj) (varobjectp(obj) && ((Record_type(obj) & ~%d) == %d))\n",Rectype_Svector^Rectype_vector,Rectype_Svector&Rectype_vector); - #endif */ #ifdef TYPECODES - printf2("#define simple_string_p(obj) (typecode(obj) == %d)\n",(tint)sstring_type); + printf2("#define general_vector_p(obj) ((typecode(obj) & ~%d) == %d)\n",(tint)bit(notsimple_bit_t),(tint)svector_type); +#else + printf2("#define general_vector_p(obj) (varobjectp(obj) && ((Record_type(obj) & ~%d) == %d))\n",Rectype_Svector^Rectype_vector,Rectype_Svector&Rectype_vector); +#endif +#ifdef TYPECODES + printf1("#define simple_string_p(obj) (typecode(obj) == %d)\n",(tint)sstring_type); #else printf("#define simple_string_p(obj) (varobjectp(obj) && ((uintB)(Record_type(obj) - %d) <= %d))\n",Rectype_S8string,Rectype_reallocstring - Rectype_S8string); #endif @@ -1063,20 +1063,20 @@ printf("#define stringp(obj) (varobjectp(obj) && ((uintB)(Record_type(obj) - %d) <= %d))\n",Rectype_S8string,Rectype_reallocstring - Rectype_S8string); #endif #ifdef TYPECODES - printf1("#define simple_bit_vector_p(atype,obj) (typecode(obj) == Array_type_simple_bit_vector(atype))\n"); + printf("#define simple_bit_vector_p(atype,obj) (typecode(obj) == Array_type_simple_bit_vector(atype))\n"); #else printf1("#define simple_bit_vector_p(atype,obj) (varobjectp(obj) && (Record_type(obj) == %d+(atype)))\n",Rectype_Sbvector); #endif #ifdef TYPECODES - printf2("#define bit_vector_p(atype,obj) ((typecode(obj) & ~%d) == Array_type_simple_bit_vector(atype))\n",(tint)bit(notsimple_bit_t)); + printf1("#define bit_vector_p(atype,obj) ((typecode(obj) & ~%d) == Array_type_simple_bit_vector(atype))\n",(tint)bit(notsimple_bit_t)); #else printf2("#define bit_vector_p(atype,obj) (varobjectp(obj) && ((Record_type(obj) & ~%d) == %d+(atype)))\n",Rectype_Sbvector^Rectype_bvector,Rectype_Sbvector&Rectype_bvector); #endif -/* #ifdef TYPECODES - printf2("#define arrayp(obj) ((tint)(typecode(obj) - %d) <= (tint)%d)\n",(tint)mdarray_type,(tint)(vector_type-mdarray_type)); - #else - printf1("#define arrayp(obj) (varobjectp(obj) && ((uintB)(Record_type(obj)-1) <= %d))\n",24-1); - #endif */ +#ifdef TYPECODES + printf2("#define arrayp(obj) ((tint)(typecode(obj) - %d) <= (tint)%d)\n",(tint)mdarray_type,(tint)(vector_type-mdarray_type)); +#else + printf2("#define arrayp(obj) (varobjectp(obj) && ((uintB)(Record_type(obj)-%d) <= %d))\n",Rectype_vector,Rectype_mdarray-Rectype_vector); +#endif printf("extern object array_displace_check (object array, uintL size, uintL* index);\n"); printf("extern uintL vector_length (object vector);\n"); #ifdef TYPECODES @@ -1876,7 +1876,7 @@ emit_typedef("struct { XRECORD_HEADER void* fp_pointer;} *","Fpointer"); printf("#define fpointerp(obj) (orecordp(obj) && (Record_type(obj) == %d))\n",Rectype_Fpointer); #ifdef TYPECODES - printf("#define TheFpointer(obj) ((Fpointer)(");print_type_pointable(orecord_type,obj);printf("))\n"); + printf("#define TheFpointer(obj) ((Fpointer)("); printf_type_pointable(orecord_type); printf("))\n"); #else printf("#define TheFpointer(obj) ((Fpointer)(ngci_pointable(obj)-%d))\n",varobject_bias); #endif Couldn't generate diff; no version number found in filespec: ChangeLog,1.2599,1.2600" --__--__-- Message: 6 From: ha...@us... To: cli...@li... Subject: "clisp/src array.d,1.81,1.82" Date: Sun, 22 Feb 2004 08:42:08 -0800 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1733/src Modified Files: array.d Log Message: idx -> index. Couldn't generate diff; no version number found in filespec: array.d,1.81,1.82" --__--__-- Message: 7 From: ha...@us... To: cli...@li... Subject: "clisp/src io.d,1.190,1.191 array.d,1.82,1.83 lispbibl.d,1.418,1.419 sequence.d,1.68,1.69 spvw_circ.d,1.22,1.23 spvw_garcol.d,1.57,1.58 spvw_genera1.d,1.21,1.22 spvw_objsize.d,1.15,1.16 spvw_typealloc.d,1.29,1.30 spvw_update.d,1.17,1.18 type.lisp,1.50,1.51 hashtabl.d,1.63,1.64 predtype.d,1.85,1.86 genclisph.d,1.90,1.91 ChangeLog,1.2600,1.2601" Date: Sun, 22 Feb 2004 08:47:20 -0800 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2713/src Modified Files: io.d array.d lispbibl.d sequence.d spvw_circ.d spvw_garcol.d spvw_genera1.d spvw_objsize.d spvw_typealloc.d spvw_update.d type.lisp hashtabl.d predtype.d genclisph.d ChangeLog Log Message: Make arrays with element type NIL work also in the TYPECODES config. Index: io.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/io.d,v retrieving revision 1.190 retrieving revision 1.191 diff -u -d -r1.190 -r1.191 --- io.d 19 Feb 2004 18:17:55 -0000 1.190 +++ io.d 22 Feb 2004 16:46:53 -0000 1.191 @@ -1,6 +1,6 @@ /* * Input/Output for CLISP - * Bruno Haible 1990-2003 + * Bruno Haible 1990-2004 * Marcus Daniels 11.3.1997 * Sam Steingold 1998-2003 * German comments translated into English: Stefan Kain 2001-06-12 @@ -7517,7 +7517,7 @@ INDENT_START(3); # indent by 3 characters because of '#A(' JUSTIFY_START(1); JUSTIFY_LAST(false); - prin_object_dispatch(stream_,array_element_type(*sv_)); # print element-type + prin_object_dispatch(stream_, vector_nil_p ? NIL : array_element_type(*sv_)); # print element-type JUSTIFY_SPACE; JUSTIFY_LAST(false); pushSTACK(fixnum(len)); @@ -7881,7 +7881,7 @@ INDENT_START(3); # indent by 3 characters, because of '#A(' JUSTIFY_START(1); JUSTIFY_LAST(false); - prin_object_dispatch(stream_,array_element_type(*obj_)); # print element-type (Symbol or List) + prin_object_dispatch(stream_, locals.pr_one_elt==NULL ? NIL : array_element_type(*locals.obj_)); # print element-type (Symbol or List) JUSTIFY_SPACE; JUSTIFY_LAST(false); pr_list(stream_,array_dimensions(*obj_)); # print dimension-list if (locals.pr_one_elt) { /* not (ARRAY NIL) */ @@ -8423,7 +8423,6 @@ case Rectype_b16vector: case Rectype_Sb16vector: # 16bit-vector case Rectype_b32vector: case Rectype_Sb32vector: # 32bit-vector case Rectype_vector: case Rectype_Svector: # (vector t) - case Rectype_nilvector: case Rectype_Snilvector: /* (VECTOR NIL) */ pr_vector(stream_,obj); break; case Rectype_WeakKVT: # weak key-value table pr_weakkvt(stream_,obj); break; Index: array.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/array.d,v retrieving revision 1.82 retrieving revision 1.83 diff -u -d -r1.82 -r1.83 --- array.d 22 Feb 2004 16:42:06 -0000 1.82 +++ array.d 22 Feb 2004 16:46:54 -0000 1.83 @@ -97,21 +97,24 @@ { /* (cond ((eq obj 'BIT) Atype_Bit) ((eq obj 'CHARACTER) Atype_Char) ((eq obj 'T) Atype_T) - (t (multiple-value-bind (low high) (sys::subtype-integer obj) - ;; Now (or (null low) (subtypep obj `(INTEGER ,low ,high))) - (if (and (integerp low) (not (minusp low)) (integerp high)) - (let ((l (integer-length high))) - ;; Now (subtypep obj `(UNSIGNED-BYTE ,l)) - (cond ((<= l 1) Atype_Bit) - ((<= l 2) Atype_2Bit) - ((<= l 4) Atype_4Bit) - ((<= l 8) Atype_8Bit) - ((<= l 16) Atype_16Bit) - ((<= l 32) Atype_32Bit) - (t Atype_T))) - (if (subtypep type 'CHARACTER) - Atype_Char - Atype_T))))) */ + ((eq obj 'NIL) Atype_NIL) + (t (if (subtypep obj 'NIL) + Atype_NIL + (multiple-value-bind (low high) (sys::subtype-integer obj) + ;; Now (or (null low) (subtypep obj `(INTEGER ,low ,high))) + (if (and (integerp low) (not (minusp low)) (integerp high)) + (let ((l (integer-length high))) + ;; Now (subtypep obj `(UNSIGNED-BYTE ,l)) + (cond ((<= l 1) Atype_Bit) + ((<= l 2) Atype_2Bit) + ((<= l 4) Atype_4Bit) + ((<= l 8) Atype_8Bit) + ((<= l 16) Atype_16Bit) + ((<= l 32) Atype_32Bit) + (t Atype_T))) + (if (subtypep type 'CHARACTER) + Atype_Char + Atype_T)))))) */ if (eq(obj,S(bit))) { /* symbol BIT ? */ return Atype_Bit; } else if (eq(obj,S(character))) { /* symbol CHARACTER ? */ @@ -121,8 +124,14 @@ } else if (nullp(obj)) /* symbol NIL ? */ return Atype_NIL; pushSTACK(obj); /* save obj */ + /* (SUBTYPEP obj 'NIL) */ + pushSTACK(obj); pushSTACK(S(nil)); funcall(S(subtypep),2); + if (!nullp(value1)) { + skipSTACK(1); + return Atype_NIL; + } /* (SYS::SUBTYPE-INTEGER obj) */ - pushSTACK(obj); funcall(S(subtype_integer),1); + pushSTACK(STACK_0); funcall(S(subtype_integer),1); obj = popSTACK(); /* restore obj */ if ((mv_count>1) && integerp(value1) && positivep(value1) && integerp(value2)) { @@ -140,6 +149,7 @@ if (l<=32) return Atype_32Bit; } + /* (SUBTYPEP obj 'CHARACTER) */ pushSTACK(obj); pushSTACK(S(character)); funcall(S(subtypep),2); if (!nullp(value1)) return Atype_Char; @@ -178,9 +188,10 @@ /* An indirect array contains a pointer to another array: TheIarray(array)->data. The "storage vector" of an array is a 1-dimensional array, of the same - element type as the original array, without fill-pointer or adjustable bit. + element type as the original array, without fill-pointer or adjustable bit; + for arrays of element type NIL, the "storage vector" is the symbol NIL. It can be obtained by repeatedly taking TheIarray(array)->data, until - array satisfies array_simplep. */ + array satisfies array_simplep || nullp. */ /* Function: Follows the TheIarray(array)->data chain until the storage-vector is reached, and thereby sums up displaced-offsets. This function is useful @@ -211,8 +222,9 @@ simple: simple_array_to_storage(array); /* have reached the storage-vector, not indirect */ - if (*index >= Sarray_length(array)) - goto fehler_bad_index; + if (!nullp(array)) + if (*index >= Sarray_length(array)) + goto fehler_bad_index; return array; fehler_bad_index: fehler(error,GETTEXT("index too large")); /* more details?? */ @@ -248,8 +260,9 @@ simple: simple_array_to_storage(array); /* have reached the storage-vector, not indirect */ - if (*index+size > Sarray_length(array)) - goto fehler_bad_index; + if (!nullp(array)) + if (*index+size > Sarray_length(array)) + goto fehler_bad_index; return array; fehler_bad_index: fehler_displaced_inconsistent(); @@ -282,8 +295,9 @@ simple: simple_array_to_storage(array); /* have reached the storage-vector, not indirect */ - if (*index+size > Sarray_length(array)) - goto fehler_bad_index; + if (!nullp(array)) + if (*index+size > Sarray_length(array)) + goto fehler_bad_index; return array; fehler_bad_index: fehler_displaced_inconsistent(); @@ -475,11 +489,9 @@ /* error: attempt to retrieve a value from (ARRAY NIL) */ nonreturning_function(global, fehler_retrieve, (object array)) { - pushSTACK(array); /* TYPE-ERROR slot DATUM -- what else can we put here?! */ - pushSTACK(array_element_type(array)); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(STACK_1); /* array */ + /* Ignore array, since it's always NIL. */ pushSTACK(TheSubr(subr_self)->name); - fehler(type_error,GETTEXT("~: cannot retrieve values from ~")); + fehler(error,GETTEXT("~: cannot retrieve values from an array of element type NIL")); } /* Function: Performs an AREF access. @@ -516,11 +528,18 @@ fehler_store(array,value); */ nonreturning_function(global, fehler_store, (object array, object value)) { pushSTACK(value); /* TYPE-ERROR slot DATUM */ - pushSTACK(NIL); pushSTACK(array); - STACK_1 = array_element_type(array); /* TYPE-ERROR slot EXPECTED-TYPE */ - pushSTACK(STACK_2); /* value */ - pushSTACK(TheSubr(subr_self)->name); - fehler(type_error,GETTEXT("~: ~ does not fit into ~, bad type")); + pushSTACK(NIL); /* TYPE-ERROR slot EXPECTED-TYPE */ + if (!nullp(array)) { + pushSTACK(array); + STACK_1 = array_element_type(array); /* TYPE-ERROR slot EXPECTED-TYPE */ + pushSTACK(STACK_2); /* value */ + pushSTACK(TheSubr(subr_self)->name); + fehler(type_error,GETTEXT("~: ~ does not fit into ~, bad type")); + } else { + pushSTACK(STACK_1); /* value */ + pushSTACK(TheSubr(subr_self)->name); + fehler(type_error,GETTEXT("~: ~ cannot be stored in an array of element type NIL")); + } } /* performs a STORE-access. @@ -759,6 +778,7 @@ { switch (Array_type(array)) { case Array_type_mdarray: /* general array -> look at Arrayflags */ + case Array_type_vector: /* [GENERAL-]VECTOR or (VECTOR NIL) */ return Iarray_flags(array) & arrayflags_atype_mask; case Array_type_sbvector: case Array_type_sb2vector: @@ -777,12 +797,12 @@ case Array_type_string: case Array_type_sstring: return Atype_Char; - case Array_type_vector: case Array_type_svector: return Atype_T; - case Array_type_nilvector: + #if 0 /* not necessary */ case Array_type_snilvector: return Atype_NIL; + #endif default: NOTREACHED; } } @@ -2788,7 +2808,8 @@ break; case Array_type_snilvector: /* (VECTOR NIL) */ switch (Array_type(dv2)) { - case Array_type_snilvector: return; + case Array_type_snilvector: + return; case Array_type_svector: /* Simple-Vector */ case Array_type_sbvector: /* Simple-Bit-Vector */ case Array_type_sb2vector: @@ -3018,7 +3039,8 @@ case Array_type_sstring: /* Simple-String */ elt_move_Char(dv1,index1,dv2,index2,count); break; - case Array_type_snilvector: break; /* nothing to be done! */ + case Array_type_snilvector: + return; default: NOTREACHED; } } @@ -3255,8 +3277,8 @@ > index2: start index in dv2 > count: number of elements to be copied, > 0 can trigger GC */ -global void elt_reverse (object dv1, uintL index1, object dv2, - uintL index2, uintL count) { +global void elt_reverse (object dv1, uintL index1, object dv2, uintL index2, + uintL count) { #define SIMPLE_REVERSE(p1,p2,c) dotimespL(c,c, { *p2-- = *p1++; }) index2 += count-1; switch (Array_type(dv1)) { @@ -3412,6 +3434,8 @@ }); } break; + case Array_type_snilvector: + fehler_retrieve(dv1); default: NOTREACHED; } #undef SIMPLE_REVERSE @@ -3507,6 +3531,8 @@ }); } break; + case Array_type_snilvector: + fehler_retrieve(dv); default: NOTREACHED; } #undef SIMPLE_NREVERSE @@ -4151,7 +4177,9 @@ case Atype_32Bit: /* create simple bit/byte-vector */ vector = allocate_bit_vector(eltype,len); break; - case Atype_NIL: vector = allocate_nilvector(len); break; + case Atype_NIL: + vector = NIL; + break; default: NOTREACHED; } if (boundp(STACK_4)) /* initial-element supplied? */ @@ -4282,7 +4310,8 @@ pushSTACK(displaced_to); /* TYPE-ERROR slot DATUM */ pushSTACK(S(array)); pushSTACK(STACK_(5+2)); { /* TYPE-ERROR slot EXPECTED-TYPE */ - object exp_type = listof(2); pushSTACK(exp_type); } + object exp_type = listof(2); pushSTACK(exp_type); + } pushSTACK(STACK_(5+2)); /* element-type */ pushSTACK(STACK_2); /* displaced_to */ pushSTACK(S(Kdisplaced_to)); @@ -4386,7 +4415,7 @@ and adjustable is not supplied and rank=1 , then return a (semi-)simple vector: */ - if ((rank==1) && (nullp(STACK_6)) && (nullp(STACK_2))) { + if ((rank==1) && nullp(STACK_6) && nullp(STACK_2) && !nullp(datenvektor)) { VALUES1(datenvektor); /* return datenvektor */ skipSTACK(8); return; } @@ -4440,7 +4469,7 @@ Array_type_b32vector, /* Atype_32Bit -> Array_type_b32vector */ Array_type_vector, /* Atype_T -> Array_type_vector */ Array_type_string, /* Atype_Char -> Array_type_string */ - Array_type_nilvector, /* Atype_NIL -> Array_type_nilvector */ + Array_type_vector, /* Atype_NIL -> Array_type_vector */ Array_type_vector, /* unused yet */ Array_type_vector, /* unused yet */ Array_type_vector, /* unused yet */ Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.418 retrieving revision 1.419 diff -u -d -r1.418 -r1.419 --- lispbibl.d 22 Feb 2004 16:34:31 -0000 1.418 +++ lispbibl.d 22 Feb 2004 16:46:54 -0000 1.419 @@ -1,5 +1,5 @@ # Main include-file for CLISP -# Bruno Haible 1990-2003 +# Bruno Haible 1990-2004 # Marcus Daniels 11.11.1994 # Sam Steingold 1998-2003 # German comments translated into English: Stefan Kain 2001-09-24 @@ -3817,8 +3817,8 @@ Rectype_b8vector, /* 5 */ # Iarray, not Srecord/Xrecord Rectype_b16vector, /* 6 */ # Iarray, not Srecord/Xrecord Rectype_b32vector, /* 7 */ # Iarray, not Srecord/Xrecord - Rectype_nilvector, /* 8 */ # Iarray, not Srecord/Xrecord - /* Rectype_Svector is the bottom SIMPLE-VECTOR */ + Rectype_unused1, /* 8 */ + /* Rectype_Svector is the bottom SIMPLE VECTOR */ Rectype_Svector, /* 9 */ # Svector, not Srecord/Xrecord Rectype_Sbvector, /* 10 */ # Sbvector, not Srecord/Xrecord Rectype_Sb2vector, /* 11 */ # Sbvector, not Srecord/Xrecord @@ -3826,7 +3826,7 @@ Rectype_Sb8vector, /* 13 */ # Sbvector, not Srecord/Xrecord Rectype_Sb16vector, /* 14 */ # Sbvector, not Srecord/Xrecord Rectype_Sb32vector, /* 15 */ # Sbvector, not Srecord/Xrecord - Rectype_Snilvector, /* 16 */ # Lrecord, not Srecord/Xrecord + Rectype_unused2, /* 16 */ /* Rectype_S8string is the bottom STRING */ Rectype_S8string, /* 17 */ # S8string, not Srecord/Xrecord Rectype_Imm_S8string, /* 18 */ # immutable S8string, not Srecord/Xrecord @@ -4418,18 +4418,15 @@ #define arrayflags_atype_mask 0x0F # mask for the element-type # Element-types of arrays in Bits 3..0 of its flags: # The first ones are chosen, so that 2^Atype_nBit = n. -#define Atype_Bit 0 -#define Atype_2Bit 1 -#define Atype_4Bit 2 -#define Atype_8Bit 3 -#define Atype_16Bit 4 -#define Atype_32Bit 5 -#define Atype_T 6 -#define Atype_Char 7 -#ifndef TYPECODES -/* (ARRAY NIL) has an Array_type_snilvector data vector */ -#define Atype_NIL 8 -#endif +#define Atype_Bit 0 # storage vector is of type sbvector_type +#define Atype_2Bit 1 # storage vector is of type sb2vector_type +#define Atype_4Bit 2 # storage vector is of type sb4vector_type +#define Atype_8Bit 3 # storage vector is of type sb8vector_type +#define Atype_16Bit 4 # storage vector is of type sb16vector_type +#define Atype_32Bit 5 # storage vector is of type sb32vector_type +#define Atype_T 6 # storage vector is of type svector_type +#define Atype_Char 7 # storage vector is of type sstring_type +#define Atype_NIL 8 # storage vector is NIL # array-types #ifdef TYPECODES @@ -4451,6 +4448,7 @@ #define Array_type_sb32vector sb32vector_type # Sbvector #define Array_type_sstring sstring_type # Sstring #define Array_type_svector svector_type # Svector + #define Array_type_snilvector symbol_type # Symbol NIL # Array_type_simple_bit_vector(atype) # maps Atype_[n]Bit to Array_type_sb[n]vector. Depends on TB0, TB1, TB2. # The formula works because there are only 4 possible cases: @@ -4480,8 +4478,7 @@ #define Array_type_sb32vector Rectype_Sb32vector # Sbvector #define Array_type_sstring Rectype_S8string: case Rectype_Imm_S8string: case Rectype_S16string: case Rectype_Imm_S16string: case Rectype_S32string: case Rectype_Imm_S32string: case Rectype_reallocstring # S[8|16|32]string, reallocated string #define Array_type_svector Rectype_Svector # Svector - #define Array_type_nilvector Rectype_nilvector # Iarray - #define Array_type_snilvector Rectype_Snilvector # Lrecord + #define Array_type_snilvector Rectype_Symbol # Symbol NIL #endif # Determining the atype of a [simple-]bit-array: #define sbNvector_atype(obj) \ @@ -5778,7 +5775,6 @@ #else # cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string, # Rectype_bvector, Rectype_b[2|4|8|16|32]vector, Rectype_vector, Rectype_reallocstring, Rectype_string - # Rectype_S?nilvector #define vectorp(obj) \ (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_vector) \ <= Rectype_string - Rectype_vector)) @@ -5790,7 +5786,7 @@ ((tint)(typecode(obj) - sbvector_type) <= (tint)(svector_type - sbvector_type)) #else # cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string, - # Rectype_reallocstring, Rectype_Snilvector + # Rectype_reallocstring #define simplep(obj) \ (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_Svector) \ <= Rectype_reallocstring - Rectype_Svector)) @@ -5802,7 +5798,7 @@ ((typecode(obj) & bit(notsimple_bit_t)) == 0) #else # cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string, - # Rectype_reallocstring, Rectype_Snilvector + # Rectype_reallocstring #define array_simplep(obj) \ ((uintB)(Record_type(obj) - Rectype_Svector) \ <= Rectype_reallocstring - Rectype_Svector) @@ -5821,13 +5817,18 @@ # Test for general-vector=(vector t) #ifdef TYPECODES #define general_vector_p(obj) \ - ((typecode(obj) & ~bit(notsimple_bit_t)) == svector_type) + ((typecode(obj) == svector_type) \ + || (typecode(obj) == vector_type \ + && (Iarray_flags(obj) & arrayflags_atype_mask) == Atype_T \ + ) ) #else # cases: Rectype_Svector, Rectype_vector #define general_vector_p(obj) \ (varobjectp(obj) \ - && ((Record_type(obj) & ~(Rectype_Svector ^ Rectype_vector)) == (Rectype_Svector & Rectype_vector)) \ - ) + && ((Record_type(obj) == Rectype_Svector) \ + || (Record_type(obj) == Rectype_vector \ + && (Iarray_flags(obj) & arrayflags_atype_mask) == Atype_T \ + ) ) ) #endif # Test for simple-string @@ -5888,7 +5889,7 @@ #else # cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string, # Rectype_bvector, Rectype_b[2|4|8|16|32]vector, Rectype_vector, Rectype_reallocstring, Rectype_string, - # Rectype_S?nilvector, Rectype_mdarray + # Rectype_mdarray #define arrayp(obj) \ (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_vector) \ <= Rectype_mdarray - Rectype_vector)) @@ -5925,7 +5926,6 @@ case Rectype_bvector: case Rectype_string: case Rectype_vector: \ case Rectype_reallocstring: \ case Rectype_Bignum: case Rectype_Lfloat: \ - case Rectype_nilvector: case Rectype_Snilvector: \ goto not_record; \ default: { statement1 } break; \ } \ @@ -6419,10 +6419,6 @@ case Rectype_S8string: case Rectype_Imm_S8string: case Rectype_S16string: case Rectype_Imm_S16string: case Rectype_S32string: case Rectype_Imm_S32string: case Rectype_reallocstring: goto case_sstring; #define case_Rectype_Svector_above \ case Rectype_Svector: goto case_svector; - #define case_Rectype_Snilvector_above \ - case Rectype_Snilvector: goto case_snilvector; - #define case_Rectype_nilvector_above \ - case Rectype_nilvector: goto case_nilvector; #define case_Rectype_WeakKVT_above \ case Rectype_WeakKVT: goto case_weakkvt; #define case_Rectype_mdarray_above \ @@ -6487,7 +6483,6 @@ case Rectype_Sb32vector: case Rectype_b32vector: \ case Rectype_Svector: case Rectype_vector: \ case Rectype_WeakKVT: case Rectype_mdarray: \ - case Rectype_Snilvector: case Rectype_nilvector: \ goto case_array; #define case_Rectype_number_above /* don't forget immediate_number_p */ \ case Rectype_Complex: case Rectype_Ratio: \ @@ -7713,22 +7708,14 @@ extern object make_symbol (object string); # is used by PACKAGE, IO, SYMBOL -# UP: allocates a vector +# UP: allocates a general vector # allocate_vector(len) # > len: length of the vector -# < result: new vector (elements are initialized with NIL) +# < result: fresh simple general vector (elements are initialized with NIL) # can trigger GC extern object allocate_vector (uintL len); # is used by ARRAY, IO, EVAL, PACKAGE, CONTROL, HASHTABL -# UP: allocates a (VECTOR NIL) -# allocate_nilvector(len) -# > len: length of the vector -# < result: new vector -# can trigger GC -extern object allocate_nilvector (uintL len); -# is used by ARRAY - # Function: Allocates a bit/byte vector. # allocate_bit_vector(atype,len) # > uintB atype: Atype_nBit @@ -10743,6 +10730,10 @@ nonreturning_function(extern, fehler_index_range, (uintL bound)); # used by SEQUENCE +# error message: attempt to retrieve a value from (ARRAY NIL) +nonreturning_function(extern, fehler_retrieve, (object array)); +# used by PREDTYPE + # Function: Performs an AREF access. # storagevector_aref(storagevector,index) # > storagevector: a storage vector (simple vector or semi-simple byte vector) Index: sequence.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/sequence.d,v retrieving revision 1.68 retrieving revision 1.69 diff -u -d -r1.68 -r1.69 --- sequence.d 17 Feb 2004 21:00:02 -0000 1.68 +++ sequence.d 22 Feb 2004 16:46:55 -0000 1.69 @@ -1,6 +1,6 @@ /* * Sequences for CLISP - * Bruno Haible 1987-2003 + * Bruno Haible 1987-2004 * Sam Steingold 1998-2003 */ #include "lispbibl.c" @@ -261,10 +261,20 @@ case Array_type_b16vector: case Array_type_b32vector: # Typ n, bedeutet (VECTOR (UNSIGNED-BYTE n)) name = fixnum(bit(bNvector_atype(seq))); break; - case Array_type_snilvector: case Array_type_nilvector: /* (VECTOR NIL) */ - name = Fixnum_0; break; - default: + case Array_type_vector: + switch (Iarray_flags(seq) & arrayflags_atype_mask) { + case Atype_NIL: /* type (VECTOR NIL) */ + name = Fixnum_0; break; + case Atype_T: /* type [GENERAL-]VECTOR */ + name = S(vector); break; + default: + NOTREACHED; + } + break; + case Array_type_svector: name = S(vector); break; # Typ [GENERAL-]VECTOR + default: + NOTREACHED; } } else if (structurep(seq)) { name = TheStructure(seq)->structure_types; # Structure-Typen-List*e Index: spvw_circ.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_circ.d,v retrieving revision 1.22 retrieving revision 1.23 diff -u -d -r1.22 -r1.23 --- spvw_circ.d 27 Oct 2003 12:42:59 -0000 1.22 +++ spvw_circ.d 22 Feb 2004 16:46:55 -0000 1.23 @@ -445,7 +445,6 @@ case_lfloat: # Long-Float case_ratio: # Ratio case_complex: # Complex - case_snilvector: /* (VECTOR NIL) */ # Object without components that are printed: if (mlb_add(&env->bitmap,obj)) # marked? goto m_schon_da; @@ -465,7 +464,7 @@ } } goto m_end; - case_mdarray: case_ovector: case_nilvector: + case_mdarray: case_ovector: # non-simple Array with components, that are objects: if (mlb_add(&env->bitmap,obj)) # marked? goto m_schon_da; @@ -522,8 +521,6 @@ case_Rectype_Ratio_above; case_Rectype_Complex_above; case_Rectype_Svector_above; - case_Rectype_Snilvector_above; - case_Rectype_nilvector_above; case_Rectype_mdarray_above; case_Rectype_ovector_above; #endif @@ -746,7 +743,6 @@ case_lfloat: # Long-Float case_ratio: # Ratio case_complex: # Complex - case_snilvector: /* (VECTOR NIL) */ # object without components that are printed: if (marked(ThePointer(obj))) # marked? goto m_schon_da; @@ -770,7 +766,7 @@ } } goto m_end; - case_mdarray: case_ovector: case_nilvector: + case_mdarray: case_ovector: # non-simple array with components that are objects: if (marked(TheIarray(obj))) # marked? goto m_schon_da; @@ -833,8 +829,6 @@ case_Rectype_Ratio_above; case_Rectype_Complex_above; case_Rectype_Svector_above; - case_Rectype_Snilvector_above; - case_Rectype_nilvector_above; case_Rectype_mdarray_above; case_Rectype_ovector_above; #endif @@ -947,7 +941,6 @@ case_lfloat: # Long-Float case_ratio: # Ratio case_complex: # Complex - case_snilvector: /* (VECTOR NIL) */ # unmark object, that has no marked components: unmark(ThePointer(obj)); # unmark goto u_end; @@ -966,7 +959,7 @@ } } goto u_end; - case_mdarray: case_ovector: case_nilvector: + case_mdarray: case_ovector: # non-simple Array with components that are objects: if (!marked(TheIarray(obj))) # already unmarked? goto u_end; @@ -1024,8 +1017,6 @@ case_Rectype_Ratio_above; case_Rectype_Complex_above; case_Rectype_Svector_above; - case_Rectype_Snilvector_above; - case_Rectype_nilvector_above; case_Rectype_mdarray_above; case_Rectype_ovector_above; #endif @@ -1154,7 +1145,7 @@ } } return; - case_mdarray: case_ovector: case_nilvector: + case_mdarray: case_ovector: # non-simple array, no string or bit-vector if (mlb_add(&env->bitmap,obj)) # object already marked? return; @@ -1165,8 +1156,6 @@ #ifndef TYPECODES switch (Record_type(obj)) { case_Rectype_Svector_above; - case_Rectype_Snilvector_above; - case_Rectype_nilvector_above; case_Rectype_mdarray_above; case_Rectype_ovector_above; case_Rectype_bvector_above; @@ -1247,7 +1236,6 @@ case_subr: # SUBR case_number: # Zahl case_symbol: # Symbol - case_snilvector: /* (VECTOR NIL) */ # Object contains no references -> do nothing return; default: NOTREACHED; @@ -1345,7 +1333,7 @@ } } break; - case_mdarray: case_ovector: case_nilvector: + case_mdarray: case_ovector: # non-simple array, no string or bit-vector # traverse data-vector: end-recursive subst(data-vector) ptr = &TheIarray(obj)->data; goto enter_subst; @@ -1354,8 +1342,6 @@ #ifndef TYPECODES switch (Record_type(obj)) { case_Rectype_Svector_above; - case_Rectype_Snilvector_above; - case_Rectype_nilvector_above; case_Rectype_mdarray_above; case_Rectype_ovector_above; case_Rectype_bvector_above; @@ -1427,7 +1413,6 @@ case_subr: # SUBR case_number: # Zahl case_symbol: # Symbol - case_snilvector: /* (VECTOR NIL) */ # Object contains no references -> do nothing break; default: NOTREACHED; @@ -1520,7 +1505,7 @@ } } return; - case_mdarray: case_ovector: case_nilvector: + case_mdarray: case_ovector: # non-simple array, no string or bit-vector if (marked(TheIarray(obj))) # object already marked? return; @@ -1531,8 +1516,6 @@ #ifndef TYPECODES switch (Record_type(obj)) { case_Rectype_Svector_above; - case_Rectype_Snilvector_above; - case_Rectype_nilvector_above; case_Rectype_mdarray_above; case_Rectype_ovector_above; case_Rectype_bvector_above; @@ -1615,7 +1598,6 @@ case_subr: # SUBR case_number: # Zahl case_symbol: # Symbol - case_snilvector: /* (VECTOR NIL) */ # Object contains no references -> do nothing return; default: NOTREACHED; @@ -1661,7 +1643,7 @@ } } return; - case_mdarray: case_ovector: case_nilvector: + case_mdarray: case_ovector: # non-simple array, no string or bit-vector if (!marked(TheIarray(obj))) # already unmarked? return; @@ -1673,8 +1655,6 @@ #ifndef TYPECODES switch (Record_type(obj)) { case_Rectype_Svector_above; - case_Rectype_Snilvector_above; - case_Rectype_nilvector_above; case_Rectype_mdarray_above; case_Rectype_ovector_above; case_Rectype_bvector_above; @@ -1722,7 +1702,6 @@ case_subr: # SUBR case_number: # Zahl case_symbol: # Symbol - case_snilvector: /* (VECTOR NIL) */ # Object contains no references -> do nothing return; default: NOTREACHED; Index: spvw_garcol.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_garcol.d,v retrieving revision 1.57 retrieving revision 1.58 diff -u -d -r1.57 -r1.58 --- spvw_garcol.d 16 Jan 2004 11:16:27 -0000 1.57 +++ spvw_garcol.d 22 Feb 2004 16:46:55 -0000 1.58 @@ -315,7 +315,6 @@ case Rectype_Ffloat: case Rectype_Dfloat: case Rectype_Lfloat: - case Rectype_Snilvector: /* (VECTOR NIL) */ down_nopointers(TheRecord); case Rectype_Svector: down_svector(); @@ -335,7 +334,6 @@ case Rectype_b16vector: case Rectype_b32vector: case Rectype_string: - case Rectype_nilvector: /* (VECTOR NIL) */ case Rectype_vector: down_iarray(); case Rectype_realloc_Instance: Index: spvw_genera1.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_genera1.d,v retrieving revision 1.21 retrieving revision 1.22 diff -u -d -r1.21 -r1.22 --- spvw_genera1.d 27 Oct 2003 12:42:59 -0000 1.21 +++ spvw_genera1.d 22 Feb 2004 16:46:55 -0000 1.22 @@ -250,7 +250,6 @@ case Rectype_reallocstring: \ case Rectype_string: \ case Rectype_vector: \ - case Rectype_nilvector: \ # arrays that are not simple: \ walk_area_iarray(objptr,physpage_end,walkfun); \ break; \ @@ -271,7 +270,6 @@ case Rectype_Ffloat: \ case Rectype_Dfloat: \ case Rectype_Lfloat: \ - case Rectype_Snilvector: \ # simple-byte-vector, simple-string, bignum, float \ objptr += objsize((Varobject)objptr); \ break; \ @@ -606,7 +604,7 @@ } break; #endif - case_mdarray: case_obvector: case_ob2vector: case_ob4vector: case_ob8vector: case_ob16vector: case_ob32vector: case_ostring: case_ovector: case_nilvector: # non-simple arrays: + case_mdarray: case_obvector: case_ob2vector: case_ob4vector: case_ob8vector: case_ob16vector: case_ob32vector: case_ostring: case_ovector: # non-simple arrays: { var aint nextptr = objptr + objsize((Iarray)objptr); # here is gen0_start-physpagesize <= objptr < gen0_start. @@ -682,7 +680,6 @@ case_Rectype_ob32vector_above; case_Rectype_ostring_above; case_Rectype_ovector_above; - case_Rectype_nilvector_above; case_Rectype_Svector_above; case_Rectype_WeakKVT_above; case Rectype_Sbvector: @@ -696,7 +693,6 @@ case Rectype_S32string: case Rectype_Imm_S32string: case Rectype_Bignum: case Rectype_Ffloat: case Rectype_Dfloat: case Rectype_Lfloat: - case Rectype_Snilvector: goto case_nopointers; default: ; } Index: spvw_objsize.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_objsize.d,v retrieving revision 1.15 retrieving revision 1.16 diff -u -d -r1.15 -r1.16 --- spvw_objsize.d 4 Apr 2003 20:41:24 -0000 1.15 +++ spvw_objsize.d 22 Feb 2004 16:46:55 -0000 1.16 @@ -138,7 +138,6 @@ case_Rectype_Sb16vector_above; case_Rectype_Sb32vector_above; case_Rectype_Svector_above; - case_Rectype_Snilvector_above; case_Rectype_WeakKVT_above; case_Rectype_mdarray_above; case_Rectype_obvector_above; @@ -149,7 +148,6 @@ case_Rectype_ob32vector_above; case_Rectype_ostring_above; case_Rectype_ovector_above; - case_Rectype_nilvector_above; case_Rectype_Bignum_above; case_Rectype_Lfloat_above; #ifdef UNICODE @@ -210,11 +208,9 @@ case_weakkvt: # weak-key-value-table case_svector: # simple-vector return size_svector(svector_length((Svector)addr)); - case_snilvector: /* (VECTOR NIL) */ - return size_svector(0); case_mdarray: case_obvector: case_ob2vector: case_ob4vector: case_ob8vector: case_ob16vector: case_ob32vector: case_ostring: - case_ovector: case_nilvector: { # non-simple array: + case_ovector: { # non-simple array: var uintL size; size = (uintL)iarray_rank((Iarray)addr); if (iarray_flags((Iarray)addr) & bit(arrayflags_fillp_bit)) Index: spvw_typealloc.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_typealloc.d,v retrieving revision 1.29 retrieving revision 1.30 diff -u -d -r1.29 -r1.30 --- spvw_typealloc.d 1 Apr 2003 22:07:08 -0000 1.29 +++ spvw_typealloc.d 22 Feb 2004 16:46:55 -0000 1.30 @@ -93,22 +93,6 @@ #undef SETTFL } -/* allocate a (VECTOR NIL) - allocate_nilvector(len) - > len: length of the vector - < result: new vector - can trigger GC */ -global object allocate_nilvector (uintL len) { - var uintL need = size_svector(0); - #ifdef TYPECODES - #define SETTFL ptr->length = len - #else - #define SETTFL ptr->tfl = lrecord_tfl(Rectype_Snilvector,len) - #endif - allocate(nilvector_type,true,need,Lrecord,ptr,{ SETTFL; }); - #undef SETTFL -} - /* allocate and init the weak kvtable > len: the length of the data vector > type: :KEY or :VALUE or :EITHER or :BOTH Index: spvw_update.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_update.d,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- spvw_update.d 27 Oct 2003 12:42:59 -0000 1.17 +++ spvw_update.d 22 Feb 2004 16:46:55 -0000 1.18 @@ -195,7 +195,6 @@ case Rectype_reallocstring: \ case Rectype_string: \ case Rectype_vector: \ - case Rectype_nilvector: \ # non-simple array: update data vector \ do_update_iarray(); \ break; \ @@ -214,7 +213,6 @@ case Rectype_S32string: case Rectype_Imm_S32string: \ case Rectype_Bignum: case Rectype_Ffloat: \ case Rectype_Dfloat: case Rectype_Lfloat: \ - case Rectype_Snilvector: \ # these contain no pointers that need update -> do nothing \ break; \ default: # Record: update all pointers \ Index: type.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/type.lisp,v retrieving revision 1.50 retrieving revision 1.51 diff -u -d -r1.50 -r1.51 --- type.lisp 16 Jan 2004 11:16:27 -0000 1.50 +++ type.lisp 22 Feb 2004 16:46:55 -0000 1.51 @@ -128,21 +128,23 @@ ((CHARACTER) 'CHARACTER) ((T) 'T) ((NIL) 'NIL) - (t (multiple-value-bind (low high) (sys::subtype-integer type) - ; Es gilt (or (null low) (subtypep type `(INTEGER ,low ,high))) - (if (and (integerp low) (not (minusp low)) (integerp high)) - (let ((l (integer-length high))) - ; Es gilt (subtypep type `(UNSIGNED-BYTE ,l)) - (cond ((<= l 1) 'BIT) - ((<= l 2) '(UNSIGNED-BYTE 2)) - ((<= l 4) '(UNSIGNED-BYTE 4)) - ((<= l 8) '(UNSIGNED-BYTE 8)) - ((<= l 16) '(UNSIGNED-BYTE 16)) - ((<= l 32) '(UNSIGNED-BYTE 32)) - (t 'T))) - (if (subtypep type 'CHARACTER) - 'CHARACTER - 'T)))))) + (t (if (subtypep type 'NIL) + 'NIL + (multiple-value-bind (low high) (sys::subtype-integer type) + ; Es gilt (or (null low) (subtypep type `(INTEGER ,low ,high))) + (if (and (integerp low) (not (minusp low)) (integerp high)) + (let ((l (integer-length high))) + ; Es gilt (subtypep type `(UNSIGNED-BYTE ,l)) + (cond ((<= l 1) 'BIT) + ((<= l 2) '(UNSIGNED-BYTE 2)) + ((<= l 4) '(UNSIGNED-BYTE 4)) + ((<= l 8) '(UNSIGNED-BYTE 8)) + ((<= l 16) '(UNSIGNED-BYTE 16)) + ((<= l 32) '(UNSIGNED-BYTE 32)) + (t 'T))) + (if (subtypep type 'CHARACTER) + 'CHARACTER + 'T))))))) ;; ---------------------------------------------------------------------------- Index: hashtabl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/hashtabl.d,v retrieving revision 1.63 retrieving revision 1.64 diff -u -d -r1.63 -r1.64 --- hashtabl.d 19 Feb 2004 17:05:13 -0000 1.63 +++ hashtabl.d 22 Feb 2004 16:46:55 -0000 1.64 @@ -1,6 +1,6 @@ /* * Hash-Tables in CLISP - * Bruno Haible 1990-2002 + * Bruno Haible 1990-2004 * Sam Steingold 1998-2003 * German comments translated into English: Stefan Kain 2002-01-29 */ @@ -640,6 +640,8 @@ return hashcode4_vector_32Bit(dv,index,count,bish_code); case Array_type_sstring: /* simple-string */ return hashcode4_vector_Char(dv,index,count,bish_code); + case Array_type_snilvector: /* (VECTOR NIL) */ + return 0x2116ECD0 + bish_code; default: NOTREACHED; } } @@ -680,7 +682,7 @@ case_b16vector: /* 16bit-vector */ case_b32vector: /* 32bit-vector */ case_string: /* string */ - case_vector: { /* (VECTOR T) */ + case_vector: { /* (VECTOR T), (VECTOR NIL) */ /* look at it component-wise: */ var uintL len = vector_length(obj); /* length */ var uintL index = 0; Index: predtype.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/predtype.d,v retrieving revision 1.85 retrieving revision 1.86 diff -u -d -r1.85 -r1.86 --- predtype.d 22 Feb 2004 07:23:21 -0000 1.85 +++ predtype.d 22 Feb 2004 16:46:55 -0000 1.86 @@ -1,6 +1,6 @@ /* * Predicates for equality and type tests, types, classes in CLISP - * Bruno Haible 1990-2002 + * Bruno Haible 1990-2004 * Sam Steingold 1998-2002 * German comments translated into English: Stefan Kain 2002-09-15 */ @@ -693,6 +693,8 @@ return elt_compare_T_32Bit(dv1,index1,dv2,index2,count); case Array_type_sstring: /* Simple-String */ return elt_compare_T_Char(dv1,index1,dv2,index2,count); + case Array_type_snilvector: /* (VECTOR NIL) */ + fehler_retrieve(dv2); default: NOTREACHED; } case Array_type_sbvector: /* Simple-Bit-Vector */ @@ -713,6 +715,8 @@ return elt_compare_Bit_32Bit(dv1,index1,dv2,index2,count); case Array_type_sstring: /* Simple-String */ return false; /* because count > 0 */ + case Array_type_snilvector: /* (VECTOR NIL) */ + fehler_retrieve(dv2); default: NOTREACHED; } case Array_type_sb2vector: @@ -733,6 +737,8 @@ return elt_compare_2Bit_32Bit(dv1,index1,dv2,index2,count); case Array_type_sstring: /* Simple-String */ return false; /* because count > 0 */ + case Array_type_snilvector: /* (VECTOR NIL) */ + fehler_retrieve(dv2); default: NOTREACHED; } case Array_type_sb4vector: @@ -753,6 +759,8 @@ return elt_compare_4Bit_32Bit(dv1,index1,dv2,index2,count); case Array_type_sstring: /* Simple-String */ return false; /* because count > 0 */ + case Array_type_snilvector: /* (VECTOR NIL) */ + fehler_retrieve(dv2); default: NOTREACHED; } case Array_type_sb8vector: @@ -773,6 +781,8 @@ return elt_compare_8Bit_32Bit(dv1,index1,dv2,index2,count); case Array_type_sstring: /* Simple-String */ return false; /* because count > 0 */ + case Array_type_snilvector: /* (VECTOR NIL) */ + fehler_retrieve(dv2); default: NOTREACHED; } case Array_type_sb16vector: @@ -793,6 +803,8 @@ return elt_compare_16Bit_32Bit(dv1,index1,dv2,index2,count); case Array_type_sstring: /* Simple-String */ return false; /* because count > 0 */ + case Array_type_snilvector: /* (VECTOR NIL) */ + fehler_retrieve(dv2); default: NOTREACHED; } case Array_type_sb32vector: @@ -813,6 +825,8 @@ return elt_compare_32Bit_32Bit(dv1,index1,dv2,index2,count); case Array_type_sstring: /* Simple-String */ return false; /* because count > 0 */ + case Array_type_snilvector: /* (VECTOR NIL) */ + fehler_retrieve(dv2); default: NOTREACHED; } case Array_type_sstring: /* Simple-String */ @@ -828,6 +842,26 @@ return false; /* because count > 0 */ case Array_type_sstring: /* Simple-String */ return elt_compare_Char_Char(dv1,index1,dv2,index2,count); + case Array_type_snilvector: /* (VECTOR NIL) */ + fehler_retrieve(dv2); + default: NOTREACHED; + } + case Array_type_snilvector: /* (VECTOR NIL) */ + switch (Array_type(dv2)) { + case Array_type_svector: /* Simple-Vector */ + case Array_type_sbvector: /* Simple-Bit-Vector */ + case Array_type_sb2vector: + case Array_type_sb4vector: + case Array_type_sb8vector: + case Array_type_sb16vector: + case Array_type_sb32vector: + case Array_type_sstring: /* Simple-String */ + fehler_retrieve(dv1); + case Array_type_snilvector: /* (VECTOR NIL) */ + /* One can argue that comparing nonexistent elements should yield + an error, not true. But OTOH, we want (equalp (copy-seq x) x) + to return true without signalling an error. */ + return true; default: NOTREACHED; } default: NOTREACHED; @@ -1355,17 +1389,25 @@ value1 = new_cons; } break; - case_ovector: /* other general-vector -> (VECTOR T dim0) */ - pushSTACK(array_dimensions(arg)); /* list of dimensions */ - { - var object new_cons = allocate_cons(); - Cdr(new_cons) = popSTACK(); Car(new_cons) = T; - pushSTACK(new_cons); - } + case_ovector: /* other general-vector -> (VECTOR eltype dim0) */ { - var object new_cons = allocate_cons(); - Cdr(new_cons) = popST... [truncated message content] |