Mercurial > hg > jgplsrc

comparison s.c @ 0:e0bbaa717f41 draft default tip

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
lol J
author Jordi Gutiérrez Hermoso <jordigh@octave.org>
date Mon, 25 Nov 2013 11:56:30 -0500
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:e0bbaa717f41
1 /* Copyright 1990-2011, Jsoftware Inc. All rights reserved. */
2 /* License in license.txt. */
3 /* */
4 /* Symbol Table */
5
6 #include "j.h"
7
8
9 /* a symbol table aka locale is a type INT vector */
10 /* the length is prime and is one of ptab[i] */
11 /* zero elements mean unused entry */
12 /* non-zero elements are indices in the global symbol pool and */
13 /* are head pointers to a linked list */
14 /* the first element is symbol pool index for locale info */
15
16 /* the global symbol pool is a type INT matrix */
17 /* the number of columns is symcol=ceiling(sizeof(L)/sizeof(I)) */
18 /* elements are interpreted per type L (see jtype.h) */
19 /* A name - A name on LHS of assignment or locale name */
20 /* A val - value or locale search path */
21 /* I sn - script index */
22 /* I flag - various flags */
23 /* I next - pointer to successor in linked list */
24 /* I prev - pointer to predecessor in linked list */
25 /* if no predecessor then pointer to hash table entry, and */
26 /* flag will include LHEAD */
27 /* a stack of free entries is kept using the next pointer */
28 /* jt->symp: symbol pool array */
29 /* jt->sympv: symbol pool array pointer, (L*)AV(jt->symp) */
30 /* jt->symindex: symbol table index (monotonically increasing) */
31
32 /* numbered locales: */
33 /* jt->stnum: -1 means free; others are numbers in use */
34 /* jt->stptr: 0 means free; others are symbol tables */
35 /* jt->stused: # entries in stnum/stptr in use */
36 /* jt->stmax: 1 + maximum number extant */
37
38 /* named locales: */
39 /* jt->stloc: locales symbol table */
40
41 static I symcol=(sizeof(L)+SZI-1)/SZI;
42
43 B jtsymext(J jt,B b){A x,y;I j,m,n,s[2],*v,xn,yn;L*u;
44 if(b){y=jt->symp; j=((MS*)y-1)->j; n=*AS(y); yn=AN(y);}
45 else { j=12; n=1; yn=0; }
46 m=msize[1+j]; /* new size in bytes */
47 m-=sizeof(MS)+SZI*(AH+2); /* less array overhead */
48 m/=symcol*SZI; /* new # rows */
49 s[0]=m; s[1]=symcol; xn=m*symcol; /* new pool array shape */
50 GA(x,INT,xn,2,s); v=AV(x); /* new pool array */
51 if(b)ICPY(v,AV(y),yn); /* copy old data to new array */
52 memset(v+yn,C0,SZI*(xn-yn)); /* 0 unused area for safety */
53 u=n+(L*)v; j=1+n;
54 DO(m-n-1, u++->next=j++;); /* build free list extension */
55 if(b)u->next=jt->sympv->next; /* push extension onto stack */
56 ((L*)v)->next=n; /* new stack top */
57 jt->symp =ra(x); /* preserve new array */
58 jt->sympv=(L*)AV(x); /* new array value ptr */
59 if(b)fa(y); /* release old array */
60 R 1;
61 } /* 0: initialize (no old array); 1: extend old array */
62
63 L* jtsymnew(J jt,I*hv){I j;L*u,*v;
64 while(!(j=jt->sympv->next))RZ(symext(1)); /* extend pool if req'd */
65 jt->sympv->next=(j+jt->sympv)->next; /* new top of stack */
66 u=j+jt->sympv;
67 if(u->next=*hv){v=*hv+jt->sympv; v->prev=j; v->flag^=LHEAD;}
68 u->prev=(I)hv; u->flag=LHEAD;
69 *hv=j;
70 R u;
71 } /* allocate a new pool entry and insert into hash table entry hv */
72
73 B jtsymfree(J jt,L*u){I q;
74 q=u->next;
75 if(q)(q+jt->sympv)->prev=u->prev;
76 if(LHEAD&u->flag){*(I*)u->prev=q; if(q)(q+jt->sympv)->flag|=LHEAD;}
77 else (u->prev+jt->sympv)->next=q;
78 fa(u->name); u->name=0; /* zero out data fields */
79 fa(u->val ); u->val =0; u->sn=u->flag=u->prev=0;
80 u->next=jt->sympv->next; /* point to old top of stack */
81 jt->sympv->next=u-jt->sympv; /* new top of stack */
82 R 1;
83 } /* free pool entry pointed to by u */
84
85 static SYMWALK(jtsymfreeha, B,B01,100,1, 1, RZ(symfree(d))) /* free pool table entries */
86
87 B jtsymfreeh(J jt,A w,L*v){I*wv;L*u;
88 wv=AV(w);
89 ASSERTSYS(*wv,"symfreeh");
90 u=*wv+jt->sympv;
91 RZ(symfree(u));
92 RZ(symfreeha(w));
93 memset(wv,C0,AN(w)*SZI);
94 fa(w);
95 if(v){v->val=0; RZ(symfree(v));}
96 R 1;
97 } /* free entire hash table w, (optional) pointed by v */
98
99
100 static SYMWALK(jtsympoola, I,INT,100,1, 1, *zv++=j;)
101
102 F1(jtsympool){A aa,*pu,q,x,y,*yv,z,*zv;I i,j,n,*u,*v,*xv;L*pv;
103 RZ(w);
104 ASSERT(1==AR(w),EVRANK);
105 ASSERT(!AN(w),EVLENGTH);
106 GA(z,BOX,3,1,0); zv=AAV(z);
107 n=*AS(jt->symp); pv=jt->sympv;
108 GA(x,INT,n*6,2,0); *AS(x)=n; *(1+AS(x))=6; xv= AV(x); zv[0]=x;
109 GA(y,BOX,n, 1,0); yv=AAV(y); zv[1]=y;
110 for(i=0;i<n;++i,++pv){ /* per pool entry */
111 *xv++=i;
112 *xv++=(q=pv->val)?AT(pv->val):0;
113 *xv++=pv->flag;
114 *xv++=pv->sn;
115 *xv++=pv->next;
116 *xv++=pv->prev;
117 RZ(*yv++=(q=pv->name)?sfn(1,q):mtv);
118 }
119 GA(y,BOX,n,1,0); yv=AAV(y); zv[2]=y;
120 DO(n, yv[i]=mtv;);
121 n=AN(jt->stloc); v=AV(jt->stloc);
122 for(i=0;i<n;++i)if(j=v[i]){ /* per named locales */
123 x=(j+jt->sympv)->val;
124 RZ(yv[j]=yv[*AV(x)]=aa=sfn(1,LOCNAME(x)));
125 RZ(q=sympoola(x)); u=AV(q); DO(AN(q), yv[u[i]]=aa;);
126 }
127 n=AN(jt->stptr); pu=AAV(jt->stptr);
128 for(i=0;i<n;++i)if(x=pu[i]){ /* per numbered locales */
129 RZ( yv[*AV(x)]=aa=sfn(1,LOCNAME(x)));
130 RZ(q=sympoola(x)); u=AV(q); DO(AN(q), yv[u[i]]=aa;);
131 }
132 if(x=jt->local){ /* per local table */
133 RZ( yv[*AV(x)]=aa=cstr("**local**"));
134 RZ(q=sympoola(x)); u=AV(q); DO(AN(q), yv[u[i]]=aa;);
135 }
136 R z;
137 } /* 18!:31 symbol pool */
138
139
140 L*jtprobe(J jt,A a,A g){C*s;I*hv,k,m;L*v;NM*u;
141 RZ(a&&g);
142 u=NAV(a); m=u->m; s=u->s; k=u->hash%AN(g); hv=AV(g)+(k?k:1);
143 if(!*hv)R jt->cursymb=0; /* (0) empty slot */
144 v=*hv+jt->sympv;
145 while(1){
146 u=NAV(v->name);
147 if(m==u->m&&!memcmp(s,u->s,m))R jt->cursymb=v; /* (1) exact match */
148 if(!v->next)R jt->cursymb=0; /* (2) link list end */
149 v=v->next+jt->sympv;
150 }}
151
152 static L*jtprobeis(J jt,A a,A g){C*s;I*hv,k,m;L*v;NM*u;
153 u=NAV(a); m=u->m; s=u->s; k=u->hash%AN(g); hv=AV(g)+(k?k:1);
154 if(*hv){ /* !*hv means (0) empty slot */
155 v=*hv+jt->sympv;
156 while(1){
157 u=NAV(v->name);
158 if(m==u->m&&!memcmp(s,u->s,m))R jt->cursymb=v; /* (1) exact match */
159 if(!v->next)break; /* (2) link list end */
160 v=v->next+jt->sympv;
161 }}
162 RZ(v=symnew(hv));
163 v->name=ra(a);
164 R jt->cursymb=v;
165 } /* probe for assignment */
166
167 static L*jtsyrd1(J jt,A a,A g,B b){A*v,x,y;L*e;NM*av;
168 if(b&&jt->local&&(e=probe(a,jt->local))){av=NAV(a); R av->e=e;}
169 RZ(g&&(y=LOCPATH(g)));
170 if(e=probe(a,g))R e;
171 v=AAV(y);
172 DO(AN(y), x=v[i]; if(e=probe(a,stfind(1,AN(x),CAV(x))))break;);
173 R e;
174 } /* find name a where the current locale is g */
175
176 static A jtlocindirect(J jt,I n,C*u){A a,g=jt->global,x,y;B lcl=1;C*s,*v,*xv;I k,xn;L*e;
177 s=n+u;
178 while(u<s){
179 v=s; while('_'!=*--v); ++v;
180 k=s-v; s=v-2; RZ(a=nfs(k,v));
181 e=syrd1(a,g,lcl); lcl=0;
182 ASSERTN(e,EVVALUE,a);
183 y=e->val;
184 ASSERTN(!AR(y),EVRANK,a);
185 ASSERTN(BOX&AT(y),EVDOMAIN,a);
186 x=AAV0(y); xn=AN(x); xv=CAV(x);
187 ASSERTN(1>=AR(x),EVRANK,a);
188 ASSERTN(xn,EVLENGTH,a);
189 ASSERTN(LIT&AT(x),EVDOMAIN,a);
190 ASSERTN(vlocnm(xn,xv),EVILNAME,a);
191 RZ(g=stfind(1,xn,xv));
192 }
193 R g;
194 }
195
196 L*jtsyrd(J jt,A a,A*symb){A g=jt->global;I m,n;NM*v;
197 RZ(a);
198 n=AN(a); v=NAV(a); m=v->m;
199 if(n>m)RZ(g=NMILOC&v->flag?locindirect(n-m-2,2+m+v->s):stfind(1,n-m-2,1+m+v->s))
200 if(symb)*symb=g;
201 R syrd1(a,g,(B)(n==m));
202 }
203
204
205 static A jtdllsymaddr(J jt,A w,C flag){A*wv,x,y,z;I i,n,wd,*zv;L*v;
206 RZ(w);
207 n=AN(w); wv=AAV(w); wd=(I)w*ARELATIVE(w);
208 ASSERT(!n||BOX&AT(w),EVDOMAIN);
209 GA(z,INT,n,AR(w),AS(w)); zv=AV(z);
210 for(i=0;i<n;++i){
211 x=WVR(i); v=syrd(nfs(AN(x),CAV(x)),0L);
212 ASSERT(v,EVVALUE);
213 y=v->val;
214 ASSERT(NOUN&AT(y),EVDOMAIN);
215 zv[i]=flag?(I)AV(y):(I)v;
216 }
217 R z;
218 } /* 15!:6 (0=flag) or 15!:14 (1=flag) */
219
220 F1(jtdllsymget){R dllsymaddr(w,0);}
221 F1(jtdllsymdat){R dllsymaddr(w,1);}
222
223
224 F1(jtsymbrd){L*v; RZ(w); ASSERTN(v=syrd(w,0L),EVVALUE,w); R v->val;}
225
226 F1(jtsymbrdlock){A y;
227 RZ(y=symbrd(w));
228 R FUNC&AT(y)&&(jt->glock||VLOCK&VAV(y)->flag)?nameref(w):y;
229 }
230
231 B jtredef(J jt,A w,L*v){A f,oldn;DC c,d;
232 d=jt->sitop; while(d&&!(DCCALL==d->dctype&&d->dcj))d=d->dclnk; if(!(d&&DCCALL==d->dctype&&d->dcj))R 1;
233 oldn=jt->curname;
234 if(v==(L*)d->dcn){
235 jt->curname=d->dca; f=d->dcf;
236 ASSERT(AT(f)==AT(w)&&(CCOLON==VAV(f)->id)==(CCOLON==VAV(w)->id),EVSTACK);
237 d->dcf=w;
238 if(CCOLON==VAV(w)->id)jt->redefined=(I)v;
239 c=jt->sitop; while(c&&DCCALL!=c->dctype){c->dctype=DCJUNK; c=c->dclnk;}
240 }
241 c=d; while(c=c->dclnk){jt->curname=c->dca; ASSERT(!(DCCALL==c->dctype&&v==(L*)c->dcn),EVSTACK);}
242 jt->curname=oldn;
243 R 1;
244 } /* check for changes to stack */
245
246 A jtsymbis(J jt,A a,A w,A g){A x;I m,n,wn,wr,wt;NM*v;L*e;V*wv;
247 RZ(a&&w&&g);
248 n=AN(a); v=NAV(a); m=v->m;
249 if(n==m)ASSERT(!(jt->local&&g==jt->global&&probe(a,jt->local)),EVDOMAIN)
250 else{C*s=1+m+v->s; RZ(g=NMILOC&v->flag?locindirect(n-m-2,1+s):stfind(1,n-m-2,s));}
251 RZ(e=probeis(a,g));
252 if(jt->db)RZ(redef(w,e));
253 wt=AT(w);
254 if(wt&FUNC&&(wv=VAV(w),wv->f)){if(wv->id==CCOLON)wv->flag|=VNAMED; if(jt->glock)wv->flag|=VLOCK;}
255 x=e->val;
256 ASSERT(!(x&&AFRO&AFLAG(x)),EVRO);
257 if(!(x&&AFNJA&AFLAG(x))){
258 RZ(w=ra(AFNJA&AFLAG(w)?w:rca(w)));
259 nvrredef(x);
260 fa(x);
261 e->val=w;
262 }else if(x!=w){ /* replacing mapped data */
263 if(wt&BOX)R smmis(x,w);
264 wn=AN(w); wr=AR(w); m=wn*bp(wt);
265 ASSERT(wt&B01+INT+FL+CMPX+LIT,EVDOMAIN);
266 ASSERT(AM(x)>=m,EVALLOC);
267 AT(x)=wt; AN(x)=wn; AR(x)=wr; ICPY(AS(x),AS(w),wr); MC(AV(x),AV(w),m);
268 }
269 e->sn=jt->slisti;
270 if(jt->stch&&(m<n||jt->local!=g&&jt->stloc!=g))e->flag|=LCH;
271 R mark;
272 } /* a: name; w: value; g: symbol table */