mirror of
https://github.com/Interlisp/maiko.git
synced 2026-03-06 02:59:14 +00:00
c4873d0ff8
* Display atom name in error message if get_package_atom() fails * Various fixes to package/atom handling in testtool.c Remove S_TOPVAL and S_MAKEATOM which only existed to deal with an old issue with dbx where you supposedly couldn't enter a string with "\" in it. Remove countchar(), which is functionally identical to strlen(), and adjust code that used it. Adjust return type of MAKEATOM() to be the LispPTR that it should be, instead of int. Limit find_package_from_name() to examining only the number of entries that are present in the *PACKAGE-FROM-INDEX* array, instead of walking off the end. MakeAtom68k() now drops into uraid() if asked to look up an atom that does not exist (Make... is a misnomer, it will never *make* the atom, only lookup an existing one)
326 lines
11 KiB
C
326 lines
11 KiB
C
/* $Id: gcarray.c,v 1.3 1999/05/31 23:35:30 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved
|
|
*/
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* (C) Copyright 1989-1995 Venue. All Rights Reserved. */
|
|
/* Manufactured in the United States of America. */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
#include "version.h"
|
|
|
|
/*************************************************************************/
|
|
/* */
|
|
/* File Name : gcarray.c */
|
|
/* */
|
|
/*************************************************************************/
|
|
/* */
|
|
/* Functions : */
|
|
/* LispPTR aref1(array, index); */
|
|
/* DLword find_symbol(char_base,offset, */
|
|
/* length,hashtbl); */
|
|
/* DLword get_package_atom( */
|
|
/* char_base,charlen,packname, */
|
|
/* packlen,externalp); */
|
|
/* */
|
|
/* LispPTR with_symbol(charbase, charlen, */
|
|
/* hashtable, result_fixp); */
|
|
/* */
|
|
/*************************************************************************/
|
|
/* Description : */
|
|
/* */
|
|
/* The function "aref1" is the accessor of oned_array. */
|
|
/* The functions "find_symbol" and "get_package_atom" are implemented */
|
|
/* to access the atom through the package mechanism. */
|
|
/* */
|
|
/* with_symbol is a C subr implementation of LLPACKAGE's */
|
|
/* WITH-SYMBOL macro: It returns as its result the symbol found, */
|
|
/* or NIL if none, and in the result_fixp, -1 if not found. */
|
|
/* */
|
|
/*************************************************************************/
|
|
/* \Tomtom */
|
|
/*************************************************************************/
|
|
|
|
#include <stdio.h>
|
|
#include <string.h>
|
|
|
|
#include "lispemul.h"
|
|
#include "lsptypes.h"
|
|
#include "address.h"
|
|
#include "adr68k.h"
|
|
#include "lspglob.h"
|
|
#include "stack.h"
|
|
#include "cell.h"
|
|
#include "ifpage.h"
|
|
#include "gcdata.h"
|
|
#include "array.h"
|
|
#include "debug.h"
|
|
#include "lispmap.h"
|
|
|
|
#include "gcarraydefs.h"
|
|
#include "car-cdrdefs.h"
|
|
#include "commondefs.h"
|
|
#include "mkatomdefs.h"
|
|
#include "testtooldefs.h"
|
|
|
|
/*** not currently used -FS
|
|
#define min(a,b) ((a > b)?b:a)
|
|
#define Trailer(ldatum,datum68) (ldatum+2*(datum68->arlen - ARRAYBLOCKTRAILERCELLS))
|
|
#define BucketIndex(n) min(integerlength(n),MAXBUCKETINDEX)
|
|
#define FreeBlockChainN(n) ((POINTERMASK & *FreeBlockBuckets_word)+2*BucketIndex(n))
|
|
***/
|
|
|
|
#define Rehash_factor(hash, tablelen) (((hash) % ((tablelen)-2)) + 1)
|
|
#define Symbol_hash_reprobe(hash, rehashfactor, tablelen) (((hash) + (rehashfactor)) % (tablelen))
|
|
#define Entry_hash(strlen, sxhash) \
|
|
(((((((strlen) ^ (sxhash)) ^ ((sxhash) >> 8)) ^ ((sxhash) >> 16)) ^ ((sxhash) >> 19)) % 254) + 2)
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* Package hashtable structure */
|
|
/* */
|
|
/* 2 per package, for looking up internal and external symbols. */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
struct hashtable {
|
|
LispPTR table;
|
|
LispPTR hash;
|
|
LispPTR size;
|
|
LispPTR free;
|
|
LispPTR deleted;
|
|
};
|
|
|
|
/* The end of macros & structure for medley version */
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* */
|
|
/* */
|
|
/* */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
LispPTR aref1(LispPTR array, int index) {
|
|
register LispPTR retval = 0;
|
|
register LispPTR base;
|
|
register short typenumber;
|
|
register struct arrayheader *actarray;
|
|
|
|
actarray = (struct arrayheader *)Addr68k_from_LADDR(array);
|
|
if (index >= actarray->totalsize) {
|
|
printf("Invalid index in GC's AREF1: 0x%x\n", index);
|
|
printf(" Array size limit: 0x%x\n", actarray->totalsize);
|
|
printf(" Array ptr: 0x%lx\n", (UNSIGNED)array);
|
|
printf(" Array 68K ptr: %p\n", actarray);
|
|
printf("base: 0x%x\n", actarray->base);
|
|
printf("offset: 0x%x\n", actarray->offset);
|
|
printf("type #: 0x%x\n", actarray->typenumber);
|
|
printf("fill ptr: 0x%x\n", actarray->fillpointer);
|
|
error("index out of range in GC's AREF1.");
|
|
}
|
|
index += actarray->offset;
|
|
typenumber = actarray->typenumber;
|
|
base = actarray->base;
|
|
switch (typenumber) {
|
|
case 3: /* unsigned 8bits */
|
|
retval = (GETBYTE(((char *)Addr68k_from_LADDR(base)) + index)) & 0x0ff;
|
|
retval |= S_POSITIVE;
|
|
break;
|
|
case 4: /* unsigned 16bits */
|
|
retval = (GETWORD(((DLword *)Addr68k_from_LADDR(base)) + index)) & 0x0ffff;
|
|
retval |= S_POSITIVE;
|
|
break;
|
|
case 38: retval = (*(((LispPTR *)Addr68k_from_LADDR(base)) + index)); break;
|
|
default: error("Not Implemented in gc's aref1 (other types)");
|
|
};
|
|
return (retval);
|
|
}
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* */
|
|
/* */
|
|
/* */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
LispPTR find_symbol(const char *char_base, DLword offset, DLword length, LispPTR hashtbl, DLword fatp,
|
|
DLword lispp)
|
|
|
|
/* T => the "chars" coming in are 16-bit */
|
|
/* T => the incoming chars are in LISP space */
|
|
{
|
|
DLword hashval, ehashval, h2, ehash, indexvar;
|
|
int arraylen;
|
|
struct hashtable *hashtbladdr;
|
|
#ifdef BIGATOMS
|
|
LispPTR vecs, hashes;
|
|
#endif /* BIGATOMS */
|
|
|
|
LispPTR vec, hash;
|
|
struct arrayheader *vec68k;
|
|
int fatpnamep;
|
|
|
|
if (!hashtbl) return (0xffffffff);
|
|
|
|
if (lispp)
|
|
hashval = compute_lisp_hash(char_base, offset, length, fatp);
|
|
else
|
|
hashval = compute_hash(char_base, offset, length);
|
|
|
|
ehashval = Entry_hash(length, hashval);
|
|
hashtbladdr = (struct hashtable *)Addr68k_from_LADDR(hashtbl);
|
|
|
|
/* Move our string ptr up by offset, allowing for fatness */
|
|
if (fatp)
|
|
char_base += (offset << 1);
|
|
else
|
|
char_base += offset;
|
|
|
|
#ifdef BIGATOMS
|
|
vecs = hashtbladdr->table;
|
|
hashes = hashtbladdr->hash;
|
|
|
|
loop_thru_hashtables:
|
|
|
|
vec = car(vecs);
|
|
vecs = cdr(vecs);
|
|
hash = car(hashes);
|
|
hashes = cdr(hashes);
|
|
vec68k = (struct arrayheader *)Addr68k_from_LADDR(vec);
|
|
arraylen = vec68k->totalsize;
|
|
if (arraylen == 0) return (0xffffffff); /*kludge TAKE*/
|
|
h2 = Rehash_factor(hashval, arraylen);
|
|
indexvar = (hashval % arraylen);
|
|
#else
|
|
vec = hashtbladdr->table;
|
|
hash = hashtbladdr->hash;
|
|
vec68k = (struct arrayheader *)Addr68k_from_LADDR(vec);
|
|
arraylen = vec68k->totalsize;
|
|
if (arraylen == 0) return (0xffffffff); /*kludge TAKE*/
|
|
h2 = Rehash_factor(hashval, arraylen);
|
|
indexvar = (hashval % arraylen);
|
|
#endif /* BIGATOMS */
|
|
|
|
retry:
|
|
/* the aref1 returns a smallp, which is always <256, so trim it */
|
|
while (ehashval != (ehash = 0xFF & aref1(hash, indexvar))) {
|
|
if (ehash == NIL) { /* Ran out of entries in this table; try next or fail */
|
|
#ifdef BIGATOMS
|
|
if (hashes == NIL) return (0xffffffff); /* Last table. Fail. */
|
|
goto loop_thru_hashtables;
|
|
#else
|
|
return (0xffffffff);
|
|
#endif /* BIGATOMS */
|
|
}
|
|
indexvar = Symbol_hash_reprobe(indexvar, h2, arraylen);
|
|
}
|
|
/* if ((indexvar&0xffff) != NIL) */
|
|
{
|
|
LispPTR index;
|
|
PNCell *pnptr;
|
|
char *pname_base;
|
|
|
|
index = aref1(vec, indexvar);
|
|
if ((index & SEGMASK) == S_POSITIVE) index &= 0xFFFF;
|
|
|
|
pnptr = (PNCell *)GetPnameCell(index);
|
|
fatpnamep = ((PLCell *)GetPropCell(index))->fatpnamep;
|
|
pname_base = (char *)Addr68k_from_LADDR(pnptr->pnamebase);
|
|
if ((length == GETBYTE(pname_base)) &&
|
|
(T == ((lispp) ? compare_lisp_chars((pname_base + 1 + fatpnamep), char_base, length,
|
|
fatpnamep, fatp)
|
|
: compare_chars((pname_base + 1 + fatpnamep), char_base, length)))) {
|
|
return (index);
|
|
} else {
|
|
indexvar = Symbol_hash_reprobe(indexvar, h2, arraylen);
|
|
goto retry;
|
|
}
|
|
}
|
|
/* else return(0xffffffff); */ /* can't find */
|
|
}
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* g e t _ p a c k a g e _ a t o m */
|
|
/* */
|
|
/* Try to look up the given symbol in the given package. If */
|
|
/* you find it, return the atom number. Otherwise, return -1. */
|
|
/* */
|
|
/* */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
LispPTR get_package_atom(const char *char_base, DLword charlen, const char *packname, DLword packlen,
|
|
int externalp) {
|
|
int packindex;
|
|
PACKAGE *packaddr;
|
|
/* LispPTR hashtbladdr; */
|
|
LispPTR index;
|
|
|
|
/* For convenience, recognize the common package nicknames: */
|
|
|
|
if (0 == strncmp(packname, "XCL", packlen))
|
|
packindex = find_package_from_name("XEROX-COMMON-LISP", 17);
|
|
else if (0 == strncmp(packname, "SI", packlen))
|
|
packindex = find_package_from_name("SYSTEM", 6);
|
|
else if (0 == strncmp(packname, "CL", packlen))
|
|
packindex = find_package_from_name("LISP", 4);
|
|
else if (0 == strncmp(packname, "XCLC", packlen))
|
|
packindex = find_package_from_name("COMPILER", 8);
|
|
|
|
/**** else if (0 == strncmp(packname, "KEYWORD", packlen))
|
|
packindex = 7;***/
|
|
|
|
else
|
|
packindex = find_package_from_name(packname, packlen);
|
|
|
|
if (packindex < 0) {
|
|
printf("getting package index failed %s:%s\n", packname, char_base);
|
|
return (0xffffffff);
|
|
}
|
|
|
|
/* if (packindex != 7) Not necessary (Take)*/
|
|
packaddr = (PACKAGE *)Addr68k_from_LADDR(aref1(*Package_from_Index_word, packindex));
|
|
/* else packaddr = (PACKAGE *)Addr68k_from_LADDR(
|
|
*Keyword_Package_word); */
|
|
/* hashtbladdr = ((externalp == T)?(packaddr->EXTERNAL_SYMBOLS):
|
|
(packaddr->INTERNAL_SYMBOLS));
|
|
return( find_symbol(char_base, 0, charlen, hashtbladdr, 0, 0) );*/
|
|
|
|
if ((index = find_symbol(char_base, 0, charlen, packaddr->EXTERNAL_SYMBOLS, 0, 0)) != 0xffffffff)
|
|
return (index);
|
|
else
|
|
return (find_symbol(char_base, 0, charlen, packaddr->INTERNAL_SYMBOLS, 0, 0));
|
|
}
|
|
|
|
/************************************************************************/
|
|
/* */
|
|
/* */
|
|
/* */
|
|
/* */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
LispPTR with_symbol(LispPTR char_base, LispPTR offset, LispPTR charlen, LispPTR fatp,
|
|
LispPTR hashtbl, LispPTR result) {
|
|
char *charbase68k = (char *)Addr68k_from_LADDR(char_base);
|
|
LispPTR *resultptr = (LispPTR *)Addr68k_from_LADDR(result);
|
|
DLword chars = charlen & 0xFFFF; /* charlen must be a SMALLP! */
|
|
DLword offst = offset & 0xFFFF;
|
|
int symbol; /* Where the symbol goes pro tem */
|
|
|
|
symbol = find_symbol(charbase68k, offst, chars, hashtbl, (DLword)fatp, (DLword)1);
|
|
|
|
if (symbol == -1) { /* Not found. Signal that with -1 in result fixp */
|
|
*resultptr = -1;
|
|
return (NIL);
|
|
}
|
|
|
|
*resultptr = 3;
|
|
return (symbol);
|
|
|
|
} /* End of with_symbol */
|