![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tahoe.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / franz / tahoe|
Return to tahoe.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / franz / tahoe |
1.1 root 1: /*
2: * tahoe.c
3: * tahoe specific functions
4: *
5: * (c) copyright 1982, Regents of the University of California
6: */
7:
8: #include "global.h"
9: #include <signal.h>
10:
11: mmuladd (a, b, c, m)
12: int a, b, c, m;
13: {
14: asm ("emul 4(fp),8(fp),12(fp),r0");
15: asm ("ediv 16(fp),r0,r2,r0");
16: }
17:
18: Imuldiv(a, b, c, d, e)
19: {
20: asm(" emul 4(fp),8(fp),12(fp),r0");
21: asm(" ediv 16(fp),r0,*20(fp),*24(fp)");
22: }
23:
24: lispval
25: Lpolyev()
26: {
27: register int count;
28: register double *handy, *base;
29: register struct argent *argp;
30: lispval result; int type;
31: char *alloca();
32: Keepxs();
33:
34: error("Lpolyev - Unimplemented or inappropriate CCI function",FALSE);
35: count = 2 * (((int) np) - (int) lbot);
36: if(count == 0)
37: return(inewint(0));
38: if(count == 8)
39: return(lbot->val);
40: base = handy = (double *) alloca(count);
41: for(argp = lbot; argp < np; argp++) {
42: while((type = TYPE(argp->val))!=DOUB && type!=INT)
43: argp->val = (lispval) errorh2(Vermisc,"%%machine-polyev:non-real arg",nil,TRUE,73,lbot,argp->val);
44: if(TYPE(argp->val)==INT) {
45: *handy++ = argp->val->i;
46: } else
47: *handy++ = argp->val->r;
48: }
49: count = count/sizeof(double) - 2;
50: #ifdef vax
51: asm("polyd (r9),r11,8(r9)");
52: asm("movd r0,(r9)");
53: #endif
54: result = newdoub();
55: result->r = *base;
56: Freexs();
57: return(result);
58: }
59:
60: lispval
61: Lrot()
62: {
63: register val;
64: register unsigned long mask2 = -1;
65: register struct argent *mylbot = lbot;
66: long rot;
67:
68: chkarg(2,"rot");
69: if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT))
70: errorh2(Vermisc,
71: "Non ints to rot",
72: nil,FALSE,0,mylbot->val,mylbot[1].val);
73: val = mylbot[0].val->i;
74: rot = mylbot[1].val->i;
75: rot = rot & 0x3f; /* bring it down below one byte in size */
76: mask2 >>= rot;
77: mask2 ^= -1;
78: mask2 &= val;
79: mask2 >>= (32 - rot);
80: val <<= rot;
81: val |= mask2;
82: return( inewint(val));
83: }
84:
85: #include "tahoeframe.h"
86: /* new version of showstack,
87: We will set fp to point where the register fp points.
88: Then fp+2 = saved ap
89: fp+4 = saved pc
90: fp+3 = saved fp
91: ap+1 = first arg
92: If we find that the saved pc is somewhere in the routine eval,
93: then we print the first argument to that eval frame. This is done
94: by looking one beyond the saved ap.
95: */
96: lispval
97: Lshostk()
98: { lispval isho();
99: return(isho(1));
100: }
101: static lispval
102: isho(f)
103: int f;
104: {
105: register struct machframe *myfp; register lispval handy;
106: int **fp; /* this must be the first local */
107: int virgin=1;
108: lispval linterp();
109: lispval _qfuncl(),tynames(); /* locations in qfuncl */
110: extern int plevel,plength;
111:
112: error("C coded showstack - Unimplemented or inappropriate CCI function",FALSE);
113: if(TYPE(Vprinlevel->a.clb) == INT)
114: {
115: plevel = Vprinlevel->a.clb->i;
116: }
117: else plevel = -1;
118: if(TYPE(Vprinlength->a.clb) == INT)
119: {
120: plength = Vprinlength->a.clb->i;
121: }
122: else plength = -1;
123:
124: if(f==1)
125: printf("Forms in evaluation:\n");
126: else
127: printf("Backtrace:\n\n");
128:
129: myfp = (struct machframe *) (&fp +1); /* point to current frame */
130:
131: while(TRUE)
132: {
133: if( (myfp->pc > eval && /* interpreted code */
134: myfp->pc < popnames)
135: ||
136: (myfp->pc > Lfuncal && /* compiled code */
137: myfp->pc < linterp) )
138: {
139: #ifdef vax
140: if(((int) myfp->ap[0]) == 1) /* only if arg given */
141: { handy = (myfp->ap[1]);
142: if(f==1)
143: printr(handy,stdout), putchar('\n');
144: else {
145: if(virgin)
146: virgin = 0;
147: else
148: printf(" -- ");
149: printr((TYPE(handy)==DTPR)?handy->d.car:handy,stdout);
150: }
151: }
152: #endif
153:
154: }
155:
156: if(myfp > myfp->fp) break; /* end of frames */
157: else myfp = myfp->fp;
158: }
159: putchar('\n');
160: return(nil);
161: }
162:
163: /*
164: *
165: * (baktrace)
166: *
167: * baktrace will print the names of all functions being evaluated
168: * from the current one (baktrace) down to the first one.
169: * currently it only prints the function name. Planned is a
170: * list of local variables in all stack frames.
171: * written by jkf.
172: *
173: */
174: lispval
175: Lbaktrace()
176: {
177: isho(0);
178: }
179:
180: /*
181: * (int:showstack 'stack_pointer)
182: * return
183: * nil if at the end of the stack or illegal
184: * ( expresssion . next_stack_pointer) otherwise
185: * where expression is something passed to eval
186: * very tahoe specific
187: */
188:
189:
190: lispval
191: LIshowstack()
192: {
193: int **fp; /* must be the first local variable */
194: register lispval handy;
195: register struct machframe *myfp;
196: lispval retval, Lfuncal(), Ifuncal();
197: lispval (*pc)() = 0;
198: Savestack(2);
199:
200: chkarg(1,"int:showstack");
201:
202: if((TYPE(handy=lbot[0].val) != INT) && (handy != nil))
203: error("int:showstack non fixnum arg", FALSE);
204:
205: if(handy == nil)
206: asm("movab -8(fp),r11"); /* only way I could think of */
207: else
208: myfp = (struct machframe *) handy->i;
209:
210: /* if((int ***)myfp <= &fp) error("int:showstack illegal stack value",FALSE); */
211:
212: while(myfp > 0)
213: {
214: /*fprintf(stderr, "myfp=%x pc=%x fp=%x removed=%d\n", myfp, myfp->pc,
215: myfp->fp, myfp->removed);
216: fflush(stderr);*/
217:
218: if( (pc >= eval && /* interpreted code */
219: pc < popnames)
220: ||
221: (pc >= Ifuncal && /* compiled code */
222: pc < Lfuncal) )
223: {
224: if(myfp->removed == 8) /* only if arg given */
225: {
226: handy = (lispval)(myfp->arg[0]); /* arg to eval */
227:
228: protect(retval=newdot());
229: retval->d.car = handy;
230: if(myfp > myfp->fp)
231: myfp = 0; /* end of frames */
232: else
233: myfp = (struct machframe *) ((char *)myfp->fp - 8);
234: retval->d.cdr = inewint(myfp);
235: return(retval);
236: }
237: }
238: if(myfp > myfp->fp)
239: myfp = 0; /* end of frames */
240: else
241: {pc = myfp->pc;
242: myfp = (struct machframe *) ((char *)myfp->fp - 8);
243: }
244: }
245: return(nil);
246: }
247:
248: #include "frame.h"
249: /*
250: * this code is very similar to ftolsp.
251: * if it gets revised, so should this.
252: */
253: lispval
254: dothunk(func,count,arglist)
255: lispval func;
256: long count;
257: register long *arglist;
258: {
259: lispval save;
260: pbuf pb;
261:
262: if(errp->class==F_TO_FORT)
263: np = errp->svnp;
264: errp = Pushframe(F_TO_LISP,nil,nil);
265: lbot = np;
266: np++->val = func;
267: arglist++; /* this is a vaxism, we'll compensate elsewhere */
268: for(; count > 0; count--)
269: np++->val = inewint(*arglist++);
270: save = Lfuncal();
271: errp = Popframe();
272: return(save);
273: }
274:
275:
276: /*
277: _thcpy:
278: movl (sp),r0
279: pushl ap
280: pushl (r0)+
281: pushl (r0)+
282: calls $3,_dothunk
283: ret */
284:
285: /*
286: * This is thunkmodel:
287: .word 0
288: movl r0,r0
289: callf $4,_thunkstack1
290: .long 0 <count>
291: .long 0 <func>
292: */
293:
294: extern lispval thunkstack1();
295: struct thunk {
296: short mask;
297: char nop[3];
298: char callf[3];
299: lispval (*stack1)();
300: long count;
301: lispval func;
302: } thunkmodel =
303: { 0, { 0xd , 0x50 , 0x50}, {0xfe , 0x4 , 0x9f}, thunkstack1, 0, 0};
304: static char sixwords[] = "01234567890123456789012"; /* trailing 0! */
305:
306: lispval
307: Lmkcth()
308: {
309: register struct argent *mylbot = lbot;
310: register struct thunk *th;
311:
312:
313: chkarg(2,"make-c-thunk");
314: th = (struct thunk *)pinewstr(sixwords);
315: th = (struct thunk *) ((((int) th) | 3) & ~3);
316: *th = thunkmodel;
317: th->func = mylbot->val;
318: th->count = mylbot[1].val->i;
319:
320: return((lispval)th);
321: }
322:
323: /*
324: * This removes the frame from the stack for the thunk
325: * and retrieves various data. (Actually merges it into
326: * its own stack frame).
327: */
328: lispval
329: thunkstack1(retfromthunk)
330: {
331: register int *handy, *midthunk;
332: int *arglist;
333: lispval func;
334: int count;
335:
336: handy = &retfromthunk;
337: arglist = handy + 2; /* should be +3, first is taken as
338: vax arglist count and ignored */
339: handy[-1] = handy[2]; /* unlink frame */
340: midthunk = (int *) handy[-3]; /* our oldpc points to mid thunk */
341: handy[-3] = retfromthunk;
342: handy[-2] += (8 + handy[1]); /* save mask for thunk is 0,
343: adjust bytes to remove from us */
344:
345: count = *midthunk;
346: func = (lispval) midthunk[1];
347: /* you could even merge this in and avoid another callf! */
348: return(dothunk(func,count,arglist));
349: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.