/* fns3.c Copyright (C) 1989-2002 Codemist Ltd */ /* * Basic functions part 3. * A concentration on hashtable, vector and array access code here. */ /* * This code may be used and modified, and redistributed in binary * or source form, subject to the "CCL Public License", which should * accompany it. This license is a variant on the BSD license, and thus * permits use of code derived from this in either open and commercial * projects: but it does require that updates to this code be made * available back to the originators of the package. * Before merging other code in with this or linking this code * with other packages or libraries please check that the license terms * of the other material are compatible with those of this. */ /* Signature: 679133c1 10-Oct-2002 */ #include #include #include #include "machine.h" #include "tags.h" #include "cslerror.h" #include "externs.h" #include "read.h" #include "entries.h" #include "arith.h" #ifdef COMMON #include "clsyms.h" #endif #ifdef TIMEOUT #include "timeout.h" #endif /* * Common Lisp and Standard Lisp disagree about vector sizes. Common * Lisp counts the number of elements in a vector (with make-simple-vector * and vector-bound) while Standard Lisp uses the value n, where the * vector concerned will accept index values from 0 to n (inclusive) * (mkvect and upbv). I provide the Standard Lisp versions always, so I * can use them even in Common Lisp mode. The vectors are exactly the * same - it is just a different way of talking about them. */ Lisp_Object Lmkvect(Lisp_Object nil, Lisp_Object n) { int32 n1; if (!is_fixnum(n)) return aerror1("mkvect", n); n1 = int_of_fixnum(n)*CELL; n1 += CELL; /* Oh! What an abomination! Standard Lisp allocated 0::n, */ /* Common allocates n items */ if (n1 < 0) return aerror1("mkvect", n); return onevalue(getvector_init(n1+CELL, nil)); } #ifdef COMMON Lisp_Object Lmksimplevec(Lisp_Object nil, Lisp_Object n) { int32 n1; if (!is_fixnum(n)) return aerror1("make-simple-vector", n); n1 = int_of_fixnum(n)*CELL; if (n1 < 0) return aerror1("make-simple-vector", n); return onevalue(getvector_init(n1+CELL, nil)); } #endif /* * This one creates a "structure" tagged vector. */ Lisp_Object Lmkevect(Lisp_Object nil, Lisp_Object n) { int32 n1; if (!is_fixnum(n)) return aerror1("mkevect", n); n1 = int_of_fixnum(n)*CELL; #ifndef COMMON n1 += CELL; /* Oh! What an abomination! Standard Lisp allocated 0::n, */ /* Common allocates n items */ #endif if (n1 < 0) return aerror1("mkevect", n); n = getvector_init(n1+CELL, nil); errexit(); vechdr(n) ^= (TYPE_SIMPLE_VEC ^ TYPE_STRUCTURE); return onevalue(n); } /* * The following creates a sort of vector where the first 3 items are * lisp pointers, and the remainder may be filled with binary stuff (which * is not byte-flipped or anything on garbage collection, and so is possibly * fairly unsafe). It is intended for internal or experimental use only. */ Lisp_Object Lmkxvect(Lisp_Object nil, Lisp_Object n) { int32 n1; if (!is_fixnum(n)) return aerror1("mkxvect", n); n1 = int_of_fixnum(n)*CELL; #ifndef COMMON n1 += CELL; /* Oh! What an abomination! Standard Lisp allocated 0::n, */ /* Common allocates n items */ #endif if (n1 < 3*CELL) return aerror1("mkxvect", n); n = getvector_init(n1+CELL, nil); errexit(); vechdr(n) ^= (TYPE_SIMPLE_VEC ^ TYPE_MIXED1); return onevalue(n); } Lisp_Object encapsulate_pointer(void *data) /* * Creates a boxed up representation of a pointer. Note that with this * function in place the tag-name SPARE is a misnomer! However I view * this code as a temporary experiment at the present... */ { Lisp_Object w = getvector(TAG_VECTOR, TYPE_SPARE, 2*CELL); Lisp_Object nil; errexit(); elt(w, 0) = (Lisp_Object)data; return w; } void *extract_pointer(Lisp_Object a) { if (!is_vector(a) || type_of_header(vechdr(a)) != TYPE_SPARE) return NULL; else return (void *)elt(a, 0); } Lisp_Object Lencapsulatedp(Lisp_Object nil, Lisp_Object a) { if (is_vector(a) && type_of_header(vechdr(a)) == TYPE_SPARE) return onevalue(lisp_true); else return nil; } /* * The next few functions are an EXPERIMENT and apply when a reference to * a native Maple object has somehow been imported into CSL and packed * up as an "encapsulated pointer" as per above. */ Lisp_Object Lmaple_atomic_value(Lisp_Object nil, Lisp_Object a) { Lisp_Object v; CSL_IGNORE(nil); if (!is_vector(a) || type_of_header(vechdr(a)) != TYPE_SPARE) return aerror1("not an encapsulated pointer", a); v = (Lisp_Object)extract_pointer(a); if ((v & 1) != 0) { /* * The next line overflows the range of CSL fixnums too early, but * will serve as a place-holder for a while! */ return onevalue(fixnum_of_int(v >> 1)); } else return onevalue(C_nil); } Lisp_Object Lmaple_tag(Lisp_Object nil, Lisp_Object a) { Lisp_Object v; Lisp_Object *v1; CSL_IGNORE(nil); if (!is_vector(a) || type_of_header(vechdr(a)) != TYPE_SPARE) return aerror1("not an encapsulated pointer", a); v = (Lisp_Object)extract_pointer(a); if ((v & 1) != 0) return onevalue(C_nil); /* an atomic value */ v1 = (Lisp_Object *)v; v = *v1; /* the header word of the Maple object */ /* The following line will be incorrect on 64-bit machines */ return onevalue(fixnum_of_int(v >> 26)); } Lisp_Object Lmaple_length(Lisp_Object nil, Lisp_Object a) { Lisp_Object v; Lisp_Object *v1; CSL_IGNORE(nil); if (!is_vector(a) || type_of_header(vechdr(a)) != TYPE_SPARE) return aerror1("not an encapsulated pointer", a); v = (Lisp_Object)extract_pointer(a); if ((v & 1) != 0) return onevalue(C_nil); /* an atomic value */ v1 = (Lisp_Object *)v; v = *v1; /* the header word of the Maple object */ /* The following line will be incorrect on 64-bit machines */ return onevalue(fixnum_of_int(v & 0x03ffffff)); } Lisp_Object Lmaple_string_data(Lisp_Object nil, Lisp_Object a) { Lisp_Object *p = (Lisp_Object *)extract_pointer(a); char *s = (char *)&p[3]; CSL_IGNORE(nil); return onevalue(make_string(s)); } Lisp_Object Lmaple_integer(Lisp_Object nil, Lisp_Object a) { Lisp_Object r = fixnum_of_int(0); Lisp_Object *p = (Lisp_Object *)extract_pointer(a); int i; Lisp_Object t = fixnum_of_int(1); int len = (int)(*p & 0x03ffffff); for (i=1; i= len) return aerror1("subscript out of range", nn); return onevalue(encapsulate_pointer((void *)v1[n+1])); } static int primep(int32 n) /* * Used to ensure that the body of a hash-table has a size that is prime. * Assumes odd number provided on entry, and that the value to be checked * is not especially large. Since it will have been handed in as a * fixnum it is at worst 2^28 or so, so brute-force should be OK. */ { int32 i; for (i=3; i*i<=n; i+=2) if (n%i == 0) return 0; return 1; } #define HASH_CHUNK_SIZE (((unsigned32)1) << (PAGE_BITS-3)) #define HASH_CHUNK_WORDS (HASH_CHUNK_SIZE/CELL) static Lisp_Object get_hash_vector(int32 n) { Lisp_Object v, nil = C_nil; /* * A major ugliness here is that I need to support hash tables that are * larger than the largest simple vector I can use (as limited by * CSL_PAGE_SIZE). To achieve this I will handle such huge tables using * a vector of vectors, with the higher level vector tagged as a STRUCT, * and the lower level vectors each sized at around 1/8 of a CSL page. The * modest chunk size is intended to limit the packing lossage I will see at * page boundaries. HASH_CHUNK_SIZE is the size (in bytes) used for data in * each such hash chunk. */ if (n > CSL_PAGE_SIZE/2) /* A fairly arbitrary cut-off */ { int32 chunks = (n + HASH_CHUNK_SIZE - 1)/HASH_CHUNK_SIZE; int32 i; v = getvector_init(CELL*(chunks+3), nil); errexit(); /* The next line tags the top level vector as a struct */ vechdr(v) ^= (TYPE_SIMPLE_VEC ^ TYPE_STRUCTURE); elt(v, 1) = fixnum_of_int(n); for (i=0; i> 11); prev = prev ^ ((prev & 0xffffff) * 169); return prev & 0x7fffffff; } static unsigned32 hash_eql(Lisp_Object key) /* * Must return same code for two eql numbers. This is remarkably * painfull! I would like the value to be insensitive to fine details * of the machine I am running on. */ { if (is_bfloat(key)) { int32 h = type_of_header(flthdr(key)); /* * For floating point values I look at the binary representation of * the number. */ union nasty { double fp; unsigned32 i[2]; } nasty_union; nasty_union.i[0] = nasty_union.i[1] = 0; switch (h) { #ifdef COMMON case TYPE_SINGLE_FLOAT: nasty_union.fp = (double)single_float_val(key); break; #endif case TYPE_DOUBLE_FLOAT: nasty_union.fp = double_float_val(key); break; #ifdef COMMON case TYPE_LONG_FLOAT: nasty_union.fp = (double)long_float_val(key); break; #endif default: nasty_union.fp = 0.0; } /* * The following line is OK on any one computer, but will generate values * that are not portable across machines with different floating point * representation. This is not too important when the hash value is only * used with my built-in implementation of hash tables, since I arrange * to re-hash everything when an image file is re-loaded (as well as on * any garbage collection), so non-portable calculation here is corrected * for automatically. */ return update_hash(nasty_union.i[0], nasty_union.i[1]); } else if (is_numbers(key)) { Header h = numhdr(key); unsigned32 r; int n; switch (type_of_header(h)) { case TYPE_BIGNUM: n = length_of_header(h); n = (n>>2) - 2; /* last index into the data */ r = update_hash(1, (unsigned32)h); /* * This mat be overkill - for very long bignums it is possibly a waste to * walk over ALL the digits when computing a hash value - I could do well * enough just looking at a few. But I still feel safer using all of them. */ while (n >= 0) { r = update_hash(r, bignum_digits(key)[n]); n--; } return r; #ifdef COMMON case TYPE_RATNUM: case TYPE_COMPLEX_NUM: return update_hash(hash_eql(numerator(key)), hash_eql(denominator(key))); #endif default: return 0x12345678; /* unknown type of number? */ } } /* * For all things OTHER than messy numbers I just hand back the * representation of the object as a C pointer. Well, I scramble it a bit * because otherwise too often Lisp objects only differ in their low order * bits. */ else return update_hash(1, (unsigned32)key); } static unsigned32 hash_cl_equal(Lisp_Object key, CSLbool descend) /* * This function is the one used hashing things under EQUAL, and note * that Common Lisp expects that EQUAL will NOT descend vectors or * structures, so this code had better not. But it is supposed to * descend path-names and it must treat non-simple strings and bitvectors * as if they were like ordinary strings and bitvectors. If descend is * false this will not descend through lists. */ { unsigned32 r = 1, c; Lisp_Object nil, w; int32 len; #ifdef COMMON int32 bitoff; #endif unsigned char *data; Header ha; #ifdef CHECK_STACK if (check_stack(__FILE__,__LINE__)) { err_printf("Stack too deep in hash calculation\n"); my_exit(EXIT_FAILURE); } #endif for (;;) { switch (TAG_BITS & (int32)key) { case TAG_CONS: if (key == C_nil || !descend) return r; r = update_hash(r, hash_cl_equal(qcar(key), YES)); nil = C_nil; if (exception_pending()) return 0; key = qcdr(key); continue; case TAG_SYMBOL: if (key == C_nil) return r; key = get_pname(key); nil = C_nil; if (exception_pending()) return 0; r = update_hash(r, 1); /* makes name & string hash differently */ /* Drop through, because the pname is a string */ case TAG_VECTOR: { ha = vechdr(key); len = type_of_header(ha); /* * I need to treat strings and bitvectors here specially since in those * cases (and for pathnames) I must inspect the vector contents, while * in other cases I must not. */ if (len == TYPE_STRING) { len = length_of_header(ha) - CELL; data = &ucelt(key, 0); goto hash_as_string; } #ifdef COMMON else if (header_of_bitvector(ha)) { len = length_of_header(ha); len = (len - 5)*8 + ((ha & 0x380) >> 7) + 1; bitoff = 0; data = &ucelt(key, 0); goto hash_as_bitvector; } #endif else if (len == TYPE_ARRAY) { /* * Arrays are fun here! I need to pick up the special case of character * vectors and bit vectors and make them compute the same hash value as the * simple case of the same thing. */ w = elt(key, 0); if (w == string_char_sym) ha = 0; #ifdef COMMON else if (w == bit_symbol) ha = 1; #endif else return update_hash(r, (unsigned32)key); w = elt(key, 1); /* List of dimensions */ if (!consp(w) || consp(qcdr(w))) /* 1 dim or more? */ return update_hash(r, (unsigned32)key); len = int_of_fixnum(qcar(w)); /* This is the length */ w = elt(key, 5); /* Fill pointer */ if (is_fixnum(w)) len = int_of_fixnum(w); w = elt(key, 3); /* displace adjustment */ key = elt(key, 2); /* vector holding the actual data */ data = &ucelt(key, 0); #ifdef COMMON if (ha) { bitoff = int_of_fixnum(w); goto hash_as_bitvector; } #endif data += int_of_fixnum(w); goto hash_as_string; } #ifdef COMMON /* * Common Lisp demands that pathname structures be compared and hashed in * a way that is expected to look at their contents. Here I just descend * all components of the pathname. */ else if (len == TYPE_STRUCTURE && elt(key, 0) == pathname_symbol && descend) { len = doubleword_align_up(length_of_header(ha)); while ((len -= CELL) != 0) { Lisp_Object ea = *((Lisp_Object *)((char *)key + len - TAG_VECTOR)); r = update_hash(r, hash_cl_equal(ea, YES)); nil = C_nil; if (exception_pending()) return 0; } return r; } #endif else return update_hash(r, (unsigned32)key); } case TAG_ODDS: if (is_bps(key)) { data = (unsigned char *)data_of_bps(key); /* I treat bytecode things as strings here */ len = length_of_header(*(Header *)(data - CELL)); goto hash_as_string; } else return update_hash(r, (unsigned32)key); case TAG_BOXFLOAT: /* * The "case TAG_BOXFLOAT:" above is not logically necessary, but at least * one release of a Silicon Graphics C compiler seems to miscompile this * function without it (when optimised). It is as if it seems the masking * with TAG_BITS in the switch() and therefore knows that there is just a * limited range of possibilities, so it omits the normal range-check one * would use before a table-branch. But it then leaves the branch table * that it generates NOT padded with the final case (TAG_BOXFLOAT) that is * needed, so when a floating point values does arise the code goes into the * yonder and usually crashes. */ default: return hash_eql(key); } hash_as_string: /* Here len is the length of the string data structure, excluding header */ while (len > 0) { c = data[--len]; r = update_hash(r, c); } return r; #ifdef COMMON hash_as_bitvector: /* here len is the number of bits to scan, and bitoff is a BIT offset */ len += bitoff; while (len > bitoff) { len--; c = data[len >> 3] & (1 << (len & 7)); if (c != 0) c = 1; r = update_hash(r, c); } return r; #endif } } static unsigned32 hash_equal(Lisp_Object key) /* * This function is the one used hashing things under the Standard Lisp * version of EQUAL, which descends vectors but is still sensitive to * case and which views different types of numbers as different. I will * make it view displaced or fill-pointered vectors as equivalent to the * corresponding simple vectors: I am pretty well obliged to do that for * strings and bitvectors so it seems polite to do the same for general * vectors (which are the only other ones I support!). */ { unsigned32 r = 1, c; Lisp_Object nil, w; int32 type, len, offset = 0; unsigned char *data; Header ha; #ifdef CHECK_STACK if (check_stack(__FILE__,__LINE__)) { err_printf("Stack too deep in hash calculation\n"); my_exit(EXIT_FAILURE); } #endif for (;;) { switch (TAG_BITS & (int32)key) { case TAG_CONS: if (key == C_nil) return r; r = update_hash(r, hash_equal(qcar(key))); nil = C_nil; if (exception_pending()) return 0; key = qcdr(key); continue; case TAG_SYMBOL: if (key == C_nil) return r; key = get_pname(key); nil = C_nil; if (exception_pending()) return 0; r = update_hash(r, 1); /* Drop through, because the pname is a string */ case TAG_VECTOR: { ha = vechdr(key); type = type_of_header(ha); len = length_of_header(ha) - CELL; /* counts in bytes here */ /* * First I will separate off the two important cases of strings and bitvectors */ if (type == TYPE_STRING) { data = &ucelt(key, 0); goto hash_as_string; } #ifdef COMMON else if (header_of_bitvector(ha)) { len = (len - 1)*8 + ((ha & 0x380) >> 7) + 1; offset = 0; data = &ucelt(key, 0); goto hash_as_bitvector; } #endif #ifdef COMMON /* * Common Lisp demands that pathname structures be compared and hashed in * a way that is expected to look at their contents. Here I just descend * all components of the pathname. */ if (len == TYPE_STRUCTURE && elt(key, 0) != pathname_symbol) return update_hash(r, (unsigned32)key); #endif /* * Now I will look for an array that is in fact just a vector. */ if (type == TYPE_ARRAY) { w = elt(key, 0); if (w == string_char_sym) ha = 0; #ifdef COMMON else if (w == bit_symbol) ha = 1; #endif else ha = 2; w = elt(key, 1); /* List of dimensions */ if (consp(w) && !consp(qcdr(w))) /* 1 dim or not? */ { len = int_of_fixnum(qcar(w)); /* This is the length */ w = elt(key, 5); /* Fill pointer */ if (is_fixnum(w)) len = int_of_fixnum(w); w = elt(key, 3); /* displace adjustment */ key = elt(key, 2); /* vector holding the data */ switch (ha) { case 0: data = &ucelt(key, int_of_fixnum(w)); goto hash_as_string; #ifdef COMMON case 1: data = &ucelt(key, 0); offset = int_of_fixnum(w); goto hash_as_bitvector; #endif default: /* /* The code here can CRASH if asked to hash a general array that * has been represented in chunks because it has over 32K elements. */ ha = vechdr(key); offset = int_of_fixnum(w); break; } } } /* * Now in the case that I had a non-simple vector I have reset key to point * to the vector containing the true data, ha to the header of same and * len is the length that I want to use. offset is an offset into the vector. * For simple vectors all the same variables are set up (and offset will be * zero). All cases of strings and bitvectors should have been dealt with * so the only vectors containing binary are things like "file" structures, * and I do not expect them to hash portably. */ if (vector_holds_binary(ha)) return update_hash(r, (unsigned32)key); offset = CELL*offset; if (is_mixed_header(ha)) { while (len > 4*CELL) { unsigned32 ea; len -= 4; ea = *(unsigned32 *)((char *)key + offset + len - TAG_VECTOR); r = update_hash(r, ea); } } while ((len -= CELL) != 0) { Lisp_Object ea = *((Lisp_Object *)((char *)key + offset + len - TAG_VECTOR)); r = update_hash(r, hash_equal(ea)); nil = C_nil; if (exception_pending()) return 0; } return r; } case TAG_ODDS: if (is_bps(key)) { data = (unsigned char *)data_of_bps(key); /* I treat bytecode things as strings here */ len = length_of_header(*(Header *)(data - CELL)); goto hash_as_string; } else return update_hash(r, (unsigned32)key); case TAG_BOXFLOAT: default:/* The default case here mainly covers numbers */ return hash_eql(key); } hash_as_string: /* Here len is the length of the string data structure, excluding header */ while (len > 0) { c = data[--len]; r = update_hash(r, c); } return r; #ifdef COMMON hash_as_bitvector: /* here len is the number of bits to scan, and offset is a BIT offset */ len += offset; while (len > offset) { len--; c = data[len >> 3] & (1 << (len & 7)); if (c != 0) c = 1; r = update_hash(r, c); } return r; #endif } } static unsigned32 hash_equalp(Lisp_Object key) /* * This function is the one used hashing things under the Common Lisp * version of EQUALP, which descends vectors but not structs (except * pathnames), which is case-insensitive and which views numbers of * different types but similar values (eg 1 and 1.0) as EQUALP). */ { unsigned32 r = 1, c; Lisp_Object nil, w; int32 type, len, offset = 0; unsigned char *data; Header ha; #ifdef CHECK_STACK if (check_stack(__FILE__,__LINE__)) { err_printf("Stack too deep in hash calculation\n"); my_exit(EXIT_FAILURE); } #endif for (;;) { switch (TAG_BITS & (int32)key) { case TAG_CONS: if (key == C_nil) return r; r = update_hash(r, hash_equalp(qcar(key))); nil = C_nil; if (exception_pending()) return 0; key = qcdr(key); continue; case TAG_SYMBOL: if (key == C_nil) return r; key = get_pname(key); nil = C_nil; if (exception_pending()) return 0; r = update_hash(r, 1); /* Drop through, because the pname is a string */ case TAG_VECTOR: { ha = vechdr(key); type = type_of_header(ha); len = length_of_header(ha) - CELL; /* counts in bytes here */ /* * First I will separate off the two important cases of strings and bitvectors */ if (type == TYPE_STRING) { data = &ucelt(key, 0); goto hash_as_string; } #ifdef COMMON else if (header_of_bitvector(ha)) { len = (len - 1)*8 + ((ha & 0x380) >> 7) + 1; offset = 0; data = &ucelt(key, 0); goto hash_as_bitvector; } #endif #ifdef COMMON /* * Common Lisp demands that pathname structures be compared and hashed in * a way that is expected to look at their contents. Here I just descend * all components of the pathname. Other structs are not descended. */ if (len == TYPE_STRUCTURE && elt(key, 0) != pathname_symbol) return update_hash(r, (unsigned32)key); #endif /* * Now I will look for an array that is in fact just a vector. */ if (type == TYPE_ARRAY) { w = elt(key, 0); if (w == string_char_sym) ha = 0; #ifdef COMMON else if (w == bit_symbol) ha = 1; #endif else ha = 2; w = elt(key, 1); /* List of dimensions */ if (consp(w) && !consp(qcdr(w))) /* 1 dim or not? */ { len = int_of_fixnum(qcar(w)); /* This is the length */ w = elt(key, 5); /* Fill pointer */ if (is_fixnum(w)) len = int_of_fixnum(w); w = elt(key, 3); /* displace adjustment */ key = elt(key, 2); /* vector holding the data */ switch (ha) { case 0: data = &ucelt(key, int_of_fixnum(w)); goto hash_as_string; #ifdef COMMON case 1: data = &ucelt(key, 0); offset = int_of_fixnum(w); goto hash_as_bitvector; #endif default: /* /* Trouble if a general array with over 32K elements gets to here */ ha = vechdr(key); offset = int_of_fixnum(w); break; } } } /* * Now in the case that I had a non-simple vector I have reset key to point * to the vector containing the true data, ha to the header of same and * len is the length that I want to use. offset is an offset into the vector. * For simple vectors all the same variables are set up (and offset will be * zero). All cases of strings and bitvectors should have been dealt with * so the only vectors containing binary are things like "file" structures, * and I do not expect them to hash portably. */ if (vector_holds_binary(ha)) return update_hash(r, (unsigned32)key); offset = 8*offset; if (is_mixed_header(ha)) { while (len > 4*CELL) { unsigned32 ea; len -= 4; ea = *(unsigned32 *)((char *)key + offset + len - TAG_VECTOR); r = update_hash(r, ea); } } while ((len -= CELL) != 0) { Lisp_Object ea = *((Lisp_Object *)((char *)key + offset + len - TAG_VECTOR)); r = update_hash(r, hash_equalp(ea)); nil = C_nil; if (exception_pending()) return 0; } return r; } case TAG_ODDS: if (is_bps(key)) { data = (unsigned char *)data_of_bps(key); /* I treat bytecode things as strings here */ len = length_of_header(*(Header *)(data - CELL)); goto hash_as_string; } else if (is_char(key)) key = pack_char(0, 0, tolower(code_of_char(key))); return update_hash(r, (unsigned32)key); case TAG_BOXFLOAT: default:/* The default case here mainly covers numbers */ if (is_float(key)) { key = rational(key); /* painful expense */ nil = C_nil; if (exception_pending()) return 0; } #ifdef COMMON if (is_numbers(key)) { switch (type_of_header(numhdr(key))) { case TYPE_RATNUM: case TYPE_COMPLEX_NUM: return update_hash(hash_equalp(numerator(key)), hash_equalp(denominator(key))); default: break; } } #endif return hash_eql(key); } /* * Note that I scan the elements of a string or bitvector in the same order * that I would process a general vector of the same length, and I adjust the * vector contents to its generic representation before updating the hash * value. For strings I fold to lower case. */ hash_as_string: /* Here len is the length of the string data structure, excluding header */ while (len > 0) { c = tolower(data[--len]); r = update_hash(r, update_hash(1, pack_char(0, 0, c))); } return r; #ifdef COMMON hash_as_bitvector: /* here len is the number of bits to scan, and offset is a BIT offset */ len += offset; while (len > offset) { len--; c = data[len >> 3] & (1 << (len & 7)); if (c != 0) c = 1; r = update_hash(r, update_hash(1, fixnum_of_int(c))); } return r; #endif } } static unsigned32 hashcode; static int hashsize, hashoffset, hashgap; static CSLbool large_hash_table; #define words_in_hash_table(v) \ (((large_hash_table ? int_of_fixnum(elt(v, 1)) : \ length_of_header(vechdr(v))) - 2*CELL)/CELL) #define ht_elt(v, n) \ (*(large_hash_table ? \ &elt(elt((v), 2+(n)/HASH_CHUNK_WORDS), (n)%HASH_CHUNK_WORDS) : \ &elt((v), (n)))) Lisp_Object MS_CDECL Lget_hash(Lisp_Object nil, int nargs, ...) { int32 size, p, flavour = -1, hashstride, nprobes; va_list a; Lisp_Object v, key, tab, dflt; argcheck(nargs, 3, "gethash"); va_start(a, nargs); key = va_arg(a, Lisp_Object); tab = va_arg(a, Lisp_Object); dflt = va_arg(a, Lisp_Object); va_end(a); if (!is_vector(tab) || type_of_header(vechdr(tab)) != TYPE_HASH) return aerror1("gethash", tab); v = elt(tab, 0); /* /* The code here needs to allow for user-specified hash functions */ if (is_fixnum(v)) flavour = int_of_fixnum(v); switch (flavour) { default: return aerror1("gethash", cons(v, tab)); case 0: hashcode = update_hash(1, (unsigned32)key); break; case 1: hashcode = hash_eql(key); /* can never fail */ break; case 2: push3(key, tab, dflt); hashcode = hash_cl_equal(key, YES); pop3(dflt, tab, key); errexit(); break; case 3: push3(key, tab, dflt); hashcode = hash_equal(key); pop3(dflt, tab, key); errexit(); break; case 4: push3(key, tab, dflt); hashcode = hash_equalp(key); pop3(dflt, tab, key); errexit(); break; } v = elt(tab, 4); large_hash_table = type_of_header(vechdr(v)) == TYPE_STRUCTURE; hashsize = size = words_in_hash_table(v); p = (hashcode % (unsigned32)(size >> 1))*2; /* * I want to take my single 32-bit hash value and produce a secondary * hash value that is a stride for the search. I can just take the * remainder by 1 less than the hash table size (and add 1 so I get * a non-zero stride). */ hashstride = (1 + (hashcode % (unsigned32)((size >> 1)-1)))*2; hashgap = -1; for (nprobes=0;nprobes= size) p = p - size; } return aerror("too many probes in hash look-up"); } static void reinsert_hash(Lisp_Object v, int32 size, int32 flavour, Lisp_Object key, Lisp_Object val) { int32 p; unsigned32 hcode, hstride; Lisp_Object nil = C_nil; switch (flavour) { default: /* case 0: */ hcode = update_hash(1, (unsigned32)key); break; case 1: hcode = hash_eql(key); /* can never fail */ break; case 2: push3(key, v, val); hcode = hash_cl_equal(key, YES); pop3(val, v, key); errexitv(); break; case 3: push3(key, v, val); hcode = hash_equal(key); pop3(val, v, key); errexitv(); break; case 4: push3(key, v, val); hcode = hash_equalp(key); pop3(val, v, key); errexitv(); break; } p = (hcode % (unsigned32)(size >> 1))*2; hstride = (1 + (hcode % (unsigned32)((size >> 1)-1)))*2; /* * When I re-insert the item into the table life is especially easy - * I know it is not there already and I know I will be able to find a * gap to put it in! So I just have to look for a gap - no comparisons * are needed. */ large_hash_table = type_of_header(vechdr(v)) == TYPE_STRUCTURE; for (;;) { Lisp_Object q = ht_elt(v, p+1); if (q == SPID_HASH0 || q == SPID_HASH1) { ht_elt(v, p+1) = key; ht_elt(v, p+2) = val; return; } p = p + hstride; if (p >= size) p = p - size; } } #define REHASH_CYCLES 2 #define REHASH_AT_ONE_GO 64 void rehash_this_table(Lisp_Object v) /* * Hash tables where the hash function depends on absolute memory addresses * will sometimes need rehashing - I do this by removing items from the * table one at a time and re-inserting them. This does not guarantee that * the table is left in a perfect state, but for modest loading will be * adequate. I reason that if I extract 64 (say) items at a time and * then re-insert them then (especially for smallish tables) I have a * better chance of things ending up in the ideal place. The problem is that * items that have not yet been moved may be sitting in places where a * re-hashed item ought to go. The effect will be that the newly re-inserted * item sees a clash and moves to a second-choice position. When the other * item is (later on) processed it will then vacate the place I would have * liked to use, leaving a "tombstone" marker behind. If at the end of all * re-hashing there are too many tombstones left around lookup performance * in the table will degrade. I attempt to counter this effect by performing * the whole re-hashing procedure several times. But I have neither analysed * nore measured what happens! I will do so if practical applications show * up serious trouble here. */ { int32 size, i, j, flavour, many; CSLbool old_large = large_hash_table; Lisp_Object pendkey[REHASH_AT_ONE_GO], pendval[REHASH_AT_ONE_GO]; flavour = int_of_fixnum(elt(v, 0)); /* Done this way always */ large_hash_table = type_of_header(vechdr(v)) == TYPE_STRUCTURE; size = words_in_hash_table(v); /* * The cycle count here is something I may want to experiment with. */ for (i=0; i= REHASH_AT_ONE_GO) { while (many > 0) { many--; reinsert_hash(v, size, flavour, pendkey[many], pendval[many]); } } } while (--many >= 0) reinsert_hash(v, size, flavour, pendkey[many], pendval[many]); } large_hash_table = old_large; } Lisp_Object Lmaphash(Lisp_Object nil, Lisp_Object fn, Lisp_Object tab) /* * There is a big worry here if the table is re-hashed because of * a garbage collection while I am in the middle of things. To * avoid utter shambles I will make a copy of the vector early * on and work from that. */ { int32 size, i; Lisp_Object v, v1; if (!is_vector(tab) || type_of_header(vechdr(tab)) != TYPE_HASH) return aerror1("maphash", tab); v = elt(tab, 4); large_hash_table = type_of_header(vechdr(v)) == TYPE_STRUCTURE; size = words_in_hash_table(v)*CELL+2*CELL; push2(fn, tab); v1 = get_hash_vector(size); pop2(tab, fn); v = elt(tab, 4); size = (size - CELL)/CELL; for (i=0; i 2) return aerror("hashcontents"); ogcnum = gc_number; for (i=1; i= 0) hashoffset = hashgap; ht_elt(work_0, hashoffset+1) = key; ht_elt(work_0, hashoffset+2) = val; elt(tab, 1) += 0x10; /* increment count of used entries */ if (elt(tab, 1) > elt(tab, 2)) { Lisp_Object size = elt(tab, 2), growth = elt(tab, 3), newhash, v; int32 isize = int_of_fixnum(size), i; push2(tab, val); if (is_fixnum(growth)) { int32 w1 = int_of_fixnum(growth); if (w1 > 0) isize = isize + w1; else isize = isize + (isize/2); } else if (is_float(growth)) { double w2 = float_of_number(growth); int32 newsize = isize; if (1.0 < w2 && w2 < 10.0) newsize = (int32)(w2 * (double)isize); if (newsize > isize) isize = newsize; else isize = isize + (isize/2); } else isize = isize + (isize/2); /* * NB - Lmkhash() does not disturb large_hash_table, so I can still * access the old table happily even after this call... */ newhash = Lmkhash(nil, 3, fixnum_of_int(isize), elt(tab, 0), growth); pop2(val, tab); errexit(); v = elt(tab, 4); for (i=0; i<=4; i++) elt(tab, i) = elt(newhash, i); large_hash_table = type_of_header(vechdr(v)) == TYPE_STRUCTURE; isize = words_in_hash_table(v); for (i=0; i> 16)) & 0x03ffffff; /* ensure it will be a positive fixnum */ return onevalue(fixnum_of_int(h)); } Lisp_Object Leqlhash(Lisp_Object nil, Lisp_Object key) { unsigned32 h = hash_cl_equal(key, NO); errexit(); h = (h ^ (h >> 16)) & 0x03ffffff; /* ensure it will be a positive fixnum */ return onevalue(fixnum_of_int(h)); } #ifdef COMMON Lisp_Object Lhash_flavour(Lisp_Object nil, Lisp_Object tab) { Lisp_Object v,flavour = fixnum_of_int(-1); if (!is_vector(tab) || type_of_header(vechdr(tab)) != TYPE_HASH) return aerror1("hash_flavour", tab); v = elt(tab, 0); /* The code here needs to allow for user-specified hash functions */ if (is_fixnum(v)) flavour = v; return onevalue(flavour); } #endif Lisp_Object MS_CDECL Lputv(Lisp_Object nil, int nargs, ...) { Header h; va_list a; intxx n1, hl; Lisp_Object v, n, x; argcheck(nargs, 3, "putv"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); x = va_arg(a, Lisp_Object); va_end(a); CSL_IGNORE(nil); if (!is_vector(v) || vector_holds_binary(h = vechdr(v))) return aerror1("putv", v); else if (!is_fixnum(n)) return aerror1("putv offset not fixnum", n); hl = (length_of_header(h) - CELL)/CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("putv index range", n); elt(v, n1) = x; return onevalue(x); } Lisp_Object Lgetv(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; intxx n1, hl; CSL_IGNORE(nil); if (!is_vector(v) || vector_holds_binary(h = vechdr(v))) return aerror1("getv", v); else if (!is_fixnum(n)) return aerror1("getv offset not fixnum", n); hl = (length_of_header(h) - CELL)/CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("getv index range", n); else return onevalue(elt(v, n1)); } /* * Here I make a (simple) string. */ Lisp_Object Lsmkvect(Lisp_Object nil, Lisp_Object n) { Lisp_Object w; intxx nn; if (!is_fixnum(n) || (intxx)n<0) return aerror1("make-simple-string", n); nn = int_of_fixnum(n); w = getvector(TAG_VECTOR, TYPE_STRING, nn+CELL); errexit(); nn = (intxx)doubleword_align_up(nn+CELL); while (nn > CELL) { nn -= CELL; *(intxx *)((char *)w - TAG_VECTOR + nn) = 0; } return onevalue(w); } /* * Here I make a vector capable of holding 8-bit binary integers. */ Lisp_Object Lmkvect8(Lisp_Object nil, Lisp_Object n) { Lisp_Object w; intxx nn; if (!is_fixnum(n) || (intxx)n<0) return aerror1("mkvect8", n); nn = int_of_fixnum(n); w = getvector(TAG_VECTOR, TYPE_VEC8, nn+CELL); errexit(); nn = (intxx)doubleword_align_up(nn+CELL); while (nn > CELL) { nn -= CELL; *(intxx *)((char *)w - TAG_VECTOR + nn) = 0; } return onevalue(w); } /* * Here I make a vector capable of holding 16-bit binary integers. */ Lisp_Object Lmkvect16(Lisp_Object nil, Lisp_Object n) { Lisp_Object w; intxx nn; if (!is_fixnum(n) || (intxx)n<0) return aerror1("mkvect16", n); nn = 2*int_of_fixnum(n); w = getvector(TAG_VECTOR, TYPE_VEC16, nn+CELL); errexit(); nn = (intxx)doubleword_align_up(nn+CELL); while (nn > CELL) { nn -= CELL; *(intxx *)((char *)w - TAG_VECTOR + nn) = 0; } return onevalue(w); } /* * Here I make a vector capable of holding 32-bit binary integers. */ Lisp_Object Lmkvect32(Lisp_Object nil, Lisp_Object n) { Lisp_Object w; intxx nn; if (!is_fixnum(n) || (intxx)n<0) return aerror1("mkvect32", n); nn = 4*int_of_fixnum(n); w = getvector(TAG_VECTOR, TYPE_VEC32, nn+CELL); errexit(); nn = (intxx)doubleword_align_up(nn+CELL); while (nn > CELL) { nn -= 4; *(int32 *)((char *)w - TAG_VECTOR + nn) = 0; } return onevalue(w); } /* * Here I make a vector capable of holding 32-bit floats. */ Lisp_Object Lmkfvect32(Lisp_Object nil, Lisp_Object n) { Lisp_Object w; intxx nn; if (!is_fixnum(n) || (intxx)n<0) return aerror1("mkfvect32", n); nn = 4*int_of_fixnum(n); w = getvector(TAG_VECTOR, TYPE_FLOAT32, nn+CELL); errexit(); nn = (intxx)doubleword_align_up(nn+CELL); while (nn > CELL) { nn -= 4; *(float *)((char *)w - TAG_VECTOR + nn) = (float)0.0; } return onevalue(w); } /* * Here I make a vector capable of holding 64-bit floats. */ Lisp_Object Lmkfvect64(Lisp_Object nil, Lisp_Object n) { Lisp_Object w; intxx nn; if (!is_fixnum(n) || (intxx)n<0) return aerror1("mkfvect64", n); nn = 8*int_of_fixnum(n); #ifndef ADDRESS_64 nn += 4; /* get the doubles aligned */ #endif w = getvector(TAG_VECTOR, TYPE_FLOAT64, nn+CELL); errexit(); nn = (intxx)(nn+CELL); while (nn > CELL) { nn -= 8; *(double *)((char *)w - TAG_VECTOR + nn) = 0.0; } return onevalue(w); } Lisp_Object simplify_string(Lisp_Object s) /* * s is supposed to be a string of some sort - return a simple string * with the same contents. This is horrid and messy, and relies on * a load of stuff coded elsewhere in Lisp: is is coded here in C * despite that because despite the breaches of modularity that are involved * doing so seems to make bootstrapping easier. */ { Header h; Lisp_Object w, nil = C_nil, h1; intxx i, n = 0; if (!is_vector(s)) return aerror("simplify-string"); h = vechdr(s); if (type_of_header(h) == TYPE_STRING) return onevalue(s); /* Already simple */ if (type_of_header(h) != TYPE_ARRAY) return aerror("simplify-string"); h1 = elt(s, 0); if (h1 != string_char_sym) return aerror("simplify-string"); h1 = elt(s, 1); /* Dimension list */ if (!consp(h1)) return aerror("simplify-string"); n = int_of_fixnum(qcar(h1)); /* Look at size involved */ h1 = elt(s, 5); /* Fill pointer */ if (is_fixnum(h1)) n = int_of_fixnum(h1); stackcheck1(0, s); nil = C_nil; push(s); w = getvector(TAG_VECTOR, TYPE_STRING, n+CELL); pop(s); errexit(); i = (intxx)doubleword_align_up(n+CELL); while (i > CELL) /* pre-fill target vector with zero */ { i -= CELL; *(intxx *)((char *)w - TAG_VECTOR + i) = 0; } h1 = elt(s, 3); h = int_of_fixnum(h1); /* Displace adjustment */ s = elt(s, 2); for (i=0; i= hl) return aerror1("putv-char", n); #ifdef Kanji if (iswchar((int)vx) { if (n1 == hl-1) return aerror1("putv-char", n); celt(v, n1) = (char)(vx >> 8); celt(v, n1+1) = (char)vx; } else celt(v, n1) = (char)vx; #else celt(v, n1) = (char)vx; #endif return onevalue(x); } Lisp_Object Lbpsupbv(Lisp_Object nil, Lisp_Object v) { Header h; int32 n; CSL_IGNORE(nil); if (!(is_bps(v))) return aerror1("bps-upbv", v); h = *(Header *)((char *)data_of_bps(v) - CELL); n = length_of_header(h) - CELL; return onevalue(fixnum_of_int(n-1)); } Lisp_Object MS_CDECL Lbpsputv(Lisp_Object nil, int nargs, ...) { Header h; va_list a; int32 n1, hl; Lisp_Object v, n, x; argcheck(nargs, 3, "bpsputv"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); x = va_arg(a, Lisp_Object); va_end(a); CSL_IGNORE(nil); if (!is_bps(v)) return aerror1("bpsputv", v); else if (!is_fixnum(n)) return aerror1("bps-putv", n); else if (!is_fixnum(x)) return aerror1("bps-putv contents", x); h = *(Header *)((char *)data_of_bps(v) - CELL); hl = length_of_header(h) - CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("bps-putv", n); *((char *)data_of_bps(v) + n1) = (char)int_of_fixnum(x); return onevalue(x); } /* * To make this function Standard Lisp Friendly it will return as its * value a SYMBOL. This is because unadorned character objects are not * really part of Standard Lisp. For cases where you want to character * code I have introduced a function scharn which is almost exactly the * same except that it returns an integer character code not a symbol. */ Lisp_Object Lsgetv(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; int w; int32 n1, hl; CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_STRING) return aerror1("schar", v); else if (!is_fixnum(n)) return aerror1("schar", n); hl = length_of_header(h) - CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("schar", n); w = celt(v, n1); #ifdef Kanji if (n1 < hl-1 && is2byte(w)) w = (w << 8) + celt(v, n+1); #endif #ifdef COMMON return onevalue(pack_char(0, 0, w)); /* NB 16-bit chars OK here */ #else #ifdef Kanji if (w & 0xff00) { celt(boffo, 0) = w >> 8; celt(boffo, 1) = w; /* * If it is an extended character I will look up a symbol for it each time. * this will make processing extended characters distinctly more expensive * than working with the basic ASCII ones, but I hope it will still be * acceptable. */ n = iintern(boffo, 2, lisp_package, 0); errexit(); return onevalue(n); } #endif /* * For 8-bit characters I keep a table of ready-interned Lisp symbols. */ n = elt(charvec, w & 0xff); if (n == nil) { celt(boffo, 0) = (char)w; n = iintern(boffo, 1, lisp_package, 0); errexit(); elt(charvec, w & 0xff) = n; } return onevalue(n); #endif } Lisp_Object Lsgetvn(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; int w; intxx n1, hl; CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_STRING) return aerror1("scharn", v); else if (!is_fixnum(n)) return aerror1("scharn", n); hl = length_of_header(h) - CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("scharn", n); w = celt(v, n1); #ifdef Kanji if (n1 < hl-1 && is2byte(w)) w = (w << 8) + celt(v, n+1); #endif return onevalue(fixnum_of_int(w)); } Lisp_Object Lbytegetv(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; int w; intxx n1, hl; CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_STRING) return aerror1("byte-getv", v); else if (!is_fixnum(n)) return aerror1("byte-getv", n); hl = length_of_header(h) - CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("byte-getv", n); w = ucelt(v, n1); return onevalue(fixnum_of_int(w)); } Lisp_Object Lbpsgetv(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; intxx n1, hl; CSL_IGNORE(nil); if (!is_bps(v)) return aerror1("bps-getv", v); else if (!is_fixnum(n)) return aerror1("bps-getv", n); h = *(Header *)((char *)data_of_bps(v) - CELL); hl = length_of_header(h) - CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("bps-getv", n); n1 = *((char *)data_of_bps(v) + n1); return onevalue(fixnum_of_int(n1 & 0xff)); } /* * native-putv and native-getv have an optional trailing argument that * should have the value 1, 2 or 4 to indicate the number of bytes to be * transferred. */ Lisp_Object MS_CDECL Lnativeputv(Lisp_Object nil, int nargs, ...) { va_list a; int32 o, v32, width; intxx p; Lisp_Object v, n, x, w; if (nargs != 4) { argcheck(nargs, 3, "native-putv"); } va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); x = va_arg(a, Lisp_Object); if (nargs == 4) w = va_arg(a, Lisp_Object); else w = fixnum_of_int(1); va_end(a); CSL_IGNORE(nil); if (!consp(v) || !is_fixnum(qcar(v)) || !is_fixnum(qcdr(v)) || (p = int_of_fixnum(qcar(v))) < 0 || p > native_pages_count) return aerror1("native-putv", v); else if (!is_fixnum(n)) return aerror1("native-putv", n); else if (!is_fixnum(x) && (!is_numbers(x) || !is_bignum(x))) return aerror1("native-putv contents", x); else if (!is_fixnum(w)) return aerror1("native-putv width", w); width = int_of_fixnum(w); o = int_of_fixnum(qcdr(v)) + int_of_fixnum(n); if (o < 0 || o >= CSL_PAGE_SIZE) return aerror1("native-putv", n); p = (intxx)native_pages[p]; p = doubleword_align_up(p); v32 = thirty_two_bits(x); switch (width) { default: return aerror1("native-putv width", w); case 1: *((char *)p + o) = (char)int_of_fixnum(x); break; #ifndef ADDRESS_64 case 2: /* * NOTE that I access the memory here as an array of 16-bit or 32-bit * values and I do not do anything to adjust for the order of bytes in * the word. Thus the effect of mixtures of 1, 2 and 4 byte operations on * native code space will be system dependent. But my intent at present is * that native code is always to be generated on ths machine on which it * will run and that it will never be touched on other machines so this * lack of portability is not really an issue! */ /* * This seems to be one of a very small number of places where I use int16. * In the case of a machine with try 64-bit addresses I will disble it. */ *(int16 *)((char *)p + o) = (int16)int_of_fixnum(x); break; #endif case 4: *(int32 *)((char *)p + o) = (int32)int_of_fixnum(x); break; } native_pages_changed = 1; return onevalue(x); } Lisp_Object Lnativegetv(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { int32 o; intxx p; CSL_IGNORE(nil); if (!consp(v) || !is_fixnum(qcar(v)) || !is_fixnum(qcdr(v)) || (p = int_of_fixnum(qcar(v))) < 0 || p > native_pages_count) return aerror1("native-getv", v); else if (!is_fixnum(n)) return aerror1("native-getv", n); o = int_of_fixnum(qcdr(v)) + int_of_fixnum(n); if (o < 0 || o >= CSL_PAGE_SIZE) return aerror1("native-getv", o); p = (intxx)native_pages[p]; p = doubleword_align_up(p); o = *((char *)p + o); return onevalue(fixnum_of_int(o & 0xff)); } Lisp_Object MS_CDECL Lnativegetvn(Lisp_Object nil, int nargs, ...) { Lisp_Object v, n, w; int32 o; intxx p; va_list a; argcheck(nargs, 3, "native-getv"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); w = va_arg(a, Lisp_Object); va_end(a); CSL_IGNORE(nil); if (!consp(v) || !is_fixnum(qcar(v)) || !is_fixnum(qcdr(v)) || (p = int_of_fixnum(qcar(v))) < 0 || p > native_pages_count) return aerror1("native-getv", v); else if (!is_fixnum(n)) return aerror1("native-getv", n); else if (!is_fixnum(w)) return aerror1("native-getv width", w); o = int_of_fixnum(qcdr(v)) + int_of_fixnum(n); if (o < 0 || o >= CSL_PAGE_SIZE) return aerror1("native-getv", o); p = (intxx)native_pages[p]; p = doubleword_align_up(p); switch (int_of_fixnum(w)) { default: return aerror1("native-getv width", w); case 1: o = *((char *)p + o); return onevalue(fixnum_of_int(o & 0xff)); #ifndef ADDRESS_64 case 2: o = *(int16 *)((char *)p + o); return onevalue(fixnum_of_int(o & 0xffff)); #endif case 4: o = *(int32 *)((char *)p + o); p = o & fix_mask; if (p==0 || p==fix_mask) return onevalue(fixnum_of_int(o & 0xff)); else if ((o & 0x80000000) == 0) { w = make_one_word_bignum(o); errexit(); return onevalue(w); } else { w = make_two_word_bignum(1, o & 0x7fffffff); errexit(); return onevalue(w); } } } Lisp_Object MS_CDECL Lnative_type(Lisp_Object nil, int nargs, ...) { CSL_IGNORE(nil); CSL_IGNORE(nargs); return onevalue(fixnum_of_int(NATIVE_CODE_TAG)); } /* * (native-address fn nargs) fetches the value from the relevent function cell * of the function and returns it represented as an integer. This gives * the current real absolute address of the code involved and is intended * to be useful while testing a native-mode compiler. */ Lisp_Object Lnative_address(Lisp_Object nil, Lisp_Object fn, Lisp_Object nargs) { intxx n, n1; CSL_IGNORE(nil); if (!symbolp(fn)) return aerror1("native-address", fn); if (!is_fixnum(nargs)) return aerror1("native-address", nargs); n = int_of_fixnum(nargs); switch (n) { case 1: n = ifn1(fn); break; case 2: n = ifn2(fn); break; default:n = ifnn(fn); break; } n1 = n & fix_mask; if (n1 == 0 || n1 == fix_mask) return onevalue(fixnum_of_int(n)); fn = make_one_word_bignum(n); errexit(); return onevalue(fn); } /* * (native-address n) with one integer argument will return an integer that * is the current memory address of a CSL/CCL internal variable identified * by that integer. The association between integers and variables is as * per the file "externs.h" and the switch statement here. The case 0 gives * the address of NIL, while 1 gives the address of "stack". * An invalid or unrecognised integer leads to a result * of zero. This is intended solely for the use of a native-code compiler. * It may not then be necessary to provide access to ALL of these variables, * but at least to start with it seems easiest to be comprehensive. * Negative integers use values in the following table, which are functions * in CSL that might usefully be called directly. If the one argument is a * cons then it is expected to be a native code handle and the associated * real address is returned. */ void *useful_functions[] = { (void *)cons, /* -1, 0 */ (void *)ncons, /* -2, 1 */ (void *)list2, /* -3, 2 */ (void *)list2star, /* -4, 3 */ (void *)acons, /* -5, 4 */ (void *)list3, /* -6, 5 */ (void *)plus2, /* -7, 6 */ (void *)difference2, /* -8, 7 */ (void *)add1, /* -9, 8 */ (void *)sub1, /* -10, 9 */ (void *)get, /* -11, 10 */ (void *)lognot, /* -12, 11 */ (void *)ash, /* -13, 12 */ (void *)quot2, /* -14, 13 */ (void *)Cremainder, /* -15, 14 */ (void *)times2, /* -16, 15 */ (void *)negate, /* -17, 16 */ (void *)rational, /* -18, 17 */ (void *)lessp2, /* -19, 18 */ (void *)lesseq2, /* -20, 19 */ (void *)greaterp2, /* -21, 20 */ (void *)geq2, /* -22, 21 */ (void *)zerop, /* -23, 22 */ (void *)reclaim, /* -24, 23 */ (void *)error, /* -25, 24 */ (void *)equal_fn, /* -26, 25 */ (void *)cl_equal_fn, /* -27, 26 */ (void *)aerror, /* -28, 27 */ (void *)integerp, /* -29, 28 */ (void *)apply /* -30, 29 */ }; char *address_of_var(int n) { char *p = NULL; Lisp_Object nil = C_nil; if (n == 0) p = (char *)nil; else if (n == 1) p = (char *)&stack; else #ifdef NILSEG_EXTERNS switch (n) { default: p = 0; break; case 12: p = (char *)&byteflip; break; case 13: p = (char *)&codefringe; break; case 14: p = (char *)&codelimit; break; #ifdef COMMON case 16: p = (char *)&stacklimit; break; #else case 15: p = (char *)&stacklimit; break; #endif case 18: p = (char *)&fringe; break; case 19: p = (char *)&heaplimit; break; case 20: p = (char *)&vheaplimit; break; case 21: p = (char *)&vfringe; break; case 22: p = (char *)&miscflags; break; case 24: p = (char *)&nwork; break; case 25: p = (char *)&exit_reason; break; case 26: p = (char *)&exit_count; break; case 27: p = (char *)&gensym_ser; break; case 28: p = (char *)&print_precision; break; case 29: p = (char *)¤t_modulus; break; case 30: p = (char *)&fastget_size; break; case 31: p = (char *)&package_bits; break; case 52: p = (char *)¤t_package; break; case 53: p = (char *)&B_reg; break; case 54: p = (char *)&codevec; break; case 55: p = (char *)&litvec; break; case 56: p = (char *)&exit_tag; break; case 57: p = (char *)&exit_value; break; case 58: p = (char *)&catch_tags; break; case 59: p = (char *)&lisp_package; break; case 60: p = (char *)&boffo; break; case 61: p = (char *)&charvec; break; case 62: p = (char *)&sys_hash_table; break; case 63: p = (char *)&help_index; break; case 64: p = (char *)&gensym_base; break; case 65: p = (char *)&err_table; break; case 66: p = (char *)&supervisor; break; case 67: p = (char *)&startfn; break; case 68: p = (char *)&faslvec; break; case 69: p = (char *)&tracedfn; break; case 70: p = (char *)&prompt_thing; break; case 71: p = (char *)&faslgensyms; break; case 72: p = (char *)&cl_symbols; break; case 73: p = (char *)&active_stream; break; case 80: p = (char *)&append_symbol; break; case 81: p = (char *)&applyhook; break; case 82: p = (char *)&cfunarg; break; case 83: p = (char *)&comma_at_symbol; break; case 84: p = (char *)&comma_symbol; break; case 85: p = (char *)&compiler_symbol; break; case 86: p = (char *)&comp_symbol; break; case 87: p = (char *)&cons_symbol; break; case 88: p = (char *)&echo_symbol; break; case 89: p = (char *)&emsg_star; break; case 90: p = (char *)&evalhook; break; case 91: p = (char *)&eval_symbol; break; case 92: p = (char *)&expr_symbol; break; case 93: p = (char *)&features_symbol; break; case 94: p = (char *)&fexpr_symbol; break; case 95: p = (char *)&funarg; break; case 96: p = (char *)&function_symbol; break; case 97: p = (char *)λ break; case 98: p = (char *)&lisp_true; break; case 99: p = (char *)&lower_symbol; break; case 100: p = (char *)¯oexpand_hook; break; case 101: p = (char *)¯o_symbol; break; case 102: p = (char *)&opt_key; break; case 103: p = (char *)&prinl_symbol; break; case 104: p = (char *)&progn_symbol; break; case 105: p = (char *)"e_symbol; break; case 106: p = (char *)&raise_symbol; break; case 107: p = (char *)&redef_msg; break; case 108: p = (char *)&rest_key; break; case 109: p = (char *)&savedef; break; case 110: p = (char *)&string_char_sym; break; case 111: p = (char *)&unset_var; break; case 112: p = (char *)&work_symbol; break; case 113: p = (char *)&lex_words; break; case 114: p = (char *)&get_counts; break; case 115: p = (char *)&fastget_names; break; case 116: p = (char *)&input_libraries; break; case 117: p = (char *)&output_library; break; case 118: p = (char *)¤t_file; break; case 119: p = (char *)&break_function; break; case 120: p = (char *)&lisp_work_stream; break; case 121: p = (char *)&lisp_standard_output; break; case 122: p = (char *)&lisp_standard_input; break; case 123: p = (char *)&lisp_debug_io; break; case 124: p = (char *)&lisp_error_output; break; case 125: p = (char *)&lisp_query_io; break; case 126: p = (char *)&lisp_terminal_io; break; case 127: p = (char *)&lisp_trace_output; break; case 128: p = (char *)&standard_output; break; case 129: p = (char *)&standard_input; break; case 130: p = (char *)&debug_io; break; case 131: p = (char *)&error_output; break; case 132: p = (char *)&query_io; break; case 133: p = (char *)&terminal_io; break; case 134: p = (char *)&trace_output; break; case 135: p = (char *)&fasl_stream; break; case 136: p = (char *)&native_code; break; #ifdef COMMON case 140: p = (char *)&keyword_package; break; case 141: p = (char *)&all_packages; break; case 142: p = (char *)&package_symbol; break; case 143: p = (char *)&internal_symbol; break; case 144: p = (char *)&external_symbol; break; case 145: p = (char *)&inherited_symbol; break; case 146: p = (char *)&key_key; break; case 147: p = (char *)&allow_other_keys; break; case 148: p = (char *)&aux_key; break; case 149: p = (char *)&format_symbol; break; case 150: p = (char *)&expand_def_symbol; break; case 151: p = (char *)&allow_key_key; break; case 152: p = (char *)&declare_symbol; break; case 153: p = (char *)&special_symbol; break; #endif } #else /* NILSEG_EXTERNS */ if (n >= 160) switch (n) { default: p = 0; break; case 160: p = (char *)&user_base_0; break; case 161: p = (char *)&user_base_1; break; case 162: p = (char *)&user_base_2; break; case 163: p = (char *)&user_base_3; break; case 164: p = (char *)&user_base_4; break; case 165: p = (char *)&user_base_5; break; case 166: p = (char *)&user_base_6; break; case 167: p = (char *)&user_base_7; break; case 168: p = (char *)&user_base_8; break; case 169: p = (char *)&user_base_9; break; } else p = (char *)&(((int32 *)nil)[n]); #endif /* NILSEG_EXTERNS */ return p; } Lisp_Object Lnative_address1(Lisp_Object nil, Lisp_Object x) { int32 n, n1; intxx p; if (consp(x)) { if (!is_fixnum(qcar(x)) || !is_fixnum(qcdr(x)) || (p = int_of_fixnum(qcar(x))) < 0 || p > native_pages_count) return aerror1("native-address", x); n = int_of_fixnum(qcdr(x)); if (n < 0 || n >= CSL_PAGE_SIZE) return aerror1("native-address", x); p = (intxx)native_pages[p]; p = doubleword_align_up(p); p = (intxx)((char *)p + n); } else { if (!is_fixnum(x)) return aerror1("native-address", x); n = int_of_fixnum(x); if (n < 0) { n = (-n) - 1; if (n >= sizeof(useful_functions)/sizeof(void *)) return aerror1("native-address", x); else p = (intxx)useful_functions[n]; } else p = (intxx)address_of_var(n); } n1 = p & fix_mask; if (n1 == 0 || n1 == fix_mask) return onevalue(fixnum_of_int(p)); x = make_one_word_bignum(p); errexit(); return onevalue(x); } /* * Access functions for specialised (binary-contents) vectors. NOT integrated * in with the greater generality of vector structures. */ Lisp_Object MS_CDECL Lputv8(Lisp_Object nil, int nargs, ...) { Header h; va_list a; intxx n1, hl; Lisp_Object v, n, x; argcheck(nargs, 3, "putv8"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); x = va_arg(a, Lisp_Object); va_end(a); CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_VEC8) return aerror1("putv8", v); else if (!is_fixnum(n)) return aerror1("putv8 offset not fixnum", n); hl = length_of_header(h) - CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("putv8 index range", n); scelt(v, n1) = (char)int_of_fixnum(x); return onevalue(x); } Lisp_Object Lgetv8(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; intxx n1, hl; CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_VEC8) return aerror1("getv8", v); else if (!is_fixnum(n)) return aerror1("getv8 offset not fixnum", n); hl = length_of_header(h) - CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("getv8 index range", n); else return onevalue(fixnum_of_int(scelt(v, n1))); } Lisp_Object MS_CDECL Lputv16(Lisp_Object nil, int nargs, ...) { Header h; va_list a; intxx n1, hl; Lisp_Object v, n, x; argcheck(nargs, 3, "putv16"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); x = va_arg(a, Lisp_Object); va_end(a); CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_VEC16) return aerror1("putv16", v); else if (!is_fixnum(n)) return aerror1("putv16 offset not fixnum", n); hl = (length_of_header(h) - CELL) >> 1; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("putv16 index range", n); sethelt(v, n1, int_of_fixnum(x)); return onevalue(x); } Lisp_Object Lgetv16(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; intxx n1, hl; CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_VEC16) return aerror1("getv16", v); else if (!is_fixnum(n)) return aerror1("getv16 offset not fixnum", n); hl = (length_of_header(h) - CELL) >> 1; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("getv16 index range", n); n1 = helt(v, n1); return onevalue(fixnum_of_int(n1)); } Lisp_Object MS_CDECL Lputv32(Lisp_Object nil, int nargs, ...) { Header h; va_list a; intxx n1, hl; Lisp_Object v, n, x; argcheck(nargs, 3, "putv32"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); x = va_arg(a, Lisp_Object); va_end(a); CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_VEC32) return aerror1("putv32", v); else if (!is_fixnum(n)) return aerror1("putv32 offset not fixnum", n); hl = (length_of_header(h) - CELL)/4; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("putv32 index range", n); ielt32(v, n1) = thirty_two_bits(x); return onevalue(x); } Lisp_Object Lgetv32(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; intxx n1, hl; CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_VEC32) return aerror1("getv32", v); else if (!is_fixnum(n)) return aerror1("getv32 offset not fixnum", n); hl = (length_of_header(h) - CELL)/4; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("getv32 index range", n); n1 = ielt32(v, n1); hl = n1 & fix_mask; if (hl == 0 || hl == fix_mask) return fixnum_of_int(n1); n = make_one_word_bignum(n1); errexit(); return onevalue(n); } Lisp_Object MS_CDECL Lfputv32(Lisp_Object nil, int nargs, ...) { Header h; va_list a; intxx n1, hl; Lisp_Object v, n, x; double d; argcheck(nargs, 3, "fputv32"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); x = va_arg(a, Lisp_Object); d = float_of_number(x); va_end(a); CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_FLOAT32) return aerror1("fputv32", v); else if (!is_fixnum(n)) return aerror1("fputv32 offset not fixnum", n); hl = (length_of_header(h) - CELL)/4; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("fputv32 index range", n); felt(v, n1) = (float)d; return onevalue(x); } Lisp_Object Lfgetv32(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; intxx n1, hl; CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_FLOAT32) return aerror1("fgetv32", v); else if (!is_fixnum(n)) return aerror1("fgetv32 offset not fixnum", n); hl = (length_of_header(h) - CELL)/4; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("fgetv32 index range", n); #ifdef COMMON v = make_boxfloat((double)felt(v, n1), TYPE_SINGLE_FLOAT); #else v = make_boxfloat((double)felt(v, n1), TYPE_DOUBLE_FLOAT); #endif errexit(); return onevalue(v); } Lisp_Object MS_CDECL Lfputv64(Lisp_Object nil, int nargs, ...) { Header h; va_list a; intxx n1, hl; Lisp_Object v, n, x; double d; argcheck(nargs, 3, "fputv64"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); x = va_arg(a, Lisp_Object); d = float_of_number(x); va_end(a); CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_FLOAT64) return aerror1("fputv64", v); else if (!is_fixnum(n)) return aerror1("fputv64 offset not fixnum", n); /* * NB it is not a misprint - the first double ALWAYS starts 8 bytes in... */ hl = (length_of_header(h) - 8)/8; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("fputv64 index range", n); delt(v, n1) = d; return onevalue(x); } Lisp_Object Lfgetv64(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; intxx n1, hl; CSL_IGNORE(nil); if (!is_vector(v) || type_of_header(h = vechdr(v)) != TYPE_FLOAT64) return aerror1("fgetv64", v); else if (!is_fixnum(n)) return aerror1("fgetv64 offset not fixnum", n); hl = (length_of_header(h) - 8)/8; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("fgetv64 index range", n); v = make_boxfloat(delt(v, n1), TYPE_DOUBLE_FLOAT); errexit(); return onevalue(v); } #ifdef COMMON /* * (defun putvec (v n x) * (cond * ((simple-string-p v) (putv-char v n x)) * ((simple-bit-vector-p v) (putv-bit v n x)) * (t (putv v n x)))) */ static Lisp_Object MS_CDECL Lputvec(Lisp_Object nil, int nargs, ...) { Header h; va_list a; int32 vx; intxx n1, hl; Lisp_Object v, n, x; CSL_IGNORE(nil); argcheck(nargs, 3, "putvec"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); x = va_arg(a, Lisp_Object); va_end(a); /* * Oh joy - here I have to dispatch based on what sort of vector I have. */ if (!is_vector(v)) return aerror1("putvec", v); else if (!is_fixnum(n)) return aerror1("putvec", n); h = vechdr(v); if (type_of_header(h) == TYPE_STRING) { if (is_fixnum(x)) vx = int_of_fixnum(x); else if (is_char(x)) vx = code_of_char(x); else return aerror1("putvec on string, contents", x); hl = length_of_header(h) - CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("putvec", n); celt(v, n1) = (int)vx; return onevalue(x); } if (header_of_bitvector(h)) { int b; if (!is_fixnum(x)) return aerror1("putvec on bitvec, contents", x); x = int_of_fixnum(x) & 1; h = length_of_header(h) - CELL; n1 = int_of_fixnum(n); b = 1 << (n1 & 7); /* Bit selector */ n1 = n1 >> 3; /* Byte selector */ /* * I am just a bit shoddy here - I only complain if an attempt is made to * access beyond the last active byte of a bitvector - I do not * do bound checking accurate to bit positions. */ if (n1 < 0 || n1 >= (int32)h) return aerror1("putv-bit", n); if (x == 0) celt(v, n1) &= ~b; else celt(v, n1) |= b; return onevalue(fixnum_of_int(x)); } if (vector_holds_binary(h)) return aerror1("putvec", v); hl = (length_of_header(h) - CELL)/CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("putvec index range", n); elt(v, n1) = x; return onevalue(x); } /* * (defun aref (v n1 &rest r) * (if (null r) * (cond * ((simple-vector-p v) (getv v n1)) * ((simple-string-p v) (schar v n1)) * ((simple-bit-vector-p v) (getv-bit v n1)) * ((structp v) (getv v n1)) * (t (general-aref v n1 r))) * (general-aref v n1 r))) * * (defun general-aref (v n1 r) * (when (not (arrayp v)) (error "aref ~s ~s" v (cons n1 r))) * (do ((dd (cdr (getv v 1)) (cdr dd))) * ((null r)) * (setq n1 (+ (* n1 (car dd)) (pop r)))) ***** plus special magic to deal with segmented representations... * (aref (getv v 2) (+ (getv v 3) n1))) */ Lisp_Object MS_CDECL Laref(Lisp_Object nil, int nargs, ...) { Header h; Lisp_Object v, n, w; intxx hl, n1; int32 b; va_list a; if (nargs == 0) return aerror("aref"); va_start(a, nargs); v = va_arg(a, Lisp_Object); if (!is_vector(v)) { va_end(a); return aerror1("aref", v); } h = vechdr(v); if (nargs == 1) n = 0; /* Funny case (aref v) legal if no dimensions! */ else { n = va_arg(a, Lisp_Object); /* First subscript */ if (!is_fixnum(n)) { va_end(a); return aerror1("aref", n); } if (nargs == 2) { if (type_of_header(h) == TYPE_SIMPLE_VEC || type_of_header(h) == TYPE_STRUCTURE) { va_end(a); hl = (length_of_header(h) - CELL)/CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("aref index range", n); else return onevalue(elt(v, n1)); } else if (type_of_header(h) == TYPE_STRING) { va_end(a); hl = length_of_header(h) - CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("aref index range", n); return onevalue(pack_char(0, 0, celt(v, n1))); } else if (header_of_bitvector(h)) { va_end(a); h = length_of_header(h) - CELL; n1 = int_of_fixnum(n); b = 1 << (n1 & 7); /* Bit selector */ n1 = n1 >> 3; /* Byte selector */ if (n1 < 0 || n1 >= (int32)h) return aerror1("aref index range", n); if ((celt(v, n1) & b) == 0) return onevalue(fixnum_of_int(0)); else return onevalue(fixnum_of_int(1)); } } } if (type_of_header(h) != TYPE_ARRAY) { va_end(a); return aerror1("aref", v); } /* * Here I had better have a general array, and I will need to calculate the * real index location within it. */ w = elt(v, 1); /* The list of dimensions */ if (w == nil && nargs == 1) { va_end(a); return onevalue(elt(v, 2)); } n1 = int_of_fixnum(n); w = qcdr(w); while (nargs > 2 && w != nil) { n = va_arg(a, Lisp_Object); if (!is_fixnum(n)) { va_end(a); return aerror1("aref", n); } n1 = n1*int_of_fixnum(qcar(w)) + int_of_fixnum(n); nargs--; w = qcdr(w); } va_end(a); if (nargs > 2 || w != nil) return aerror("aref, wrong number of subscripts"); n1 += int_of_fixnum(elt(v, 3)); /* displaced-index-offset */ v = elt(v, 2); /* * Now I have got the vector that this array is displaced to or * represented by. If it is in fact a structure (not a simple vector) * then it is a row of 8K sub-vectors, and at element zero it has the * nominal size of the big vector (as a Lisp integer) */ h = vechdr(v); if (type_of_header(h) == TYPE_SIMPLE_VEC) { hl = (length_of_header(h) - CELL)/CELL; if (n1 < 0 || n1 >= hl) return aerror("aref index range"); else return onevalue(elt(v, n1)); } else if (type_of_header(h) == TYPE_STRUCTURE) { int32 n2; hl = int_of_fixnum(elt(v, 0)); if (n1 < 0 || n1 >= hl) return aerror("aref index range"); n2 = n1 % 8192; n1 = n1 / 8192; return onevalue(elt(elt(v, n1+1), n2)); } else if (type_of_header(h) == TYPE_STRING) { hl = length_of_header(h) - CELL; if (n1 < 0 || n1 >= hl) return aerror("aref index range"); return onevalue(pack_char(0, 0, celt(v, n1))); } else if (header_of_bitvector(h)) { h = length_of_header(h) - CELL; b = 1 << (n1 & 7); /* Bit selector */ n1 = n1 >> 3; /* Byte selector */ if (n1 < 0 || n1 >= (int32)h) return aerror("aref index range"); if ((celt(v, n1) & b) == 0) return onevalue(fixnum_of_int(0)); else return onevalue(fixnum_of_int(1)); } return aerror("aref unknown type for vector representation"); } static Lisp_Object Laref1(Lisp_Object nil, Lisp_Object a) { return Laref(nil, 1, a); } Lisp_Object Laref2(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { return Laref(nil, 2, a, b); } Lisp_Object Lelt(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; Lisp_Object w; int32 hl, n1, b; if (!is_fixnum(n) || ((int32)n) < 0) return aerror1("elt", n); n1 = int_of_fixnum(n); if (!is_vector(v)) { w = v; while (consp(w) && n1>0) { n1--; w = qcdr(w); } if (!consp(w)) return aerror1("elt", v); return onevalue(qcar(w)); } h = vechdr(v); if (type_of_header(h) == TYPE_SIMPLE_VEC || type_of_header(h) == TYPE_STRUCTURE) { hl = (length_of_header(h) - CELL)/CELL; if (n1 >= hl) return aerror1("elt index range", n); else return onevalue(elt(v, n1)); } else if (type_of_header(h) == TYPE_STRING) { hl = length_of_header(h) - CELL; if (n1 >= hl) return aerror1("elt index range", n); return onevalue(pack_char(0, 0, celt(v, n1))); } else if (header_of_bitvector(h)) { h = length_of_header(h) - CELL; b = 1 << (n1 & 7); /* Bit selector */ n1 = n1 >> 3; /* Byte selector */ if (n1 < 0 || n1 >= (int32)h) return aerror1("elt index range", n); if ((celt(v, n1) & b) == 0) return onevalue(fixnum_of_int(0)); else return onevalue(fixnum_of_int(1)); } if (type_of_header(h) != TYPE_ARRAY) return aerror1("elt", v); w = elt(v, 1); /* The list of dimensions - must be 1 dim here */ w = qcdr(w); if (w != nil) return aerror1("elt", v); n1 += int_of_fixnum(elt(v, 3)); /* displaced-index-offset */ v = elt(v, 2); h = vechdr(v); if (type_of_header(h) == TYPE_SIMPLE_VEC) { hl = (length_of_header(h) - CELL)/CELL; if (n1 >= hl) return aerror("elt index range"); else return onevalue(elt(v, n1)); } else if (type_of_header(h) == TYPE_STRUCTURE) { int32 n2; hl = int_of_fixnum(elt(v, 0)); if (n1 >= hl) return aerror("elt index range"); n2 = n1 % 8192; n1 = n1 / 8192; return onevalue(elt(elt(v, n1+1), n2)); } else if (type_of_header(h) == TYPE_STRING) { hl = length_of_header(h) - CELL; if (n1 >= hl) return aerror("elt index range"); return onevalue(pack_char(0, 0, celt(v, n1))); } else if (header_of_bitvector(h)) { h = length_of_header(h) - CELL; b = 1 << (n1 & 7); /* Bit selector */ n1 = n1 >> 3; /* Byte selector */ if (n1 >= (int32)h) return aerror("elt index range"); if ((celt(v, n1) & b) == 0) return onevalue(fixnum_of_int(0)); else return onevalue(fixnum_of_int(1)); } return aerror("elt unknown type for vector representation"); } /* * (defun aset (v n1 x &rest r) * (if (null r) * (cond * ((simple-vector-p v) (putv v n1 x)) * ((simple-string-p v) (putv-char v n1 x)) * ((simple-bit-vector-p v) (putv-bit v n1 x)) * ((structp v) (putv v n1 x)) * (t (general-aset v n1 x r))) * (general-aset v n1 x r))) * * (defun general-aset (v n1 x r) * (when (not (arrayp v)) (error "aref ~s ~s" v * (reverse (cdr (reverse (cons n1 (cons x r))))))) * (setq r (cons x r)) * (do ((dd (cdr (getv v 1)) (cdr dd))) * ((null (cdr r))) * (setq n1 (+ (* n1 (car dd)) (pop r)))) ***** plus special magic to deal with segmented representations... * (aset (getv v 2) (+ (getv v 3) n1) (car r))) */ /* * Note that the code for ASET is really a mildly modified copy of that * for AREF. */ Lisp_Object MS_CDECL Laset(Lisp_Object nil, int nargs, ...) { Header h; Lisp_Object v, n, w, x; int32 hl, n1, b; va_list a; if (nargs < 2) return aerror("aset"); va_start(a, nargs); v = va_arg(a, Lisp_Object); if (!is_vector(v)) { va_end(a); return aerror1("aset", v); } h = vechdr(v); if (nargs == 2) n = 0; /* Funny case (aset v w) legal if no dimensions! */ else { n = va_arg(a, Lisp_Object); /* First subscript */ if (!is_fixnum(n)) { va_end(a); return aerror1("aset", n); } if (nargs == 3) { if (type_of_header(h) == TYPE_SIMPLE_VEC || type_of_header(h) == TYPE_STRUCTURE) { x = va_arg(a, Lisp_Object); va_end(a); hl = (length_of_header(h) - CELL)/CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("aset index range", n); elt(v, n1) = x; return onevalue(x); } else if (type_of_header(h) == TYPE_STRING) { x = va_arg(a, Lisp_Object); va_end(a); hl = length_of_header(h) - CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("aset index range", n); if (is_fixnum(x)) b = int_of_fixnum(x); else if (is_char(x)) b = code_of_char(x); else return aerror1("aset needs char", x); celt(v, n1) = b; return onevalue(x); } else if (header_of_bitvector(h)) { x = va_arg(a, Lisp_Object); va_end(a); h = length_of_header(h) - CELL; n1 = int_of_fixnum(n); b = 1 << (n1 & 7); /* Bit selector */ n1 = n1 >> 3; /* Byte selector */ if (n1 < 0 || n1 >= (int32)h) return aerror1("aset index range", n); if (!is_fixnum(x)) return aerror1("aset needs bit", x); if (int_of_fixnum(x) & 1) ucelt(v, n1) |= b; else ucelt(v, n1) &= ~b; return onevalue(x); } } } if (type_of_header(h) != TYPE_ARRAY) { va_end(a); return aerror1("aset", v); } /* * Here I had better have a general array, and I will need to calculate the * real index location within it. */ w = elt(v, 1); /* The list of dimensions */ if (w == nil && nargs == 2) { x = va_arg(a, Lisp_Object); va_end(a); elt(v, 2) = x; return onevalue(x); } n1 = int_of_fixnum(n); w = qcdr(w); while (nargs > 3 && w != nil) { n = va_arg(a, Lisp_Object); if (!is_fixnum(n)) { va_end(a); return aerror1("aset", n); } n1 = n1*int_of_fixnum(qcar(w)) + int_of_fixnum(n); nargs--; w = qcdr(w); } x = va_arg(a, Lisp_Object); va_end(a); if (nargs > 3 || w != nil) return aerror("aset, wrong number of subscripts"); n1 += int_of_fixnum(elt(v, 3)); /* displaced-index-offset */ v = elt(v, 2); h = vechdr(v); if (type_of_header(h) == TYPE_SIMPLE_VEC) { hl = (length_of_header(h) - CELL)/CELL; if (n1 < 0 || n1 >= hl) return aerror("aset index range"); elt(v, n1) = x; return onevalue(x); } if (type_of_header(h) == TYPE_STRUCTURE) { int32 n2; hl = int_of_fixnum(elt(v, 0)); if (n1 < 0 || n1 >= hl) return aerror("aset index range"); n2 = n1 % 8192; n1 = n1 / 8192; elt(elt(v, n1+1), n2) = x; return onevalue(x); } else if (type_of_header(h) == TYPE_STRING) { hl = length_of_header(h) - CELL; if (n1 < 0 || n1 >= hl) return aerror("aset index range"); if (is_fixnum(x)) b = int_of_fixnum(x); else if (is_char(x)) b = code_of_char(x); else return aerror1("aset needs char", x); celt(v, n1) = b; return onevalue(x); } else if (header_of_bitvector(h)) { h = length_of_header(h) - CELL; b = 1 << (n1 & 7); /* Bit selector */ n1 = n1 >> 3; /* Byte selector */ if (n1 < 0 || n1 >= (int32)h) return aerror("aset index range"); if (!is_fixnum(x)) return aerror1("aset needs bit", x); if (int_of_fixnum(x) & 1) ucelt(v, n1) |= b; else ucelt(v, n1) &= ~b; return onevalue(x); } return aerror("aset unknown type for vector representation"); } static Lisp_Object Laset1(Lisp_Object nil, Lisp_Object a) { return aerror("aset"); } static Lisp_Object Laset2(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { return Laset(nil, 2, a, b); } static Lisp_Object MS_CDECL Lsetelt(Lisp_Object nil, int nargs, ...) { Lisp_Object v, n, x; Header h; Lisp_Object w; int32 hl, n1, b; va_list a; argcheck(nargs, 3, "setelt"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); x = va_arg(a, Lisp_Object); va_end(a); if (!is_fixnum(n) || ((int32)n) < 0) return aerror1("setelt", n); n1 = int_of_fixnum(n); if (!is_vector(v)) { w = v; while (consp(w) && n1>0) { n1--; w = qcdr(w); } if (!consp(w)) return aerror1("setelt", v); qcar(w) = x; return onevalue(x); } h = vechdr(v); if (type_of_header(h) == TYPE_SIMPLE_VEC || type_of_header(h) == TYPE_STRUCTURE) { hl = (length_of_header(h) - CELL)/CELL; if (n1 >= hl) return aerror1("setelt index range", n); elt(v, n1) = x; return onevalue(x); } else if (type_of_header(h) == TYPE_STRING) { int vx; hl = length_of_header(h) - CELL; if (n1 >= hl) return aerror1("setelt index range", n); if (is_fixnum(x)) vx = int_of_fixnum(x); else if (is_char(x)) vx = code_of_char(x); else return aerror1("setelt contents", x); celt(v, n1) = vx; return onevalue(x); } else if (header_of_bitvector(h)) { if (!is_fixnum(x)) return aerror1("setelt contents", x); x = int_of_fixnum(x) & 1; h = length_of_header(h) - CELL; b = 1 << (n1 & 7); /* Bit selector */ n1 = n1 >> 3; /* Byte selector */ if (n1 >= (int32)h) return aerror1("setelt index range", n); if (x == 0) celt(v, n1) &= ~b; else celt(v, n1) |= b; return onevalue(fixnum_of_int(x)); } if (type_of_header(h) != TYPE_ARRAY) return aerror1("setelt", v); w = elt(v, 1); /* The list of dimensions - must be 1 dim here */ w = qcdr(w); if (w != nil) return aerror1("setelt", v); n1 += int_of_fixnum(elt(v, 3)); /* displaced-index-offset */ v = elt(v, 2); h = vechdr(v); if (type_of_header(h) == TYPE_SIMPLE_VEC) { hl = (length_of_header(h) - CELL)/CELL; if (n1 >= hl) return aerror("setelt index range"); elt(v, n1) = x; return onevalue(x); } else if (type_of_header(h) == TYPE_STRUCTURE) { int32 n2; hl = int_of_fixnum(elt(v, 0)); if (n1 >= hl) return aerror("setelt index range"); n2 = n1 % 8192; n1 = n1 / 8192; elt(elt(v, n1+1), n2) = x; return onevalue(x); } else if (type_of_header(h) == TYPE_STRING) { int vx; hl = length_of_header(h) - CELL; if (is_fixnum(x)) vx = int_of_fixnum(x); else if (is_char(x)) vx = code_of_char(x); else return aerror1("setelt contents", x); if (n1 >= hl) return aerror("setelt index range"); celt(v, n1) = vx; return onevalue(x); } else if (header_of_bitvector(h)) { if (!is_fixnum(x)) return aerror1("setelt contents", x); x = int_of_fixnum(x) & 1; h = length_of_header(h) - CELL; b = 1 << (n1 & 7); /* Bit selector */ n1 = n1 >> 3; /* Byte selector */ if (n1 >= (int32)h) return aerror("setelt index range"); if (x == 0) celt(v, n1) &= ~b; else celt(v, n1) |= b; return onevalue(fixnum_of_int(x)); } return aerror("setelt unknown type for vector representation"); } /* * (defun vectorp (x) * (or (simple-vector-p x) * (simple-string-p x) * (simple-bit-vector-p x) * (and (arrayp x) (length-one-p (svref x 1))))) */ Lisp_Object Lvectorp(Lisp_Object nil, Lisp_Object a) { Header h; int32 tt; if (!is_vector(a)) return onevalue(nil); h = vechdr(a); tt = type_of_header(h); if (tt == TYPE_SIMPLE_VEC || tt == TYPE_STRING || header_of_bitvector(h)) return onevalue(lisp_true); if (tt == TYPE_ARRAY) { a = elt(a, 1); /* List of dimensions */ if (consp(a) && !consp(qcdr(a))) return onevalue(lisp_true); } return onevalue(nil); } /* * (defun char (s n) * (cond * ((simple-string-p s) (schar s n)) * (t (aref s n)))) */ static Lisp_Object Lchar(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; if (!is_vector(v)) return aerror("char"); h = vechdr(v); if (type_of_header(h) == TYPE_STRING) { int32 hl, n1; if (!is_fixnum(n)) return aerror1("char", n); hl = length_of_header(h) - CELL; n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("schar", n); return onevalue(pack_char(0, 0, celt(v, n1))); } return Laref(nil, 2, v, n); } /* * (defun charset (s n c) * (cond * ((simple-string-p s) (putv-char s n c)) * (t (aset s n c)))) */ static Lisp_Object MS_CDECL Lcharset(Lisp_Object nil, int nargs, ...) { Lisp_Object v, n, c; Header h; va_list a; argcheck(nargs, 3, "charset"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); c = va_arg(a, Lisp_Object); va_end(a); if (!is_vector(v)) return aerror1("charset", v); h = vechdr(v); if (!is_fixnum(n)) return aerror1("charset", n); if (type_of_header(h) == TYPE_STRING) { int32 hl, n1, vx; if (!is_fixnum(n)) return aerror1("charset", n); hl = length_of_header(h) - CELL; if (is_fixnum(c)) vx = int_of_fixnum(c); else if (is_char(c)) vx = code_of_char(c); else return aerror1("charset contents", c); n1 = int_of_fixnum(n); if (n1 < 0 || n1 >= hl) return aerror1("charset", n); celt(v, n1) = (int)vx; return onevalue(c); } return Laset(nil, 3, v, n, c); } /* * (defun make-string (len &key (initial-element #\ )) * (let ((s (make-simple-string len))) * (dotimes (i len) (charset s i initial-element)) * s)) */ static Lisp_Object MS_CDECL Lmake_string(Lisp_Object nil, int nargs, ...) { va_list a; Lisp_Object w, n, key, init; int32 nn, z, blanks; argcheck(nargs, 3, "make-string"); va_start(a, nargs); n = va_arg(a, Lisp_Object); key = va_arg(a, Lisp_Object); init = va_arg(a, Lisp_Object); va_end(a); if (!is_fixnum(n) || (int32)n<0) return aerror1("make-string", n); if (!is_char(init) && !is_fixnum(init)) return aerror1("make-string", init); if (key != initial_element) return aerror1("make-string", key); nn = int_of_fixnum(n); w = getvector(TAG_VECTOR, TYPE_STRING, nn+CELL); errexit(); z = (int32)doubleword_align_up(nn+CELL); if (is_char(init)) blanks = code_of_char(init); else blanks = int_of_fixnum(init); blanks = (blanks << 8) | blanks; blanks = (blanks << 16) | blanks; while (z > CELL) { z -= 4; *(int32 *)((char *)w - TAG_VECTOR + z) = blanks; } nn = nn + CELL; while ((nn & 7) != 0) { *((char *)w - TAG_VECTOR + nn) = 0; nn++; } return onevalue(w); } static Lisp_Object Lmake_string1(Lisp_Object nil, Lisp_Object n) { Lisp_Object w; int32 nn, z, blanks; if (!is_fixnum(n) || (int32)n<0) return aerror1("make-string", n); nn = int_of_fixnum(n); w = getvector(TAG_VECTOR, TYPE_STRING, nn+CELL); errexit(); z = (int32)doubleword_align_up(nn+CELL); blanks = (' ' << 24) | (' ' << 16) | (' ' << 8) | ' '; while (z > CELL) { z -= 4; *(int32 *)((char *)w - TAG_VECTOR + z) = blanks; } nn = nn + CELL; while ((nn & 7) != 0) { *((char *)w - TAG_VECTOR + nn) = 0; nn++; } return onevalue(w); } static Lisp_Object Lmake_string2(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { return Lmake_string(nil, 2, a, b); } /* * (defun string (x) * (cond * ((stringp x) x) * ((symbolp x) (symbol-name x)) * ((string-char-p x) (make-string 1 :initial-element x)) * (t (error "String expected, but found ~S" x)))) */ static Lisp_Object Lstring(Lisp_Object nil, Lisp_Object a) { Header h; Lisp_Object w; if (!is_vector(a)) { char dd[4]; if (symbolp(a)) return onevalue(qpname(a)); if (!is_char(a)) return aerror1("string", a); dd[0] = 'x'; /* Done this way in case character arg has code 0 */ dd[1] = 0; w = make_string(dd); errexit(); celt(w, 0) = code_of_char(a); return onevalue(w); } h = vechdr(a); if (type_of_header(h) == TYPE_STRING) return onevalue(a); else if (type_of_header(h) != TYPE_ARRAY) return aerror1("string", a); /* * Beware abolition of 'string-char */ else if (elt(a, 0) != string_char_sym) return aerror1("string", a); w = elt(a, 1); if (!consp(w) || consp(qcdr(w))) return aerror1("string", a); else return onevalue(a); } /* * (defun list-to-vector (old) * (let* ((len (length old)) * (new (make-simple-vector len))) * (dotimes (i len new) (putv new i (car old)) (setq old (cdr old))))) */ static Lisp_Object Llist_to_vector(Lisp_Object nil, Lisp_Object a) { Lisp_Object v; int32 n = CELL; /* * The general LENGTH function deals with vectors as well as lists, and * returns a Lisp integer result. So here I just write out a simple in-line * version. */ for (v=a; consp(v); v = qcdr(v)) n += CELL; push(a); v = getvector(TAG_VECTOR, TYPE_SIMPLE_VEC, n); pop(a); errexit(); for(n=0; consp(a); a = qcdr(a), n++) elt(v, n) = qcar(a); #ifndef ADDRESS_64 if ((n & 1) == 0) elt(v, n) = nil; /* Padder word */ #endif return onevalue(v); } /* * (defun copy-vector (old) * ;; At present this only copies general vectors... * (let* ((len (vector-bound old)) * (new (make-simple-vector len))) * (dotimes (i len new) (putv new i (svref old i))))) */ static Lisp_Object Lcopy_vector(Lisp_Object nil, Lisp_Object a) { /* not done yet! */ return onevalue(nil); } /* * (defun vector (&rest args) * ;; Note that a vector made this way can have at most 50 elements... * (let* ((l (length args)) * (g (make-simple-vector l))) * (dotimes (i l g) * (putv g i (car args)) * (setq args (cdr args))))) */ static Lisp_Object MS_CDECL Lvector(Lisp_Object nil, int nargs, ...) { Lisp_Object r = nil, w; va_list a; va_start(a, nargs); push_args(a, nargs); r = getvector(TAG_VECTOR, TYPE_SIMPLE_VEC, CELL*nargs+CELL); errexitn(nargs); #ifndef ADDRESS_64 /* * The next line allows for the fact that vectors MUST pad to an even * number of words. */ if ((nargs & 1) == 0) elt(r, nargs) = nil; #endif while (nargs > 0) { pop(w); elt(r, --nargs) = w; } return onevalue(r); } static Lisp_Object Lvector1(Lisp_Object nil, Lisp_Object a) { return Lvector(nil, 1, a); } static Lisp_Object Lvector2(Lisp_Object nil, Lisp_Object a, Lisp_Object b) { return Lvector(nil, 2, a, b); } static Lisp_Object Lshrink_vector(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { int32 n1, n2; if (!is_vector(v)) return aerror1("shrink-vector", v); if (!is_fixnum(n)) return aerror1("shrink-vector", n); n1 = length_of_header(vechdr(v)); n2 = CELL*int_of_fixnum(n)+CELL; if (n2 >= n1) return onevalue(v); /* Not shrunk at all */ #ifndef ADDRESS_64 if (n1==n2+4 && (n2&4)==0) /* No space to free */ *(Lisp_Object *)((char *)v-TAG_VECTOR+n2) = nil; else #endif { int32 n2a = doubleword_align_up(n2); n1 = doubleword_align_up(n1); *(Lisp_Object *)((char *)v-TAG_VECTOR+n1) = TAG_ODDS+TYPE_STRING+((n1-n2a)<<10); } vechdr(v) = TAG_ODDS+type_of_header(vechdr(v))+(n2<<10); return onevalue(v); } static Lisp_Object Lmake_simple_bitvector(Lisp_Object nil, Lisp_Object n) { int32 bytes; Lisp_Object w; int32 n1; if (!is_fixnum(n) || (int32)n<0) return aerror1("make-simple-bitvector", n); n1 = int_of_fixnum(n); bytes = CELL+(n1+7)/8; #define bitvechdr_(n) (TYPE_BITVEC1 + ((((n)+7)&7)<<7)) w = getvector(TAG_VECTOR, bitvechdr_(n1), bytes); errexit(); n1 = doubleword_align_up(bytes); while (n1 > CELL) { n1 -= 4; *(int32 *)((char *)w - TAG_VECTOR + n1) = 0; } return onevalue(w); } static Lisp_Object MS_CDECL Lbputv(Lisp_Object nil, int nargs, ...) { Header h; va_list a; int b; int32 n1; Lisp_Object v, n, x; argcheck(nargs, 3, "bputv"); va_start(a, nargs); v = va_arg(a, Lisp_Object); n = va_arg(a, Lisp_Object); x = va_arg(a, Lisp_Object); va_end(a); CSL_IGNORE(nil); /* * This code is WRONG at present in that unexpectedly it is supposed to * support bit-arrays of arbitrary rank, and not just simple vectors. */ if (!(is_vector(v)) || !header_of_bitvector(h = vechdr(v))) return aerror1("putv-bit", v); if (!is_fixnum(n)) return aerror1("putv-bit", n); if (!is_fixnum(x)) return aerror1("putv-bit contents", x); x = int_of_fixnum(x) & 1; h = length_of_header(h) - CELL; n1 = int_of_fixnum(n); b = 1 << (n1 & 7); /* Bit selector */ n1 = n1 >> 3; /* Byte selector */ /* * I am just a bit shoddy here - I only complain if an attempt is made to * access beyond the last active byte of a bitvector - I do not * do bound checking accurate to bit positions. */ if (n1 < 0 || n1 >= (int32)h) return aerror1("putv-bit", n); if (x == 0) ucelt(v, n1) &= ~b; else ucelt(v, n1) |= b; return onevalue(fixnum_of_int(x)); } static Lisp_Object Lbgetv(Lisp_Object nil, Lisp_Object v, Lisp_Object n) { Header h; int b; int32 n1; CSL_IGNORE(nil); /* * This code is WRONG at present in that unexpectedly it is supposed to * support bit-arrays of arbitrary rank, and not just simple vectors. */ if (!(is_vector(v)) || !header_of_bitvector(h = vechdr(v))) return aerror1("getv-bit", v); if (!is_fixnum(n)) return aerror1("getv-bit", n); h = length_of_header(h) - CELL; n1 = int_of_fixnum(n); b = 1 << (n1 & 7); /* Bit selector */ n1 = n1 >> 3; /* Byte selector */ if (n1 < 0 || n1 >= (int32)h) return aerror1("getv-bit", n); if ((ucelt(v, n1) & b) == 0) return onevalue(fixnum_of_int(0)); else return onevalue(fixnum_of_int(1)); } #endif /* COMMON */ Lisp_Object Lupbv(Lisp_Object nil, Lisp_Object v) { Header h; int32 n; CSL_IGNORE(nil); /* * in non segmented mode this will support BPS, but really * you ought not to rely on that. */ if (!(is_vector(v))) return onevalue(nil); /* Standard Lisp demands.. */ h = vechdr(v); n = length_of_header(h) - CELL; #ifdef COMMON if (header_of_bitvector(h)) { n = (n - 1)*8; n += ((h & 0x380) >> 7) + 1; } else #endif switch (type_of_header(h)) { case TYPE_STRING: case TYPE_VEC8: break; case TYPE_VEC16: n = n/2; break; case TYPE_VEC32: n = n/4; break; case TYPE_FLOAT64: n = n/8; break; default: n = n/CELL; break; } n--; /* c.f. mkvect */ return onevalue(fixnum_of_int(n)); } #ifdef COMMON Lisp_Object Lvecbnd(Lisp_Object nil, Lisp_Object v) { Header h; int32 n; CSL_IGNORE(nil); /* * in non segmented mode this will support BPS, but really * you ought not to rely on that. */ if (!(is_vector(v))) return aerror1("vector-bound", v); h = vechdr(v); n = length_of_header(h) - CELL; if (header_of_bitvector(h)) { n = (n - 1)*8; n += ((h & 0x380) >> 7) + 1; } else switch (type_of_header(h)) { case TYPE_STRING: case TYPE_VEC8: break; case TYPE_VEC16: n = n/2; break; case TYPE_VEC32: n = n/4; break; case TYPE_FLOAT64: n = n/8; break; default: n = n/CELL; break; } return onevalue(fixnum_of_int(n)); } #endif #ifdef COMMON /* * The following were added for efficiency reasons, MCD 14/8/96 */ Lisp_Object list_subseq(Lisp_Object sequence, int32 start, int32 end) { Lisp_Object nil=C_nil, copy, last, new, seq=sequence; int32 seq_length, pntr = start; seq_length = end - start; /* Find start of subsequence */ while (consp(seq) && pntr > 0) { pntr--; seq = qcdr(seq); } if (!consp(seq)) return aerror1("subseq",sequence); copy = nil; /* Store the values */ push(sequence); while (consp(seq) && pntr < seq_length) { push3(seq,copy,last); new = Lcons(nil,qcar(seq),nil); pop3(last,copy,seq); if (pntr == 0) copy = new; else qcdr(last) = new; last = new; seq = qcdr(seq); pntr++; } pop(sequence); errexit(); if (pntr != seq_length) return aerror1("subseq",sequence); return onevalue(copy); } Lisp_Object vector_subseq(Lisp_Object sequence, int32 start, int32 end) { Lisp_Object nil=C_nil, copy; Header h; int32 hl, seq_length, i; if (is_cons(sequence)) return list_subseq(sequence,start,end); else if (!is_vector(sequence)) return aerror1("vector-subseq*",sequence); seq_length = end - start; h = vechdr(sequence); if (type_of_header(h) == TYPE_SIMPLE_VEC ) { hl = (length_of_header(h) - CELL)/CELL; if (hl < end) return aerror0("vector-subseq* out of range"); /* * Since we are dealing with a simple vector the following shift is * guarenteed to work. The extra CELL bytes are for the header. */ copy = getvector_init(CELL+seq_length*CELL,nil); for (i=start; i < end; ++i) elt(copy,i-start) = elt(sequence,i); return onevalue(copy); } else if (type_of_header(h) == TYPE_STRING) { char *s; int32 k; hl = length_of_header(h) - CELL; if (hl < end) return aerror0("vector-subseq* out of range"); /* Get a new string of the right size */ push(sequence); copy = getvector(TAG_VECTOR, TYPE_STRING, CELL+seq_length); pop(sequence); /* This code plagiarised from copy_string ... */ s = (char *)copy - TAG_VECTOR; k = (seq_length + 3) & ~(int32)7; errexit(); *(int32 *)(s + k + CELL) = 0; if (k != 0) *(int32 *)(s + k) = 0; memcpy(s + CELL, (char *)sequence+(CELL-TAG_VECTOR)+start, (size_t)seq_length); return onevalue(copy); } else if (header_of_bitvector(h)) { hl = length_of_header(h) - CELL; if (hl < end/8) return aerror0("vector-subseq* out of range"); /* Grab a bit-vector of the right size */ push(sequence); copy = Lmake_simple_bitvector(nil,fixnum_of_int(seq_length)); pop(sequence); errexit(); /* * This is not terribly efficient since the calls to Lbputv and Lbgetv * ought to be coded inline, but on the other hand its no worse than the * original Lisp-coded version. */ for (i=start; i last) return aerror1("list-subseq* out of range",seq); return list_subseq(seq, first, last); } Lisp_Object MS_CDECL Llist_subseq2(Lisp_Object nil, int32 nargs, ...) { va_list args; int32 first, last; Lisp_Object seq, start, end; argcheck(nargs, 3, "list-subseq*"); va_start(args, nargs); seq = va_arg(args, Lisp_Object); start = va_arg(args, Lisp_Object); end = va_arg(args, Lisp_Object); va_end(args); first = int_of_fixnum(start); last = int_of_fixnum(end); if (first > last) return aerror1("list-subseq* out of range",seq); return list_subseq(seq, first, last); } Lisp_Object Lvector_subseq1(Lisp_Object nil, Lisp_Object seq, Lisp_Object start) { Lisp_Object len; int32 first, last; first = int_of_fixnum(start); push(seq); len = Llength(nil,seq); pop(seq); errexit(); last = int_of_fixnum(len); if (first > last) return aerror1("vector-subseq* out of range",seq); return vector_subseq(seq, first, last); } Lisp_Object MS_CDECL Lvector_subseq2(Lisp_Object nil, int32 nargs, ...) { va_list args; int32 first, last; Lisp_Object seq, start, end; argcheck(nargs, 3, "vector-subseq*"); va_start(args, nargs); seq = va_arg(args, Lisp_Object); start = va_arg(args, Lisp_Object); end = va_arg(args, Lisp_Object); va_end(args); first = int_of_fixnum(start); last = int_of_fixnum(end); if (first > last) return aerror1("vector-subseq* out of range",seq); return vector_subseq(seq, first, last); } #endif setup_type const funcs3_setup[] = { {"getv", too_few_2, Lgetv, wrong_no_2}, {"putv", wrong_no_3a, wrong_no_3b, Lputv}, {"getv8", too_few_2, Lgetv8, wrong_no_2}, {"putv8", wrong_no_3a, wrong_no_3b, Lputv8}, {"getv16", too_few_2, Lgetv16, wrong_no_2}, {"putv16", wrong_no_3a, wrong_no_3b, Lputv16}, {"getv32", too_few_2, Lgetv32, wrong_no_2}, {"putv32", wrong_no_3a, wrong_no_3b, Lputv32}, {"fgetv32", too_few_2, Lfgetv32, wrong_no_2}, {"fputv32", wrong_no_3a, wrong_no_3b, Lfputv32}, {"fgetv64", too_few_2, Lfgetv64, wrong_no_2}, {"fputv64", wrong_no_3a, wrong_no_3b, Lfputv64}, {"qgetv", too_few_2, Lgetv, wrong_no_2}, {"egetv", too_few_2, Lgetv, wrong_no_2}, {"qputv", wrong_no_3a, wrong_no_3b, Lputv}, {"eputv", wrong_no_3a, wrong_no_3b, Lputv}, {"make-simple-string", Lsmkvect, too_many_1, wrong_no_1}, {"putv-char", wrong_no_3a, wrong_no_3b, Lsputv}, {"bps-putv", wrong_no_3a, wrong_no_3b, Lbpsputv}, {"bps-getv", too_few_2, Lbpsgetv, wrong_no_2}, {"bps-upbv", Lbpsupbv, too_many_1, wrong_no_1}, {"native-type", wrong_no_na, wrong_no_nb, Lnative_type}, {"native-putv", wrong_no_3a, wrong_no_3b, Lnativeputv}, {"native-getv", too_few_2, Lnativegetv, Lnativegetvn}, {"native-address", Lnative_address1, Lnative_address, wrong_no_2}, {"eupbv", Lupbv, too_many_1, wrong_no_1}, {"schar", too_few_2, Lsgetv, wrong_no_2}, {"scharn", too_few_2, Lsgetvn, wrong_no_2}, {"byte-getv", too_few_2, Lbytegetv, wrong_no_2}, {"mkvect", Lmkvect, too_many_1, wrong_no_1}, {"mkevect", Lmkevect, too_many_1, wrong_no_1}, {"mkxvect", Lmkxvect, too_many_1, wrong_no_1}, {"mkvect8", Lmkvect8, too_many_1, wrong_no_1}, {"mkvect16", Lmkvect16, too_many_1, wrong_no_1}, {"mkvect32", Lmkvect32, too_many_1, wrong_no_1}, {"mkfvect32", Lmkfvect32, too_many_1, wrong_no_1}, {"mkfvect64", Lmkfvect64, too_many_1, wrong_no_1}, {"mkhash", wrong_no_3a, wrong_no_3b, Lmkhash}, {"gethash", Lget_hash_1, Lget_hash_2, Lget_hash}, {"puthash", wrong_no_3a, Lput_hash_2, Lput_hash}, {"remhash", Lrem_hash_1, Lrem_hash, wrong_no_2}, {"clrhash", Lclr_hash, too_many_1, Lclr_hash_0}, {"sxhash", Lsxhash, too_many_1, wrong_no_1}, {"eqlhash", Leqlhash, too_many_1, wrong_no_1}, {"maphash", too_few_2, Lmaphash, wrong_no_2}, {"hashcontents", Lhashcontents, too_many_1, wrong_no_1}, {"upbv", Lupbv, too_many_1, wrong_no_1}, #ifdef COMMON {"hashtable-flavour", Lhash_flavour, too_many_1, wrong_no_1}, {"getv-bit", too_few_2, Lbgetv, wrong_no_2}, {"sbit", too_few_2, Lbgetv, wrong_no_2}, {"make-simple-bitvector", Lmake_simple_bitvector, too_many_1, wrong_no_1}, {"make-simple-vector", Lmksimplevec, too_many_1, wrong_no_1}, {"putv-bit", wrong_no_3a, wrong_no_3b, Lbputv}, {"sbitset", wrong_no_3a, wrong_no_3b, Lbputv}, {"svref", too_few_2, Lgetv, wrong_no_2}, {"vector-bound", Lvecbnd, too_many_1, wrong_no_1}, {"putvec", wrong_no_3a, wrong_no_3b, Lputvec}, {"aref", Laref1, Laref2, Laref}, {"aset", Laset1, Laset2, Laset}, {"elt", too_few_2, Lelt, wrong_no_2}, {"setelt", wrong_no_3a, wrong_no_3b, Lsetelt}, {"vectorp", Lvectorp, too_many_1, wrong_no_1}, {"char", too_few_2, Lchar, wrong_no_2}, {"charset", wrong_no_3a, wrong_no_3b, Lcharset}, {"make-string", Lmake_string1, Lmake_string2, Lmake_string}, {"list-to-vector", Llist_to_vector, too_many_1, wrong_no_1}, {"vector", Lvector1, Lvector2, Lvector}, {"shrink-vector", too_few_2, Lshrink_vector, wrong_no_2}, {"string", Lstring, too_many_1, wrong_no_1}, {"vector-subseq*", wrong_no_3a, Lvector_subseq1, Lvector_subseq2}, {"list-subseq*", wrong_no_3a, Llist_subseq1, Llist_subseq2}, {"subseq", wrong_no_3a, Lvector_subseq1, Lvector_subseq2}, /* The "x" is temporary while I debug */ {"xcopy-vector", Lcopy_vector, too_many_1, wrong_no_1}, #endif {"encapsulatedp", Lencapsulatedp, too_many_1, wrong_no_1}, {"maple_atomic_value", Lmaple_atomic_value, too_many_1, wrong_no_1}, {"maple_tag", Lmaple_tag, too_many_1, wrong_no_1}, {"maple_length", Lmaple_length, too_many_1, wrong_no_1}, {"maple_string_data", Lmaple_string_data, too_many_1, wrong_no_1}, {"maple_integer", Lmaple_integer, too_many_1, wrong_no_1}, {"maple_component", too_few_2, Lmaple_component, wrong_no_2}, {NULL, 0, 0, 0} }; /* end of fns3.c */