intern.c
Go to the documentation of this file.
1 /****************************************************************/
2 /* EusLisp: intern.c
3 /* intern a symbol in a package
4 /* Copyright (c) 1989, Toshihiro MATSUI, Electrotechnical Laboratory
5 /*
6 /****************************************************************/
7 static char *rcsid="@(#)$Id$";
8 
9 #include "eus.h"
10 
12 
13 int rehash(str)
14 register pointer str; /*string object*/
15 { register int i,l,hash;
16  register byte *id;
17  id=str->c.str.chars;
18  l=vecsize(str);
19  hash=l;
20  for (i=0; i<l; i++) hash+=(hash<<2)+id[i];
21  return(hash & 0x1fffffff);}
22 
23 pointer findsymbol(id,l,symvec,hashval)
24 byte *id;
25 int l,*hashval;
26 register pointer symvec;
27 { register pointer sym,pnam;
28  register int i,size,hash=l,flag=0;
29  for (i=0; i<l; i++) hash+=(hash<<2)+id[i];
30  hash&=0x1fffffff;
31  size=vecsize(symvec);
32  if (size==0) return(NULL);
33  hash=hash % size;
34  do {
35  sym = symvec->c.vec.v[hash];
36  if (issymbol(sym)) {
37  pnam=sym->c.sym.pname;
38  if (strlength(pnam)==l &&
39  !memcmp((char *)pnam->c.str.chars, (char *)id, l)) {
40  *hashval=hash; return(sym);}}
41  if (sym==makeint(0)) {
42  if (flag==0) *hashval=hash;
43  return(NULL);}
44  if (sym==makeint(1) && flag==0) { flag=1; *hashval=hash;}
45  if (++hash>=size) hash=0;}
46  while (1);}
47 
48 static pointer extendsymvec(symvec)
49 pointer symvec;
50 { register pointer newsymvec,sym;
51  bpointer bp;
52  register int i,newsize,size,hash;
53  size=vecsize(symvec);
54  bp=bpointerof(symvec);
55 #ifdef RGC
56  newsize=buddysize[(bp->h.bix & TAGMASK)+1]-2;
57 #else
58  newsize=buddysize[bp->h.bix+1]-2;
59 #endif
60  newsymvec=makevector(C_VECTOR,newsize);
61  for (i=0; i<newsize; i++) newsymvec->c.vec.v[i]=makeint(0); /*empty mark*/
62  for (i=0; i<size; i++) { /*rehash all symbols*/
63  sym=symvec->c.vec.v[i];
64  if (issymbol(sym)) {
65  hash=rehash(sym->c.sym.pname) % newsize;
66  while (newsymvec->c.vec.v[hash]!=makeint(0)) { /*find an empty slot*/
67  if (++hash>=newsize) hash=0;}
68  pointer_update(newsymvec->c.vec.v[hash],sym);}}
69 #ifdef SAFETY
70  take_care(newsymvec);
71 #endif
72  return(newsymvec);}
73 
74 pointer export(sym,pkg)
75 pointer sym,pkg;
76 { register pointer symvec=pkg->c.pkg.symvector; /*external symbol table*/
77  register int size, newsymcount;
78  int hash;
79  pointer usedby,usedbylist=pkg->c.pkg.used_by;
80  pointer pnam,s;
81 
82  pnam=sym->c.sym.pname;
83  usedby = (T);
84  /*check symbol conflict in each of used-by packages*/
85  while (usedby && iscons(usedbylist)) {
86  usedby=ccar(usedbylist);
87  usedbylist=ccdr(usedbylist);
88  s=findsymbol(pnam->c.str.chars, strlength(pnam),
89  usedby->c.pkg.intsymvector, &hash);
90  if (s && s!=sym) error(E_SYMBOLCONFLICT,sym);}
91  size=vecsize(symvec);
92  hash=rehash(pnam) % size;
93  while (1) {
94  if (symvec->c.vec.v[hash]==sym) return(sym);
95  if (isint(symvec->c.vec.v[hash])) {
96  pointer_update(symvec->c.vec.v[hash],sym);
97  newsymcount=intval(pkg->c.pkg.symcount)+1;
98  pkg->c.pkg.symcount=makeint(newsymcount);
99  if (newsymcount > (size / 2))
100  pointer_update(pkg->c.pkg.symvector, extendsymvec(symvec));
101  return(sym);}
102  else if (++hash>=size) hash=0;}
103  }
104 
105 pointer intern(ctx,id,l,pkg)
106 register context *ctx;
107 char *id; /*pointer to a string*/
108 int l; /*l=strlen(id)*/
109 pointer pkg; /*destination package*/
110 { register pointer sym,symvec,newsym,uselist,use;
111  register int i,size;
112  int hash,newhash;
113 
114  if ((sym=findsymbol((byte *)id,l,pkg->c.pkg.intsymvector,&hash))) return(sym);
115  uselist=pkg->c.pkg.use;
116  while (islist(uselist)) { /*search in external symbols in inherited packages*/
117  use=ccar(uselist);
118  uselist=ccdr(uselist);
119  if ((sym=findsymbol((byte *)id,l,use->c.pkg.symvector,&newhash))) return(sym);}
120  /*create the symbol and insert it in the package*/
121  symvec=pkg->c.pkg.intsymvector;
122  size=vecsize(symvec);
123  newsym=makesymbol(ctx,id,l,pkg);
124  /*put it in the package*/
125  while (issymbol(symvec->c.vec.v[hash])) if (++hash>=size) hash=0;
126  pointer_update(symvec->c.vec.v[hash],newsym);
127  if (pkg==keywordpkg) {
128  newsym->c.sym.vtype=V_CONSTANT;
129  pointer_update(newsym->c.sym.speval,newsym);
130  export(newsym,pkg);}
131  l=intval(pkg->c.pkg.intsymcount)+1;
132  pkg->c.pkg.intsymcount=makeint(l);
133  if (l>(size/2)) { /*extend hash table*/
134  vpush(newsym);
135  pointer_update(pkg->c.pkg.intsymvector,extendsymvec(symvec));
136  vpop();}
137  /* export all the symbols to avoid incompatibility with old EusLisp*/
138  if (export_all) export(newsym, pkg);
139 #ifdef SAFETY
140  take_care(newsym);
141 #endif
142  return(newsym); }
143 
144 
pointer used_by
Definition: eus.h:225
pointer speval
Definition: eus.h:201
pointer makesymbol(context *, char *, int, pointer)
Definition: makes.c:164
static int bp
pointer findsymbol(byte *id, int l, pointer symvec, int *hashval)
Definition: intern.c:23
struct vector vec
Definition: eus.h:412
#define makeint(v)
Definition: sfttest.c:2
pointer C_VECTOR
Definition: eus.c:144
Definition: eus.h:522
struct string str
Definition: eus.h:400
byte chars[1]
Definition: eus.h:210
pointer T
Definition: eus.c:110
pointer intern(context *ctx, char *id, int l, pointer pkg)
Definition: intern.c:105
pointer symvector
Definition: eus.h:220
pointer intsymvector
Definition: eus.h:222
static char * rcsid
Definition: intern.c:7
#define intval(p)
Definition: sfttest.c:1
pointer use
Definition: eus.h:219
pointer makevector(pointer, int)
Definition: makes.c:417
struct symbol sym
Definition: eus.h:399
union cell::cellunion c
int rehash(pointer str)
Definition: intern.c:13
long l
Definition: structsize.c:3
pointer intsymcount
Definition: eus.h:223
Definition: eus.h:379
static pointer extendsymvec(pointer symvec)
Definition: intern.c:48
struct cellheader h
Definition: eus.h:438
long buddysize[MAXBUDDY+1]
Definition: eus.c:103
short s
Definition: structsize.c:2
pointer vtype
Definition: eus.h:201
int export_all
Definition: intern.c:11
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
pointer export(pointer sym, pointer pkg)
Definition: intern.c:74
unsigned bix
Definition: eus.h:183
#define TAGMASK
Definition: collector.h:168
#define NULL
Definition: transargv.c:8
pointer pname
Definition: eus.h:201
Definition: eus.h:437
unsigned char byte
Definition: eus.h:161
pointer v[1]
Definition: eus.h:299
pointer keywordpkg
Definition: eus.c:109
struct package pkg
Definition: eus.h:402


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 6 2019 20:00:44