Commit | Line | Data |
---|---|---|
43810ffa BJ |
1 | #include "apl.h" |
2 | ||
3 | funedit(an_editor) | |
4 | register char *an_editor; | |
5 | { | |
6 | register struct item *p; | |
7 | register f; | |
8 | int a, q; | |
9 | ||
10 | p = sp[-1]; | |
11 | if(p->type != LV) | |
12 | error("ed B"); | |
13 | f = fork(); | |
14 | if(f==0) { | |
15 | for(f=3; f<7; f++) | |
16 | close(f); | |
17 | execl(an_editor+4, an_editor+9, p->namep, 0); | |
18 | execl(an_editor, an_editor+9, p->namep, 0); | |
19 | aprintf("exec failure: "); | |
20 | aprintf(an_editor); | |
21 | exit(0); | |
22 | } | |
23 | if(f==-1) | |
24 | error("try again"); | |
25 | a = signal(2, 1); | |
26 | while((q=wait(&integ))!=f) | |
27 | if(q==-1) | |
28 | break; | |
29 | signal(2, a); | |
30 | funload(0); | |
31 | } | |
32 | ||
33 | funload(s) | |
34 | { | |
35 | register struct item *p; | |
36 | register int *f; | |
37 | ||
38 | p = sp[-1]; | |
39 | sp--; | |
40 | if(p->type != LV) | |
41 | error("fnl B"); | |
42 | f = open(p->namep, 0); | |
43 | if((int)f <= 0) | |
44 | error("cannot open"); | |
45 | switch(s) { | |
46 | case 0: | |
47 | fundef(f); | |
48 | return; | |
49 | case 2: | |
50 | clear(); | |
51 | case 1: | |
52 | wsload(f); | |
53 | aputchar('\n'); | |
54 | } | |
55 | } | |
56 | ||
57 | fundef(f) | |
58 | { | |
59 | short i; | |
60 | register char *a, *c; | |
61 | struct nlist *np; | |
62 | int oifile; | |
63 | long b[256]; | |
64 | char bbuf[BUFSIZ]; | |
65 | ||
66 | oifile = ifile; | |
67 | ifile = f; | |
68 | a = rline(0); | |
69 | if(a == 0) | |
70 | error("fnd eof"); | |
71 | c = compile(a, 2); | |
72 | afree(a); | |
73 | if(c == 0) | |
74 | goto out; | |
75 | copy(IN, c+1, &np, 1); | |
76 | erase(np); | |
77 | np->use = c->c[0]; | |
78 | fstat(wfile, b); | |
79 | np->label = b[4]; | |
80 | lseek(wfile, 0,2); | |
81 | lseek(ifile, 0, 0); | |
82 | while((a=read(ifile, bbuf, BUFSIZ)) > 0) | |
83 | write(wfile, bbuf, a); | |
84 | write(wfile, '\0', 1); | |
85 | out: | |
86 | close(ifile); | |
87 | ifile = oifile; | |
88 | } | |
89 | ||
90 | struct lablist labldefs = { 0, 0, 0 }; | |
91 | ||
92 | funcomp(np) | |
93 | struct nlist *np; | |
94 | { | |
95 | register a, c, *p; | |
96 | int err, size; | |
97 | int oifile; | |
98 | ||
99 | ifile = dup(wfile); | |
100 | lseek(ifile, np->label, 0); | |
101 | size = 0; | |
102 | err = 0; | |
103 | labldefs.nextll = 0; | |
104 | now_xeq.name = np->namep; | |
105 | now_xeq.line = 0; | |
106 | afree(rline(0)); /* Rather inefficient */ | |
107 | pass1A: | |
108 | now_xeq.line = size++; | |
109 | if((a=rline(0))==0) { | |
110 | lseek(ifile, np->label, 0); | |
111 | size = 0; | |
112 | now_xeq.line = -1; | |
113 | goto pass1B; | |
114 | } | |
115 | lablchk(a,size); | |
116 | afree(a); | |
117 | goto pass1A; | |
118 | ||
119 | pass1B: | |
120 | ++now_xeq.line; | |
121 | a = rline(0); | |
122 | if(a == 0) { | |
123 | if(err) | |
124 | goto out; | |
125 | p = alloc((size+2)*SINT); | |
126 | *p = size; | |
127 | size = 0; | |
128 | now_xeq.line = -1; | |
129 | lseek(ifile, np->label, 0); | |
130 | err++; | |
131 | goto pass2; | |
132 | } | |
133 | c = compile(a, size==0? 3: 5); | |
134 | size++; | |
135 | afree(a); | |
136 | if(c == 0) { | |
137 | err++; | |
138 | goto pass1B; | |
139 | } | |
140 | afree(c); | |
141 | goto pass1B; | |
142 | ||
143 | pass2: | |
144 | ++now_xeq.line; | |
145 | a = rline(0); | |
146 | if(a == 0) | |
147 | goto pass3; | |
148 | c = compile(a, size==0? 3: 5); | |
149 | size++; | |
150 | afree(a); | |
151 | if(c == 0) | |
152 | goto out; | |
153 | p[size] = c; | |
154 | goto pass2; | |
155 | ||
156 | pass3: | |
157 | now_xeq.line = 0; | |
158 | lseek(ifile, np->label, 0); | |
159 | a = rline(0); | |
160 | if(a == 0) | |
161 | goto out; | |
162 | c = compile(a, 4); | |
163 | afree(a); | |
164 | if(c == 0) | |
165 | goto out; | |
166 | p[size+1] = c; | |
167 | #ifdef SOMED | |
168 | if(debug) { | |
169 | dump(p[1]); | |
170 | dump(c); | |
171 | } | |
172 | #endif | |
173 | np->itemp = p; | |
174 | err = 0; | |
175 | ||
176 | out: | |
177 | unlabel(); | |
178 | close(ifile); | |
179 | ifile = oifile; | |
180 | if(err) | |
181 | error("syntax"); | |
182 | } | |
183 | ||
184 | lablchk(line,line_no) | |
185 | register char *line; | |
186 | { | |
187 | register struct lablist *lblthru = &labldefs; | |
188 | register char *match; | |
189 | int i, len; | |
190 | ||
191 | match = line; | |
192 | while(*match++==' ') | |
193 | continue; | |
194 | line = --match; | |
195 | if(!alpha(*match++)) | |
196 | return; | |
197 | len = 1; | |
198 | while(alpha(*match)||digit(*match)) | |
199 | ++len, ++match; | |
200 | while(*match++==' ') | |
201 | continue; | |
202 | --match; | |
203 | if(*match++!='>') | |
204 | return; | |
205 | match[-1] = '\0'; | |
206 | while(lblthru->nextll) { | |
207 | if(equal(line,lblthru->lname)) { | |
208 | xeq_mark(); | |
209 | aprintf(lblthru->lname); | |
210 | aprintf("> "); | |
211 | error("dup label"); | |
212 | } | |
213 | lblthru = lblthru->nextll; | |
214 | } | |
215 | lblthru = lblthru->nextll = alloc(sizeof(struct lablist)); | |
216 | lblthru->lno = line_no; | |
217 | lblthru->lname = alloc(match-line); | |
218 | lblthru->nextll = 0; | |
219 | match = line; | |
220 | line = lblthru->lname; | |
221 | for(i=0; i<len; ++i) | |
222 | *line++ = *match++; | |
223 | *line = '\0'; | |
224 | } | |
225 | ||
226 | unlabel() | |
227 | { | |
228 | register struct lablist *lblthru, *nextdef; | |
229 | ||
230 | lblthru = labldefs.nextll; | |
231 | while(lblthru) { | |
232 | afree(lblthru->lname); | |
233 | lblthru = lblthru->nextll; | |
234 | } | |
235 | lblthru = &labldefs; | |
236 | while(nextdef=lblthru->nextll) { | |
237 | lblthru = nextdef->nextll; | |
238 | afree(nextdef); | |
239 | if(!lblthru) | |
240 | goto quit; | |
241 | } | |
242 | quit: | |
243 | labldefs.nextll = 0; | |
244 | } | |
245 | ||
246 | ex_fun() | |
247 | { | |
248 | struct nlist *np; | |
249 | register *p, s; | |
250 | int oldflc, oldpcp; | |
251 | ||
252 | pcp += copy(IN, pcp, &np, 1); | |
253 | if(np->itemp == 0) | |
254 | funcomp(np); | |
255 | switch(np->use) { | |
256 | default: | |
257 | error("arg B"); | |
258 | case NF: | |
259 | break; | |
260 | case DF: | |
261 | insulate(-2); | |
262 | case MF: | |
263 | insulate(-1); | |
264 | } | |
265 | p = np->itemp; | |
266 | oldflc = funlc; | |
267 | oldpcp = pcp; | |
268 | funlc = 0; | |
269 | s = *p; | |
270 | loop: | |
271 | funlc++; | |
272 | now_xeq.name = np->namep; | |
273 | now_xeq.line = funlc; | |
274 | execute(p[funlc]); | |
275 | if(intflg) | |
276 | error("I"); | |
277 | if(funlc <= 0 || funlc >= s) { | |
278 | execute(p[s+1]); | |
279 | funlc = oldflc; | |
280 | pcp = oldpcp; | |
281 | now_xeq.name = now_xeq.line = 0; | |
282 | return; | |
283 | } | |
284 | pop(); | |
285 | goto loop; | |
286 | } | |
287 | ||
288 | insulate(arg) | |
289 | { | |
290 | register s, p; | |
291 | ||
292 | p = sp[arg]; | |
293 | switch(p->type) { | |
294 | case DA: | |
295 | case CH: | |
296 | p->index = 0; | |
297 | return; | |
298 | case LV: | |
299 | p = p->itemp; | |
300 | s = newdat(p->type, p->rank, p->size); | |
301 | copy(IN, p->dim, s->dim, p->rank); | |
302 | copy(p->type, p->datap, s->datap, p->size); | |
303 | sp[arg] = s; | |
304 | return; | |
305 | default: | |
306 | error("ins B"); | |
307 | } | |
308 | } | |
309 | ||
310 | ex_arg1() | |
311 | { | |
312 | register struct item *p; | |
313 | struct nlist *np; | |
314 | ||
315 | pcp += copy(IN, pcp, &np, 1); | |
316 | p = fetch1(); | |
317 | sp[-1] = np->itemp; | |
318 | np->itemp = p; | |
319 | np->use = DA; | |
320 | } | |
321 | ||
322 | ex_arg2() | |
323 | { | |
324 | register struct item *p; | |
325 | struct nlist *np; | |
326 | ||
327 | pcp += copy(IN, pcp, &np, 1); | |
328 | p = fetch(sp[-2]); | |
329 | sp[-2] = np->itemp; | |
330 | np->itemp = p; | |
331 | np->use = DA; | |
332 | } | |
333 | ||
334 | ex_auto() | |
335 | { | |
336 | struct nlist *np; | |
337 | ||
338 | pcp += copy(IN, pcp, &np, 1); | |
339 | push(np->itemp); | |
340 | np->itemp = 0; | |
341 | np->use = 0; | |
342 | } | |
343 | ||
344 | ex_rest() | |
345 | { | |
346 | register struct item *p; | |
347 | struct nlist *np; | |
348 | ||
349 | p = fetch1(); | |
350 | pcp += copy(IN, pcp, &np, 1); | |
351 | erase(np); | |
352 | np->itemp = sp[-2]; | |
353 | np->use = 0; | |
354 | if(np->itemp) | |
355 | np->use = DA; | |
356 | sp--; | |
357 | sp[-1] = p; | |
358 | } | |
359 | ||
360 | ex_br0() | |
361 | { | |
362 | ||
363 | funlc = 0; | |
364 | ex_elid(); | |
365 | } | |
366 | ||
367 | ex_br() | |
368 | { | |
369 | register struct item *p; | |
370 | ||
371 | p = fetch1(); | |
372 | if(p->size == 0) | |
373 | return; | |
374 | if(p->size != 1) | |
375 | error("branch C"); | |
376 | funlc = fix(getdat(p)); | |
377 | } |