From: <cli...@li...> - 2004-03-21 16:39: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/tests clos.tst,1.35,1.36 ChangeLog,1.119,1.120 (Bruno Haible) 2. clisp/src io.d,1.199,1.200 array.d,1.86,1.87 constobj.d,1.118,1.119 hashtabl.d,1.66,1.67 lispbibl.d,1.441,1.442 stream.d,1.418,1.419 predtype.d,1.92,1.93 sequence.d,1.70,1.71 pathname.d,1.306,1.307 spvw_typealloc.d,1.32,1.33 package.d,1.72,1.73 charstrg.d,1.99,1.100 type.lisp,1.51,1.52 encoding.d,1.107,1.108 genclisph.d,1.100,1.101 spvw_debug.d,1.40,1.41 describe.lisp,1.38,1.39 ChangeLog,1.2762,1.2763 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/tests clos.tst,1.35,1.36 ChangeLog,1.119,1.120 Date: Sun, 21 Mar 2004 16:26:56 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29932/tests Modified Files: clos.tst ChangeLog Log Message: Make the vectors of element type NIL be strings. Index: clos.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/clos.tst,v retrieving revision 1.35 retrieving revision 1.36 diff -u -d -r1.35 -r1.36 --- clos.tst 19 Mar 2004 12:17:15 -0000 1.35 +++ clos.tst 21 Mar 2004 16:26:54 -0000 1.36 @@ -350,7 +350,7 @@ (eq (class-of (make-array nil)) (find-class 'array)) T (eq (class-of (make-array nil :element-type nil)) (find-class 'array)) T -(eq (class-of (make-array 10 :element-type nil)) (find-class 'vector)) T +(eq (class-of (make-array 10 :element-type nil)) (find-class 'string)) T (typep "abc" (find-class 't)) T Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.119 retrieving revision 1.120 diff -u -d -r1.119 -r1.120 --- ChangeLog 19 Mar 2004 20:06:38 -0000 1.119 +++ ChangeLog 21 Mar 2004 16:26:54 -0000 1.120 @@ -1,3 +1,8 @@ +2004-03-07 Bruno Haible <br...@cl...> + + * clos.tst: Change expected result of (class-of #A(NIL (10)) to + <string>, instead of <vector>. + 2004-03-19 Sam Steingold <sd...@gn...> * iofkts.tst (object-out): test CLOS/PPRINT-LOGICAL-BLOCK --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src io.d,1.199,1.200 array.d,1.86,1.87 constobj.d,1.118,1.119 hashtabl.d,1.66,1.67 lispbibl.d,1.441,1.442 stream.d,1.418,1.419 predtype.d,1.92,1.93 sequence.d,1.70,1.71 pathname.d,1.306,1.307 spvw_typealloc.d,1.32,1.33 package.d,1.72,1.73 charstrg.d,1.99,1.100 type.lisp,1.51,1.52 encoding.d,1.107,1.108 genclisph.d,1.100,1.101 spvw_debug.d,1.40,1.41 describe.lisp,1.38,1.39 ChangeLog,1.2762,1.2763 Date: Sun, 21 Mar 2004 16:26:56 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29932/src Modified Files: io.d array.d constobj.d hashtabl.d lispbibl.d stream.d predtype.d sequence.d pathname.d spvw_typealloc.d package.d charstrg.d type.lisp encoding.d genclisph.d spvw_debug.d describe.lisp ChangeLog Log Message: Make the vectors of element type NIL be strings. Index: pathname.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/pathname.d,v retrieving revision 1.306 retrieving revision 1.307 diff -u -d -r1.306 -r1.307 --- pathname.d 19 Mar 2004 17:48:55 -0000 1.306 +++ pathname.d 21 Mar 2004 16:26:53 -0000 1.307 @@ -994,8 +994,8 @@ #define semicolonp(c) (chareq(c,ascii(';'))) #define lslashp(c) semicolonp(c) -/* copy LEN characters in string ORIG starting at ORIG_OFFSET to string DEST, - starting at DEST_OFFSET, up-casing all characters */ +/* Copy LEN characters in string ORIG starting at ORIG_OFFSET to string DEST, + starting at DEST_OFFSET, up-casing all characters. LEN is > 0. */ local void copy_upcase (object dest, uintL dest_offset, object orig, uintL orig_offset, uintL len) { sstring_un_realloc(orig); @@ -1373,13 +1373,15 @@ var uintL length = Sstring_length(string); /* Search for the last dot: */ var uintL index = length; - SstringDispatch(string,X, { - var const cintX* ptr = &((SstringX)TheVarobject(string))->data[index]; - while (index > skip) { - if (*--ptr == '.') goto punkt; - index--; - } - }); + if (index > skip) { + SstringDispatch(string,X, { + var const cintX* ptr = &((SstringX)TheVarobject(string))->data[index]; + do { + if (*--ptr == '.') goto punkt; + index--; + } while (index > skip); + }); + } /* no dot found -> Type := NIL */ pushSTACK(NIL); goto name_type_ok; @@ -1492,7 +1494,7 @@ if (!nullpSv(parse_namestring_ansi)) { /* Coerce string to be a normal-simple-string. */ #ifdef HAVE_SMALL_SSTRING - SstringCase(string,{ Z_SUB(z,string); },{ Z_SUB(z,string); },{}); + SstringCase(string,{ Z_SUB(z,string); },{ Z_SUB(z,string); },{},{ Z_SUB(z,string); }); #endif var zustand tmp = z; var object host = parse_logical_host_prefix(&tmp,string); @@ -1523,7 +1525,7 @@ } /* Coerce string to be a normal-simple-string. */ #ifdef HAVE_SMALL_SSTRING - SstringCase(string,{ Z_SUB(z,string); },{ Z_SUB(z,string); },{}); + SstringCase(string,{ Z_SUB(z,string); },{ Z_SUB(z,string); },{},{ Z_SUB(z,string); }); #endif pushSTACK(string); } @@ -1662,15 +1664,17 @@ var object userhomedir; /* Pathname of the User-Homedir */ /* search next '/' : */ var uintL charcount = 0; - SstringDispatch(STACK_2,X, { - var const cintX* charptr = - &((SstringX)TheVarobject(STACK_2))->data[z.index]; - var uintL count; - dotimesL(count,z.count, { - if (*charptr++ == '/') break; - charcount++; + if (z.count > 0) { + SstringDispatch(STACK_2,X, { + var const cintX* charptr = + &((SstringX)TheVarobject(STACK_2))->data[z.index]; + var uintL count; + dotimespL(count,z.count, { + if (*charptr++ == '/') break; + charcount++; + }); }); - }); + } /* Username has charcount characters */ if (charcount==0) { userhomedir = O(user_homedir); /* only '~' -> User-Homedir */ Index: describe.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/describe.lisp,v retrieving revision 1.38 retrieving revision 1.39 diff -u -d -r1.38 -r1.39 --- describe.lisp 22 Feb 2004 17:23:55 -0000 1.38 +++ describe.lisp 21 Mar 2004 16:26:53 -0000 1.39 @@ -437,7 +437,7 @@ (when (array-has-fill-pointer-p obj) (format stream (TEXT " and current length (fill-pointer) ~S") (fill-pointer obj)))) - (when (stringp obj) + (when (and (stringp obj) (not (eq eltype 'NIL))) #-UNICODE (format stream (TEXT " (a string)")) #+UNICODE Index: hashtabl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/hashtabl.d,v retrieving revision 1.66 retrieving revision 1.67 diff -u -d -r1.66 -r1.67 --- hashtabl.d 23 Feb 2004 17:08:40 -0000 1.66 +++ hashtabl.d 21 Mar 2004 16:26:52 -0000 1.67 @@ -264,7 +264,7 @@ var uintL offset; var object string = unpack_string_ro(obj,&len,&offset); var uint32 bish_code = 0x33DAE11FUL + len; /* utilize length */ - if (len > 0) { + if (len > 0 && !simple_nilarray_p(string)) { SstringDispatch(string,X, { var const cintX* ptr = &((SstringX)TheVarobject(string))->data[offset]; bish_code ^= (uint32)(ptr[len-1]); /* add last character */ @@ -638,10 +638,12 @@ return hashcode4_vector_16Bit(dv,index,count,bish_code); case Array_type_sb32vector: return hashcode4_vector_32Bit(dv,index,count,bish_code); + case Array_type_snilvector: /* (VECTOR NIL) */ + if (count > 0) + return 0x2116ECD0 + bish_code; + /*FALLTHROUGH*/ 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; } } Index: stream.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/stream.d,v retrieving revision 1.418 retrieving revision 1.419 diff -u -d -r1.418 -r1.419 --- stream.d 19 Mar 2004 13:19:24 -0000 1.418 +++ stream.d 21 Mar 2004 16:26:52 -0000 1.419 @@ -9342,6 +9342,8 @@ TheS32string(*chararray_)->data[index]); index++; }); + },{ + NOTREACHED; }); } } @@ -15417,8 +15419,10 @@ var uintL len; var uintL offset; var object srcstring = unpack_string_ro(value1,&len,&offset); - if (len > 0) + if (len > 0) { + if (simple_nilarray_p(srcstring)) fehler_nilarray_retrieve(); ssstring_append_extend(*buffer_,srcstring,offset,len); + } return eofp; } } Index: package.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/package.d,v retrieving revision 1.72 retrieving revision 1.73 diff -u -d -r1.72 -r1.73 --- package.d 19 Mar 2004 12:32:20 -0000 1.72 +++ package.d 21 Mar 2004 16:26:53 -0000 1.73 @@ -44,22 +44,24 @@ var uintL len; var uintL offset; string = unpack_string_ro(string,&len,&offset); - SstringDispatch(string,X, { - var const cintX* charptr = &((SstringX)TheVarobject(string))->data[offset]; - /* there are len characters, starting at charptr */ - var uint32 hashcode = 0; /* hashcode, only the lower 24 Bit count */ - /* Look at all len characters, not just at the first min(len,16) - characters, as we did earlier, because a bad hash function quasi - turns the hash table into a few long linear lists. */ - var uintC count; - dotimesC(count, len, { - /* rotate hashcode by 5 bits to the left: */ - hashcode = hashcode << 5; hashcode = hashcode + (hashcode >> 24); - /* 'add' next byte via XOR: */ - hashcode = hashcode ^ (uint32)(*charptr++); + var uint32 hashcode = 0; /* hashcode, only the lower 24 Bit count */ + if (len > 0) { + SstringDispatch(string,X, { + var const cintX* charptr = &((SstringX)TheVarobject(string))->data[offset]; + /* there are len characters, starting at charptr */ + /* Look at all len characters, not just at the first min(len,16) + characters, as we did earlier, because a bad hash function quasi + turns the hash table into a few long linear lists. */ + var uintC count; + dotimesC(count, len, { + /* rotate hashcode by 5 bits to the left: */ + hashcode = hashcode << 5; hashcode = hashcode + (hashcode >> 24); + /* 'add' next byte via XOR: */ + hashcode = hashcode ^ (uint32)(*charptr++); + }); }); - return hashcode & 0x00FFFFFF; - }); + } + return hashcode & 0x00FFFFFF; } /* UP: Reorganizes a symbol-table, after it has grown, and Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.2762 retrieving revision 1.2763 diff -u -d -r1.2762 -r1.2763 --- ChangeLog 19 Mar 2004 19:54:46 -0000 1.2762 +++ ChangeLog 21 Mar 2004 16:26:53 -0000 1.2763 @@ -1,3 +1,104 @@ +2004-03-07 Bruno Haible <br...@cl...> + + Make the vectors of element type NIL be strings. + * lispbibl.d (general_vector_p): Undo last change. + (simple_nilarray_p): New macro. + (fehler_nilarray_retrieve): Renamed from fehler_retrieve. Remove + argument. + (fehler_nilarray_store): New declaration. + (fehler_nilarray_access): New declaration. + (SstringCase): Add a fifth argument. + (SstringDispatch): Signal an error when the string has element type + NIL. + (unpack_sstring_alloca): Handle strings of element type NIL. + (schar): Likewise. + (unpack_string_rw, unpack_string_ro): Can return NIL now. + * genclisph.d (main): Undo last change to general_vector_p. Emit + declarations of simple_nilarray_p, fehler_nilarray_retrieve. Update + unpack_sstring_alloca. + * array.d (iarray_displace, iarray_displace_check, + array_displace_check): Use simple_nilarray_p instead of nullp. + (fehler_nilarray_retrieve): Renamed from fehler_retrieve. Remove + argument. + (fehler_nilarray_store): New function. + (fehler_nilarray_access): New function. + (storagevector_aref): Update. + (fehler_store): Use simple_nilarray_p instead of nullp. + (array_atype): Handle strings of element type NIL. Array_type_vector + now implies Atype_T again. + (elt_copy_T_Char): Signal an error when dv2 has element type NIL. + (elt_copy_Char_Char): Signal an error when dv1 or dv2 has element type + NIL. + (elt_copy): Update. + (elt_move_Char): Signal an error when dv2 has element type NIL. + (elt_reverse): Signal an error when dv1 or dv2 has element type NIL. + (elt_nreverse): Update. + (ssstring_append_extend): Update. + (MAKE-ARRAY): Use simple_nilarray_p instead of nullp. Map Atype_NIL to + Array_type_string instead of Array_type_vector. + (ADJUST-ARRAY): Update. + * charstrg.d (unpack_string_ro): Can return NIL now. + (unpack_string_rw): Likewise. Signal an error when the string has + element type NIL and the length is > 0. + (copy_string_normal): Signal an error when the string has element type + NIL and the length is > 0. + (copy_string): Handle strings of element type NIL. + (coerce_imm_ss): Likewise. + (coerce_imm_normal_ss): Signal an error when the string has element + type NIL and the length is > 0. + (SYS::STRING-INFO): Handle strings of element type NIL. + (SCHAR): Update the error message for strings of element type NIL. + (SYSTEM::STORE-CHAR): Signal an error when the string has element type + NIL. + (SYSTEM::STORE-SCHAR): Update the error message for strings of element + type NIL. + (test_vector_limits): Signal an error when the string has element type + NIL and the length is > 0. + (test_string_limits_rw): Likewise. + (test_2_stringsym_limits): Likewise. + (string_comp, string_comp_ci): Handle strings of element type NIL. + (nstring_upcase, nstring_downcase, nstring_capitalize): Signal an error + when the string has element type NIL and length > 0. + (subsstring, SUBSTRING, string_concat): Signal an error when a string + has element type NIL and length > 0. + * predtype.d (equal): Handle strings of element type NIL. + (elt_compare): Update. + (SIMPLE-STRING-P): Include simple strings of element type NIL. + (TYPE-OF): For strings of element type NIL, return (VECTOR NIL dim0) + or (SIMPLE-ARRAY NIL (dim0)). Objects of type vector_type have element + type T again. + (heap_statistics_mapper): Handle strings of element type NIL. Objects + of type vector_type have element type T again. + * sequence.d (get_seq_type): Handle strings of element type NIL. + Objects of type vector_type have element type T again. + (READ-CHAR-SEQUENCE): Signal an error when the string has element type + NIL. + (WRITE-CHAR-SEQUENCE): Likewise. + * hashtabl.d (hashcode_string): Handle strings of element type NIL. + (hashcode4_vector): Likewise. + * io.d (string_printf): Handle strings of element type NIL. + (write_string): Signal an error when the string has element type NIL. + (pr_symbol_part): Don't SstringDispatch if the string's length is 0. + (pr_sstring_ab): Likewise. + (pr_string): Handle strings of element type NIL. + (UNREADABLE_START, UNREADABLE_END): Nop. + (pr_vector): Remove code for printing vectors of element type NIL. + (pr_nilvector): New function. + * stream.d (wr_ch_array_terminal3): Update. + (read_line): Handle strings of element type NIL. + * pathname.d (split_name_type): Don't SstringDispatch if the string's + length is 0. + (PARSE-NAMESTRING): Likewise. Update. + * spvw_typealloc.d (reallocate_small_string): Update. + * spvw_debug.d (string_out): Handle strings of element type NIL. + * encoding.d (string_to_asciz_): Handle strings of element type NIL. + * package.d (string_hashcode): Don't SstringDispatch if the string's + length is 0. + * type.lisp (canonicalize-type): In STRING and SIMPLE-STRING, the + element-type can be CHARACTER, BASE-CHAR or NIL, not just CHARACTER. + * describe.lisp (describe-object): Don't show string details for + strings of element type NIL. + 2004-03-19 Sam Steingold <sd...@gn...> * clos.lisp (defgeneric): added (DECLARE IN-DEFUN) to avoid a Index: type.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/type.lisp,v retrieving revision 1.51 retrieving revision 1.52 diff -u -d -r1.51 -r1.52 --- type.lisp 22 Feb 2004 16:46:55 -0000 1.51 +++ type.lisp 21 Mar 2004 16:26:53 -0000 1.52 @@ -1028,7 +1028,9 @@ `(SIMPLE-ARRAY BIT (,size)))) (SIMPLE-STRING ; (SIMPLE-STRING &optional size) (let ((size (or (second type) '*))) - `(SIMPLE-ARRAY CHARACTER (,size)))) + `(OR (SIMPLE-ARRAY CHARACTER (,size)) + #-BASE-CHAR=CHARACTER (SIMPLE-ARRAY BASE-CHAR (,size)) + (SIMPLE-ARRAY NIL (,size))))) (SIMPLE-BASE-STRING ; (SIMPLE-BASE-STRING &optional size) (let ((size (or (second type) '*))) `(SIMPLE-ARRAY BASE-CHAR (,size)))) @@ -1040,7 +1042,9 @@ `(ARRAY BIT (,size)))) (STRING ; (STRING &optional size) (let ((size (or (second type) '*))) - `(ARRAY CHARACTER (,size)))) + `(OR (ARRAY CHARACTER (,size)) + #-BASE-CHAR=CHARACTER (ARRAY BASE-CHAR (,size)) + (ARRAY NIL (,size))))) (BASE-STRING ; (BASE-STRING &optional size) (let ((size (or (second type) '*))) `(ARRAY BASE-CHAR (,size)))) Index: spvw_typealloc.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_typealloc.d,v retrieving revision 1.32 retrieving revision 1.33 diff -u -d -r1.32 -r1.33 --- spvw_typealloc.d 19 Mar 2004 12:36:29 -0000 1.32 +++ spvw_typealloc.d 21 Mar 2004 16:26:53 -0000 1.33 @@ -263,12 +263,14 @@ SstringCase(string, { copy_8bit_32bit(&TheS8string(string)->data[0],&TheS32string(newstring)->data[0],len); }, { copy_16bit_32bit(&TheS16string(string)->data[0],&TheS32string(newstring)->data[0],len); }, + abort();, abort(); ); } else if (newtype == Sstringtype_16Bit) { SstringCase(string, { copy_8bit_16bit(&TheS8string(string)->data[0],&TheS16string(newstring)->data[0],len); }, abort();, + abort();, abort(); ); } else Index: sequence.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/sequence.d,v retrieving revision 1.70 retrieving revision 1.71 diff -u -d -r1.70 -r1.71 --- sequence.d 23 Feb 2004 17:08:39 -0000 1.70 +++ sequence.d 21 Mar 2004 16:26:52 -0000 1.71 @@ -245,7 +245,17 @@ if (listp(seq)) name = S(list); # Typ LIST else if (vectorp(seq)) { switch (Array_type(seq)) { - case Array_type_sstring: case Array_type_string: + case Array_type_string: + switch (Iarray_flags(seq) & arrayflags_atype_mask) { + case Atype_NIL: /* type (VECTOR NIL) */ + name = Fixnum_0; break; + case Atype_Char: /* type STRING */ + name = S(string); break; + default: + NOTREACHED; + } + break; + case Array_type_sstring: name = S(string); break; # Typ STRING case Array_type_sbvector: case Array_type_bvector: name = S(bit_vector); break; # Typ BIT-VECTOR @@ -261,17 +271,7 @@ 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_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: + case Array_type_vector: case Array_type_svector: name = S(vector); break; # Typ [GENERAL-]VECTOR default: NOTREACHED; @@ -4338,6 +4338,7 @@ } var uintL index = 0; STACK_0 = array_displace_check(STACK_4,end,&index); + if (simple_nilarray_p(STACK_0)) fehler_nilarray_store(); check_sstring_mutable(STACK_0); var uintL result = read_char_array(&STACK_3,&STACK_0,index+start,end-start); VALUES1(fixnum(start+result)); @@ -4387,6 +4388,7 @@ if (len > 0) { var uintL index = 0; STACK_0 = array_displace_check(STACK_4,end,&index); + if (simple_nilarray_p(STACK_0)) fehler_nilarray_retrieve(); write_char_array(&STACK_3,&STACK_0,index+start,len); } } else { Index: charstrg.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/charstrg.d,v retrieving revision 1.99 retrieving revision 1.100 diff -u -d -r1.99 -r1.100 --- charstrg.d 19 Mar 2004 12:41:45 -0000 1.99 +++ charstrg.d 21 Mar 2004 16:26:53 -0000 1.100 @@ -546,7 +546,7 @@ > object string: a string < uintL len: the fill-pointer length of the string < uintL offset: offset into the datastorage vector - < object result: datastorage vector */ + < object result: datastorage vector, a simple-string or NIL */ global object unpack_string_ro (object string, uintL* len, uintL* offset) { if (simple_string_p(string)) { sstring_un_realloc(string); @@ -577,11 +577,14 @@ unpack_string_rw(string,&len) [for read-write access] > object string: a string < uintL len: the fill-pointer length of the string - < uintL offset: Offset in the Data-Vector. - < object result: Data-Vector */ + < uintL offset: offset in the datastorage vector + < object result: datastorage vector, a simple-string or NIL */ global object unpack_string_rw (object string, uintL* len, uintL* offset) { var object unpacked = unpack_string_ro(string,len,offset); - check_sstring_mutable(unpacked); + if (*len > 0) { + if (simple_nilarray_p(unpacked)) fehler_nilarray_access(); + check_sstring_mutable(unpacked); + } return unpacked; } @@ -858,10 +861,13 @@ { copy_16bit_32bit(&TheS16string(string)->data[offset], &TheS32string(new_string)->data[0],len); }, { copy_32bit_32bit(&TheS32string(string)->data[offset], - &TheS32string(new_string)->data[0],len); }); + &TheS32string(new_string)->data[0],len); }, + { fehler_nilarray_retrieve(); }); #else - copy_8bit_8bit(&TheS8string(string)->data[offset], - &TheS8string(new_string)->data[0],len); + SstringCase(string, { NOTREACHED; }, { NOTREACHED; }, + { copy_8bit_8bit(&TheS8string(string)->data[offset], + &TheS8string(new_string)->data[0],len); }, + { fehler_nilarray_retrieve(); }); #endif } return new_string; @@ -884,7 +890,8 @@ SstringCase(string, { flavour = smallest_string_flavour8(&TheS8string(string)->data[offset],len); }, { flavour = smallest_string_flavour16(&TheS16string(string)->data[offset],len); }, - { flavour = smallest_string_flavour32(&TheS32string(string)->data[offset],len); }); + { flavour = smallest_string_flavour32(&TheS32string(string)->data[offset],len); }, + { flavour = Sstringtype_8Bit; }); } else flavour = Sstringtype_32Bit; pushSTACK(string); /* save string */ @@ -902,7 +909,8 @@ { copy_16bit_8bit(&TheS16string(string)->data[offset], &TheS8string(new_string)->data[0],len); }, { copy_32bit_8bit(&TheS32string(string)->data[offset], - &TheS8string(new_string)->data[0],len); }); + &TheS8string(new_string)->data[0],len); }, + { fehler_nilarray_retrieve(); }); } else if (flavour == Sstringtype_16Bit) { SstringCase(string, { copy_8bit_16bit(&TheS8string(string)->data[offset], @@ -910,7 +918,8 @@ { copy_16bit_16bit(&TheS16string(string)->data[offset], &TheS16string(new_string)->data[0],len); }, { copy_32bit_16bit(&TheS32string(string)->data[offset], - &TheS16string(new_string)->data[0],len); }); + &TheS16string(new_string)->data[0],len); }, + { NOTREACHED; }); } else { SstringCase(string, { copy_8bit_32bit(&TheS8string(string)->data[offset], @@ -918,7 +927,8 @@ { copy_16bit_32bit(&TheS16string(string)->data[offset], &TheS32string(new_string)->data[0],len); }, { copy_32bit_32bit(&TheS32string(string)->data[offset], - &TheS32string(new_string)->data[0],len); }); + &TheS32string(new_string)->data[0],len); }, + { NOTREACHED; }); } } return new_string; @@ -988,6 +998,10 @@ var uintL len; var uintL offset; var object string = unpack_string_ro(obj,&len,&offset); + if (simple_nilarray_p(string)) { + if (len > 0) fehler_nilarray_retrieve(); + return allocate_imm_string(0); + } #ifdef UNICODE #ifdef HAVE_SMALL_SSTRING if (sstring_eltype(TheSstring(string)) == Sstringtype_8Bit) { @@ -1173,7 +1187,8 @@ { copy_16bit_32bit(&TheS16string(string)->data[offset], &TheS32string(new_string)->data[0],len); }, { copy_32bit_32bit(&TheS32string(string)->data[offset], - &TheS32string(new_string)->data[0],len); }); + &TheS32string(new_string)->data[0],len); }, + { fehler_nilarray_retrieve(); }); } return new_string; } @@ -1189,10 +1204,13 @@ { /* (SYS::STRING-INFO str) => char-len(8/16/32); immutable-p; realloc-p */ var object str = popSTACK(); if (stringp(str)) { - value3 = NIL; - while (!simple_string_p(str)) { - str = TheIarray(str)->data; + if (!simple_string_p(str)) { + if ((Iarray_flags(str) & arrayflags_atype_mask) == Atype_NIL) goto other; + do { + str = TheIarray(str)->data; + } while (!simple_string_p(str)); } + value3 = NIL; while (sstring_reallocatedp(TheSstring(str))) { value3 = T; str = TheSistring(str)->data; @@ -1200,6 +1218,7 @@ value2 = (sstring_immutable(TheSstring(str)) ? T : NIL); value1 = fixnum(8 << sstring_eltype(TheSstring(str))); } else + other: value1 = value2 = value3 = NIL; mv_count = 3; } @@ -2154,8 +2173,13 @@ LISPFUNNR(schar,2) { /* (SCHAR string integer), CLTL p. 300 */ var object string = STACK_1; - if (!simple_string_p(string)) - fehler_sstring(string); + if (!simple_string_p(string)) { /* must be a simple-string */ + if (stringp(string) + && (Iarray_flags(string) & arrayflags_atype_mask) == Atype_NIL) + fehler_nilarray_store(); + else + fehler_sstring(string); + } sstring_un_realloc(string); var uintL index = test_index_arg(Sstring_length(string)); VALUES1(code_char(schar(string,index))); @@ -2178,6 +2202,7 @@ } else { len = TheIarray(string)->totalsize; string = iarray_displace_check(string,len,&offset); + if (simple_nilarray_p(string)) fehler_nilarray_store(); } check_sstring_mutable(string); offset += test_index_arg(len); /* go to the element addressed by index */ @@ -2191,8 +2216,13 @@ = (SETF (SCHAR simple-string index) newchar), CLTL p. 300 */ var object newchar = check_char(popSTACK()); /* newchar-argument */ var object string = STACK_1; /* string-argument */ - if (!simple_string_p(string)) /* must be a simple-string */ - fehler_sstring(string); + if (!simple_string_p(string)) { /* must be a simple-string */ + if (stringp(string) + && (Iarray_flags(string) & arrayflags_atype_mask) == Atype_NIL) + fehler_nilarray_store(); + else + fehler_sstring(string); + } sstring_un_realloc(string); check_sstring_mutable(string); var uintL offset = test_index_arg(Sstring_length(string)); /* go to the element addressed by index */ @@ -2210,6 +2240,8 @@ < result: vector-argument increases STACK by 3 */ global object test_vector_limits (stringarg* arg) { + if (arg->len > 0 && simple_nilarray_p(arg->string)) + fehler_nilarray_retrieve(); var uintL start, end; /* arg->len is the length (<2^oint_data_len). check :START-argument: @@ -2259,8 +2291,10 @@ increases STACK by 3 */ local object test_string_limits_rw (stringarg* arg) { var object string = test_string_limits_ro(arg); - if (arg->len > 0) + if (arg->len > 0) { + if (simple_nilarray_p(arg->string)) fehler_nilarray_access(); check_sstring_mutable(arg->string); + } return string; } @@ -2356,6 +2390,10 @@ string1 = popSTACK(); /* restore string1 */ arg1->string = unpack_string_ro(string1,&len1,&arg1->offset); /* now, len1 is the length (<2^oint_data_len) of string1. */ + if (arg1->len > 0 && simple_nilarray_p(arg1->string)) + fehler_nilarray_retrieve(); + if (arg2->len > 0 && simple_nilarray_p(arg2->string)) + fehler_nilarray_retrieve(); } { /* check :START1 and :END1: */ var uintL start1; @@ -2431,22 +2469,25 @@ < ergebnis: 0 if equal, -1 if string1 is genuinely lesser than string2, +1 if string1 is genuinely bigger than string2. */ -local signean string_comp (stringarg* arg1, const stringarg* arg2){ +local signean string_comp (stringarg* arg1, const stringarg* arg2) { var uintL len1 = arg1->len; var uintL len2 = arg2->len; SstringCase(arg1->string, { var const cint8* charptr1_0 = &TheS8string(arg1->string)->data[arg1->offset]; var const cint8* charptr1 = &charptr1_0[arg1->index]; + /* one of the strings empty ? */ + if (len1==0) goto A_string1_end; + if (len2==0) goto A_string2_end; SstringDispatch(arg2->string,X2, { var const cintX2* charptr2 = &((SstringX2)TheVarobject(arg2->string))->data[arg2->offset+arg2->index]; loop { - /* one of the strings finished ? */ - if (len1==0) goto A_string1_end; - if (len2==0) goto A_string2_end; /* compare next characters: */ if (!chareq(as_chart(*charptr1++),as_chart(*charptr2++))) break; /* decrease both counters: */ len1--; len2--; + /* one of the strings finished ? */ + if (len1==0) goto A_string1_end; + if (len2==0) goto A_string2_end; } /* two different characters are found */ arg1->index = --charptr1 - charptr1_0; @@ -2467,16 +2508,19 @@ }, { var const cint16* charptr1_0 = &TheS16string(arg1->string)->data[arg1->offset]; var const cint16* charptr1 = &charptr1_0[arg1->index]; + /* one of the strings empty ? */ + if (len1==0) goto B_string1_end; + if (len2==0) goto B_string2_end; SstringDispatch(arg2->string,X2, { var const cintX2* charptr2 = &((SstringX2)TheVarobject(arg2->string))->data[arg2->offset+arg2->index]; loop { - /* one of the strings finished ? */ - if (len1==0) goto B_string1_end; - if (len2==0) goto B_string2_end; /* compare next characters: */ if (!chareq(as_chart(*charptr1++),as_chart(*charptr2++))) break; /* decrease both counters: */ len1--; len2--; + /* one of the strings finished ? */ + if (len1==0) goto B_string1_end; + if (len2==0) goto B_string2_end; } /* two different characters are found */ arg1->index = --charptr1 - charptr1_0; @@ -2497,16 +2541,19 @@ }, { var const cint32* charptr1_0 = &TheS32string(arg1->string)->data[arg1->offset]; var const cint32* charptr1 = &charptr1_0[arg1->index]; + /* one of the strings empty ? */ + if (len1==0) goto C_string1_end; + if (len2==0) goto C_string2_end; SstringDispatch(arg2->string,X2, { var const cintX2* charptr2 = &((SstringX2)TheVarobject(arg2->string))->data[arg2->offset+arg2->index]; loop { - /* one of the strings finished ? */ - if (len1==0) goto C_string1_end; - if (len2==0) goto C_string2_end; /* compare next characters: */ if (!chareq(as_chart(*charptr1++),as_chart(*charptr2++))) break; /* decrease both counters: */ len1--; len2--; + /* one of the strings finished ? */ + if (len1==0) goto C_string1_end; + if (len2==0) goto C_string2_end; } /* two different characters are found */ arg1->index = --charptr1 - charptr1_0; @@ -2524,6 +2571,20 @@ C_string2_end: /* string2 is finished, string1 is not yet finished */ arg1->index = charptr1 - charptr1_0; return signean_plus; /* string2 is a genuine starting piece of string1 */ + }, { + /* one of the strings empty ? */ + if (len1==0) goto D_string1_end; + if (len2==0) goto D_string2_end; + fehler_nilarray_retrieve(); + D_string1_end: /* string1 finished */ + arg1->index = 0; + if (len2==0) + return signean_null; /* string1 = string2 */ + else /* string1 is a genuine starting piece of string2 */ + return signean_minus; + D_string2_end: /* string2 is finished, string1 is not yet finished */ + arg1->index = 0; + return signean_plus; /* string2 is a genuine starting piece of string1 */ }); } @@ -2634,16 +2695,19 @@ var const cint8* charptr1 = &charptr1_0[arg1->index]; var chart ch1; var chart ch2; + /* one of the strings empty ? */ + if (len1==0) goto A_string1_end; + if (len2==0) goto A_string2_end; SstringDispatch(arg2->string,X2, { var const cintX2* charptr2 = &((SstringX2)TheVarobject(arg2->string))->data[arg2->offset+arg2->index]; loop { - /* is one of the strings finished ? */ - if (len1==0) goto A_string1_end; - if (len2==0) goto A_string2_end; /* compare next characters: */ if (!chareq(ch1 = up_case(as_chart(*charptr1++)), ch2 = up_case(as_chart(*charptr2++)))) break; /* decrease both counters: */ len1--; len2--; + /* is one of the strings finished ? */ + if (len1==0) goto A_string1_end; + if (len2==0) goto A_string2_end; } }); /* two different characters are found */ @@ -2666,16 +2730,19 @@ var const cint16* charptr1 = &charptr1_0[arg1->index]; var chart ch1; var chart ch2; + /* one of the strings empty ? */ + if (len1==0) goto B_string1_end; + if (len2==0) goto B_string2_end; SstringDispatch(arg2->string,X2, { var const cintX2* charptr2 = &((SstringX2)TheVarobject(arg2->string))->data[arg2->offset+arg2->index]; loop { - /* is one of the strings finished ? */ - if (len1==0) goto B_string1_end; - if (len2==0) goto B_string2_end; /* compare next characters: */ if (!chareq(ch1 = up_case(as_chart(*charptr1++)), ch2 = up_case(as_chart(*charptr2++)))) break; /* decrease both counters: */ len1--; len2--; + /* is one of the strings finished ? */ + if (len1==0) goto B_string1_end; + if (len2==0) goto B_string2_end; } }); /* two different characters are found */ @@ -2698,16 +2765,19 @@ var const cint32* charptr1 = &charptr1_0[arg1->index]; var chart ch1; var chart ch2; + /* one of the strings empty ? */ + if (len1==0) goto C_string1_end; + if (len2==0) goto C_string2_end; SstringDispatch(arg2->string,X2, { var const cintX2* charptr2 = &((SstringX2)TheVarobject(arg2->string))->data[arg2->offset+arg2->index]; loop { - /* is one of the strings finished ? */ - if (len1==0) goto C_string1_end; - if (len2==0) goto C_string2_end; /* compare next characters: */ if (!chareq(ch1 = up_case(as_chart(*charptr1++)), ch2 = up_case(as_chart(*charptr2++)))) break; /* decrease both counters: */ len1--; len2--; + /* is one of the strings finished ? */ + if (len1==0) goto C_string1_end; + if (len2==0) goto C_string2_end; } }); /* two different characters are found */ @@ -2725,6 +2795,20 @@ C_string2_end: /* string2 is finished, string1 is not yet finished */ arg1->index = charptr1 - charptr1_0; return signean_plus; /* string2 is a genuine starting piece of string1 */ + }, { + /* one of the strings empty ? */ + if (len1==0) goto D_string1_end; + if (len2==0) goto D_string2_end; + fehler_nilarray_retrieve(); + D_string1_end: /* string1 finished */ + arg1->index = 0; + if (len2==0) + return signean_null; /* string1 = string2 */ + else /* string1 is a genuine starting piece of string2 */ + return signean_minus; + D_string2_end: /* string2 is finished, string1 is not yet finished */ + arg1->index = 0; + return signean_plus; /* string2 is a genuine starting piece of string1 */ }); } @@ -3049,6 +3133,8 @@ var cint32* charptr = &TheS32string(dv)->data[offset]; do { *charptr = as_cint(up_case(as_chart(*charptr))); charptr++; } while (--len); + },{ + fehler_nilarray_retrieve(); }); } @@ -3121,6 +3207,8 @@ var cint32* charptr = &TheS32string(dv)->data[offset]; do { *charptr = as_cint(down_case(as_chart(*charptr))); charptr++; } while (--len); + },{ + fehler_nilarray_retrieve(); }); } @@ -3172,88 +3260,92 @@ resp. search for end of word (and do convert). can trigger GC */ global void nstring_capitalize (object dv, uintL offset, uintL len) { - var chart ch; - SstringCase(dv,{ - /* Search the start of a word. */ - search_wordstart_8: - while (len!=0) { - ch = as_chart(TheS8string(dv)->data[offset]); - if (alphanumericp(ch)) - goto wordstart_8; - offset++; len--; - } - return; /* len = 0 -> string terminated */ - /* Found the start of a word. */ - wordstart_8: - dv = sstring_store(dv,offset,up_case(ch)); - loop { - offset++; - if (sstring_reallocatedp(TheSstring(dv))) { /* has it been reallocated? */ - dv = TheSistring(dv)->data; - SstringCase(dv, NOTREACHED;, goto in_word_16;, goto in_word_32; ); + if (len > 0) { + var chart ch; + SstringCase(dv,{ + /* Search the start of a word. */ + search_wordstart_8: + while (len!=0) { + ch = as_chart(TheS8string(dv)->data[offset]); + if (alphanumericp(ch)) + goto wordstart_8; + offset++; len--; } - in_word_8: - if (--len==0) - break; - ch = as_chart(TheS8string(dv)->data[offset]); - if (!alphanumericp(ch)) - goto search_wordstart_8; - dv = sstring_store(dv,offset,down_case(ch)); - } - return; /* len = 0 -> string terminated */ - },{ - /* Search the start of a word. */ - search_wordstart_16: - while (len!=0) { - ch = as_chart(TheS16string(dv)->data[offset]); - if (alphanumericp(ch)) - goto wordstart_16; - offset++; len--; - } - return; /* len = 0 -> string terminated */ - /* Found the start of a word. */ - wordstart_16: - dv = sstring_store(dv,offset,up_case(ch)); - loop { - offset++; - if (sstring_reallocatedp(TheSstring(dv))) { /* has it been reallocated? */ - dv = TheSistring(dv)->data; - SstringCase(dv, NOTREACHED;, NOTREACHED;, goto in_word_32; ); + return; /* len = 0 -> string terminated */ + /* Found the start of a word. */ + wordstart_8: + dv = sstring_store(dv,offset,up_case(ch)); + loop { + offset++; + if (sstring_reallocatedp(TheSstring(dv))) { /* has it been reallocated? */ + dv = TheSistring(dv)->data; + SstringCase(dv, NOTREACHED;, goto in_word_16;, goto in_word_32;, NOTREACHED; ); + } + in_word_8: + if (--len==0) + break; + ch = as_chart(TheS8string(dv)->data[offset]); + if (!alphanumericp(ch)) + goto search_wordstart_8; + dv = sstring_store(dv,offset,down_case(ch)); } - in_word_16: - if (--len==0) - break; - ch = as_chart(TheS16string(dv)->data[offset]); - if (!alphanumericp(ch)) - goto search_wordstart_16; - dv = sstring_store(dv,offset,down_case(ch)); - } - return; /* len = 0 -> string terminated */ - },{ - /* Search the start of a word. */ - search_wordstart_32: - while (len!=0) { - ch = as_chart(TheS32string(dv)->data[offset]); - if (alphanumericp(ch)) - goto wordstart_32; - offset++; len--; - } - return; /* len = 0 -> string terminated */ - /* Found the start of a word. */ - wordstart_32: - TheS32string(dv)->data[offset] = as_cint(up_case(ch)); - loop { - offset++; - in_word_32: - if (--len==0) - break; - ch = as_chart(TheS32string(dv)->data[offset]); - if (!alphanumericp(ch)) - goto search_wordstart_32; - TheS32string(dv)->data[offset] = as_cint(down_case(ch)); - } - return; /* len = 0 -> string terminated */ - }); + return; /* len = 0 -> string terminated */ + },{ + /* Search the start of a word. */ + search_wordstart_16: + while (len!=0) { + ch = as_chart(TheS16string(dv)->data[offset]); + if (alphanumericp(ch)) + goto wordstart_16; + offset++; len--; + } + return; /* len = 0 -> string terminated */ + /* Found the start of a word. */ + wordstart_16: + dv = sstring_store(dv,offset,up_case(ch)); + loop { + offset++; + if (sstring_reallocatedp(TheSstring(dv))) { /* has it been reallocated? */ + dv = TheSistring(dv)->data; + SstringCase(dv, NOTREACHED;, NOTREACHED;, goto in_word_32;, NOTREACHED; ); + } + in_word_16: + if (--len==0) + break; + ch = as_chart(TheS16string(dv)->data[offset]); + if (!alphanumericp(ch)) + goto search_wordstart_16; + dv = sstring_store(dv,offset,down_case(ch)); + } + return; /* len = 0 -> string terminated */ + },{ + /* Search the start of a word. */ + search_wordstart_32: + while (len!=0) { + ch = as_chart(TheS32string(dv)->data[offset]); + if (alphanumericp(ch)) + goto wordstart_32; + offset++; len--; + } + return; /* len = 0 -> string terminated */ + /* Found the start of a word. */ + wordstart_32: + TheS32string(dv)->data[offset] = as_cint(up_case(ch)); + loop { + offset++; + in_word_32: + if (--len==0) + break; + ch = as_chart(TheS32string(dv)->data[offset]); + if (!alphanumericp(ch)) + goto search_wordstart_32; + TheS32string(dv)->data[offset] = as_cint(down_case(ch)); + } + return; /* len = 0 -> string terminated */ + },{ + fehler_nilarray_retrieve(); + }); + } } LISPFUN(nstring_capitalize,seclass_default,1,0,norest,key,2, @@ -3311,10 +3403,13 @@ { copy_16bit_32bit(&TheS16string(string)->data[start], &TheS32string(new_string)->data[0],count); }, { copy_32bit_32bit(&TheS32string(string)->data[start], - &TheS32string(new_string)->data[0],count); }); + &TheS32string(new_string)->data[0],count); }, + { fehler_nilarray_retrieve(); }); #else - copy_8bit_8bit(&TheS8string(string)->data[start], - &TheS8string(new_string)->data[0],count); + SstringCase(string, { NOTREACHED; }, { NOTREACHED; }, + { copy_8bit_8bit(&TheS8string(string)->data[start], + &TheS8string(new_string)->data[0],count); }, + { fehler_nilarray_retrieve(); }); #endif } DBGREALLOC(new_string); @@ -3363,10 +3458,13 @@ { copy_16bit_32bit(&TheS16string(string)->data[offset+start], &TheS32string(new_string)->data[0],count); }, { copy_32bit_32bit(&TheS32string(string)->data[offset+start], - &TheS32string(new_string)->data[0],count); }); + &TheS32string(new_string)->data[0],count); }, + { fehler_nilarray_retrieve(); }); #else - copy_8bit_8bit(&TheS8string(string)->data[offset+start], - &TheS8string(new_string)->data[0],count); + SstringCase(string, { NOTREACHED; }, { NOTREACHED; }, + { copy_8bit_8bit(&TheS8string(string)->data[offset+start], + &TheS8string(new_string)->data[0],count); }, + { fehler_nilarray_retrieve(); }); #endif } DBGREALLOC(new_string); @@ -3413,9 +3511,12 @@ { copy_16bit_32bit(&TheS16string(string)->data[offset], charptr2,len); }, { copy_32bit_32bit(&TheS32string(string)->data[offset], - charptr2,len); }); + charptr2,len); }, + { fehler_nilarray_retrieve(); }); #else - copy_8bit_8bit(&TheS8string(string)->data[offset],charptr2,len); + SstringCase(string, { NOTREACHED; }, { NOTREACHED; }, + { copy_8bit_8bit(&TheS8string(string)->data[offset],charptr2,len); }, + { fehler_nilarray_retrieve(); }); #endif charptr2 += len; } Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.441 retrieving revision 1.442 diff -u -d -r1.441 -r1.442 --- lispbibl.d 19 Mar 2004 12:41:45 -0000 1.441 +++ lispbibl.d 21 Mar 2004 16:26:52 -0000 1.442 @@ -5931,18 +5931,13 @@ # Test for general-vector=(vector t) #ifdef TYPECODES #define general_vector_p(obj) \ - ((typecode(obj) == svector_type) \ - || (typecode(obj) == vector_type \ - && (Iarray_flags(obj) & arrayflags_atype_mask) == Atype_T \ - ) ) + ((typecode(obj) & ~bit(notsimple_bit_t)) == svector_type) #else # cases: Rectype_Svector, Rectype_vector #define general_vector_p(obj) \ (varobjectp(obj) \ - && ((Record_type(obj) == Rectype_Svector) \ - || (Record_type(obj) == Rectype_vector \ - && (Iarray_flags(obj) & arrayflags_atype_mask) == Atype_T \ - ) ) ) + && ((Record_type(obj) & ~(Rectype_Svector ^ Rectype_vector)) == (Rectype_Svector & Rectype_vector)) \ + ) #endif # Test for simple-string @@ -10861,6 +10856,10 @@ extern object array_displace_check (object array, uintL size, uintL* index); # used by HASHTABL, PREDTYPE, IO, FOREIGN +# Tests for the storage vector of an array of element type NIL. +# simple_nilarray_p(obj) +#define simple_nilarray_p(obj) nullp(obj) + # error-message # > STACK_1: Array (usually a Vector) # > STACK_0: (erroneous) Index @@ -10868,9 +10867,15 @@ # used by SEQUENCE # error message: attempt to retrieve a value from (ARRAY NIL) -nonreturning_function(extern, fehler_retrieve, (object array)); +nonreturning_function(extern, fehler_nilarray_retrieve, (void)); # used by PREDTYPE +# error message: attempt to store a value in (ARRAY NIL) +nonreturning_function(extern, fehler_nilarray_store, (void)); + +# error message: attempt to access a value from (ARRAY NIL) +nonreturning_function(extern, fehler_nilarray_access, (void)); + # Function: Performs an AREF access. # storagevector_aref(storagevector,index) # > storagevector: a storage vector (simple vector or semi-simple byte vector) @@ -11080,14 +11085,14 @@ # Function: Adds a substring to a semi-simple-string, thereby possibly # extending it. -# ssstring_append_extend(ssstring,sstring,start,len) +# ssstring_append_extend(ssstring,srcstring,start,len) # > ssstring: a semi-simple-string -# > sstring: a simple-string +# > srcstring: a simple-string # > start: the start index into the sstring # > len: the number of characters to be pushed, starting from start # < result: the same semi-simple-string # can trigger GC -extern object ssstring_append_extend (object ssstring, object sstring, uintL start, uintL len); +extern object ssstring_append_extend (object ssstring, object srcstring, uintL start, uintL len); # used by STREAM # The following functions work on "semi-simple byte-vector"s. @@ -11279,35 +11284,40 @@ #endif -# Dispatches among S8string, S16string and S32string. -# SstringCase(string,s8string_statement,s16string_statement,s32string_statement); -# > string: a not-reallocated simple-string +# Dispatches among S8string, S16string, S32string and nilvector. +# SstringCase(string,s8string_statement,s16string_statement,s32string_statement,nilvector_statement); +# > string: a not-reallocated simple-string or simple-nilvector (i.e. NIL) # Executes one of the three statement, depending on the element size of string. #ifdef UNICODE #ifdef HAVE_SMALL_SSTRING - #define SstringCase(string,s8string_statement,s16string_statement,s32string_statement) \ + #define SstringCase(string,s8string_statement,s16string_statement,s32string_statement,nilvector_statement) \ + if (Array_type(string) == Array_type_snilvector) { nilvector_statement } else \ if (sstring_eltype(TheSstring(string)) == Sstringtype_8Bit) { s8string_statement } else \ if (sstring_eltype(TheSstring(string)) == Sstringtype_16Bit) { s16string_statement } else \ if (sstring_eltype(TheSstring(string)) == Sstringtype_32Bit) { s32string_statement } else \ NOTREACHED; #else - #define SstringCase(string,s8string_statement,s16string_statement,s32string_statement) \ + #define SstringCase(string,s8string_statement,s16string_statement,s32string_statement,nilvector_statement) \ + if (Array_type(string) == Array_type_snilvector) { nilvector_statement } else \ { s32string_statement } #endif #else # In this case we take the s32string_statement, not the s8string_statement, # because the s32string_statement is the right one for normal simple strings. #define SstringCase(string,s8string_statement,s16string_statement,s32string_statement) \ + if (Array_type(string) == Array_type_snilvector) { nilvector_statement } else \ { /*s8string_statement*/ s32string_statement } #endif # is used by CHARSTRG, ARRAY, HASHTABL, PACKAGE, PATHNAME, PREDTYPE, STREAM -# Dispatches among S8string, S16string and S32string. +# Dispatches among S8string, S16string, S32string and nilvector. # SstringDispatch(string,suffix,statement) -# > string: a not-reallocated simple-string +# > string: a not-reallocated simple-string or simple-nilvector (i.e. NIL) # Executes the statement with cint##suffix being bound to the appropriate # integer type (cint8, cint16 or cint32) and with Sstring being bound to the # appropriate struct pointer type (S8string, S16string or S32string). +# Gives an error for simple-nilvector; must therefore only be called if the +# contents of the string is really to be accessed. #define SstringDispatch(string,suffix,statement) \ SstringCase(string, \ { typedef cint8 cint##suffix; typedef S8string Sstring##suffix; \ @@ -11318,6 +11328,8 @@ }, \ { typedef cint32 cint##suffix; typedef S32string Sstring##suffix; \ statement \ + }, \ + { fehler_nilarray_access(); \ }) # is used by CHARSTRG, ARRAY, HASHTABL, PACKAGE, PATHNAME, PREDTYPE, STREAM @@ -11340,7 +11352,10 @@ # (may be in string, may be on the stack) #ifdef HAVE_SMALL_SSTRING #define unpack_sstring_alloca(string,len,offset,charptr_assignment) \ - if (sstring_eltype(TheSstring(string)) == Sstringtype_32Bit) { \ + if (simple_nilarray_p(string)) { \ + if ((len) > 0) fehler_nilarray_retrieve(); \ + charptr_assignment NULL; \ + } else if (sstring_eltype(TheSstring(string)) == Sstringtype_32Bit) { \ charptr_assignment (const chart*) &TheS32string(string)->data[offset]; \ } else { \ var chart* _unpacked_ = (chart*)alloca((len)*sizeof(chart)); \ @@ -11356,16 +11371,20 @@ } #else #define unpack_sstring_alloca(string,len,offset,charptr_assignment) \ - charptr_assignment (const chart*) &TheSnstring(string)->data[offset]; + if (simple_nilarray_p(string)) { \ + if ((len) > 0) fehler_nilarray_retrieve(); \ + charptr_assignment NULL; \ + } else { \ + charptr_assignment (const chart*) &TheSnstring(string)->data[offset]; \ + } #endif # is used by # UP: Fetches a character from a simple string. # schar(string,index) -# > object string: a not-reallocated simple string +# > object string: a not-reallocated simple-string or simple-nilvector (i.e. NIL) # > uintL index: >= 0, < length of string # < chart result: character at the given position -#ifdef UNICODE #ifndef COMPILE_STANDALONE static inline chart schar (object string, uintL index) { SstringDispatch(string,X, { @@ -11374,17 +11393,14 @@ return as_chart(0); /* not reached - just pacify the compiler */ } #endif -#else - #define schar(string,index) as_chart(TheS32string(string)->data[index]) -#endif # is used by PATHNAME, STREAM # UP: unpacks a String. # unpack_string_rw(string,&len,&offset) [for read-write access] # > object string: a String. # < uintL len: number of characters of the String. -# < uintL offset: Offset in the Data-Vector. -# < object result: Data-Vector +# < uintL offset: offset in the datastorage vector +# < object result: datastorage vector, a simple-string or NIL extern object unpack_string_rw (object string, uintL* len, uintL* offset); # is used by AFFI @@ -11392,8 +11408,8 @@ # unpack_string_ro(string,&len,&offset) [for read-only access] # > object string: a String. # < uintL len: number of characters of the String. -# < uintL offset: Offset in the Data-Vector. -# < object result: Data-Vector +# < uintL offset: offset into the datastorage vector +# < object result: datastorage vector, a simple-string or NIL extern object unpack_string_ro (object string, uintL* len, uintL* offset); # is used by STREAM, HASHTABL, PACKAGE, SEQUENCE, ENCODING Index: spvw_debug.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw_debug.d,v retrieving revision 1.40 retrieving revision 1.41 diff -u -d -r1.40 -r1.41 --- spvw_debug.d 19 Mar 2004 12:32:20 -0000 1.40 +++ spvw_debug.d 21 Mar 2004 16:26:53 -0000 1.41 @@ -50,7 +50,8 @@ var uintL len; var uintL offset; var object string = unpack_string_ro(str,&len,&offset); - var const chart* srcptr = &TheSnstring(string)->data[offset]; + var const chart* srcptr; + unpack_sstring_alloca(string,len,offset, srcptr=); var DYNAMIC_ARRAY(buffer,uintB,len+1); var uintB* destptr = buffer; while (len--) *destptr++ = as_cint(*srcptr++); Index: encoding.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/encoding.d,v retrieving revision 1.107 retrieving revision 1.108 diff -u -d -r1.107 -r1.108 --- encoding.d 19 Mar 2004 12:36:29 -0000 1.107 +++ encoding.d 21 Mar 2004 16:26:53 -0000 1.108 @@ -2072,7 +2072,8 @@ var uintL len; var uintL offset; var object string = unpack_string_ro(obj,&len,&offset); - var const chart* sourceptr = &TheSnstring(string)->data[offset]; + var const chart* sourceptr; + unpack_sstring_alloca(string,len,offset, sourceptr=); /* source-string: length in len, bytes at sourceptr */ var uintB* destptr = &TheSbvector(newasciz)->data[0]; /* destination-string: bytes at destptr */ Index: io.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/io.d,v retrieving revision 1.199 retrieving revision 1.200 diff -u -d -r1.199 -r1.200 --- io.d 19 Mar 2004 12:36:18 -0000 1.199 +++ io.d 21 Mar 2004 16:26:51 -0000 1.200 @@ -23,7 +23,7 @@ return TheSbvector(ret)->data; } global void sstring_printf (object sstr, uintL len, uintL offset) { - uintL index; + var uintL index; ASSERT(simple_string_p(sstr)); sstring_un_realloc(sstr); printf("<%d/%d\"",len,offset); @@ -32,10 +32,13 @@ printf("\">"); } global void string_printf (object str) { - uintL len, offset; + var uintL len, offset; ASSERT(stringp(str)); str = unpack_string_ro(str,&len,&offset); - sstring_printf(str,len,offset); + if (simple_nilarray_p(str)) + printf("<%d/%d>",len,offset); + else + sstring_printf(str,len,offset); } #define NL_TYPE(x) \ (eq(x,S(Klinear))? 'L' : eq(x,S(Kmiser)) ? 'M' : eq(x,S(Kfill)) ? 'F' : 'D') @@ -5055,6 +5058,7 @@ var uintL len = vector_length(string); # length var uintL offset = 0; # offset of string in the data-vector var object sstring = iarray_displace_check(string,len,&offset); # data-vector + if (len > 0 && simple_nilarray_p(sstring)) fehler_nilarray_retrieve(); write_sstring_ab(stream_,sstring,offset,len); } } @@ -6679,6 +6683,7 @@ local pr_routine_t pr_bvector; local pr_routine_t pr_vector; local pr_routine_t pr_weakkvt; +local pr_routine_t pr_nilvector; local pr_routine_t pr_array; local pr_routine_t pr_instance; local pr_routine_t pr_structure; @@ -6969,19 +6974,22 @@ pushSTACK(string); # stack layout: syntax_table, string. write_ascii_char(stream_,'|'); - SstringDispatch(STACK_0,X, { - var uintL index = 0; - for (; index < len; index++) { - var chart c = as_chart(((SstringX)TheVarobject(STACK_0))->data[index]); # the next character - switch (syntax_table_get(STACK_1,c)) { # its Syntaxcode - case syntax_single_esc: - case syntax_multi_esc: # The Escape-Character c is prepended by '\': - write_ascii_char(stream_,'\\'); - default: ; - } - write_code_char(stream_,c); # print Character - } - }); + if (len > 0) { + SstringDispatch(STACK_0,X, { + var uintL index = 0; + do { + var chart c = as_chart(((SstringX)TheVarobject(STACK_0))->data[index]); # the next character + switch (syntax_table_get(STACK_1,c)) { # its Syntaxcode + case syntax_single_esc: + case syntax_multi_esc: # The Escape-Character c is prepended by '\': + write_ascii_char(stream_,'\\'); + default: ; + } + write_code_char(stream_,c); # print Character + index++; + } while (index < len); + }); + } write_ascii_char(stream_,'|'); skipSTACK(2); } @@ -7051,37 +7059,39 @@ pushSTACK(string); # save simple-string write_ascii_char(stream_,'"'); # prepend a quotation mark string = STACK_0; -#if 0 - SstringDispatch(string,X, { - dotimesL(len,len, { - var chart c = as_chart(((SstringX)TheVarobject(STACK_0))->data... [truncated message content] |