![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to vax.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz / vax|
Return to vax.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz / vax |
1.1 root 1:
2: #ifndef lint
3: static char *rcsid =
4: "$Header: vax.c,v 1.6 84/02/29 16:45:23 sklower Exp $";
5: #endif
6:
7: /* -[Mon Mar 21 19:35:50 1983 by jkf]-
8: * vax.c $Locker: $
9: * vax specific functions
10: *
11: * (c) copyright 1982, Regents of the University of California
12: */
13:
14: #include "global.h"
15: #include <signal.h>
16: #include "vaxframe.h"
17:
18: /* exarith(a,b,c,lo,hi)
19: * int a,b,c;
20: * int *lo, *hi;
21: * Exact arithmetic.
22: * a,b and c are 32 bit 2's complement integers
23: * calculates x=a*b+c to twice the precision of an int.
24: * In the vax version, the 30 low bits only are returned
25: * in *lo,and the next 32 bits of precision are returned in * hi.
26: * this works since exarith is used either for calculating the sum of
27: * two 32 bit numbers, (which is at most 33 bits), or
28: * multiplying a 30 bit number by a 32 bit numbers,
29: * which has a maximum precision of 62 bits.
30: * If *phi is 0 or -1 then
31: * x doesn't need any more than 31 bits plus sign to describe, so we
32: * place the sign in the high two bits of *lo and return 0 from this
33: * routine. A non zero return indicates that x requires more than 31 bits
34: * to describe.
35: */
36: exarith(a,b,c,phi,plo)
37: int *phi, *plo;
38: {
39: asm(" emul 4(ap),8(ap),12(ap),r2 #r2 = a*b + c to 64 bits");
40: asm(" extzv $0,$30,r2,*20(ap) #get new lo");
41: asm(" extv $30,$32,r2,r0 #get new carry");
42: asm(" beql out # hi = 0, no work necessary");
43: asm(" movl r0,*16(ap) # save hi");
44: asm(" mcoml r0,r0 # Is hi = -1 (it'll fit in one word)");
45: asm(" bneq out # it doesn't");
46: asm(" bisl2 $0xc0000000,*20(ap) # alter low so that it is ok.");
47: asm("out: ret");
48: }
49:
50: mmuladd (a, b, c, m)
51: int a, b, c, m;
52: {
53: asm ("emul 4(ap),8(ap),12(ap),r0");
54: asm ("ediv 16(ap),r0,r2,r0");
55: }
56:
57: Imuldiv() {
58: asm(" emul 4(ap),8(ap),12(ap),r0");
59: asm(" ediv 16(ap),r0,*20(ap),*24(ap)");
60: }
61:
62: callg_(funct,arglist)
63: lispval (*funct)();
64: int *arglist;
65: {
66: asm(" callg *8(ap),*4(ap)");
67: }
68:
69: #include <errno.h>
70: #define WRITE 4
71: #define READ 3
72:
73: #ifdef os_vms
74: #define _read _$real_read
75: #define _write _$real_write
76: #else
77: #define _read(a,b,c) syscall(READ,a,b,c)
78: #define _write(a,b,c) syscall(WRITE,a,b,c)
79: #endif
80:
81: /*C library -- write
82: nwritten = write(file, buffer, count);
83: nwritten == -1 means error
84: */
85: write(file, buffer, count)
86: char *buffer;
87: {
88: register lispval handy;
89: int retval;
90: if((file != 1) || (Vcntlw->a.clb == nil)) goto top;
91: /* since ^w is non nil, we do not want to print to the terminal,
92: but we must be sure to return a correct value from the write
93: in case there is no write to ptport
94: */
95: retval = count;
96: goto skipit;
97: top:
98: retval = _write(file,buffer,count);
99:
100: skipit:
101: if(file==1) {
102: handy = Vptport->a.clb;
103: if(handy!=nil && TYPE(handy)==PORT && handy->p->_file!=1) {
104: fflush(handy->p);
105: file = handy->p->_file;
106: goto top;
107: }
108: }
109: return(retval);
110: }
111:
112: /*
113: *
114: *nread = read(file, buffer, count);
115: *nread ==0 means eof; nread == -1 means error
116: *
117: */
118:
119: read(file,buffer,count)
120: {
121: extern int errno;
122: register int Size;
123: again:
124: Size = _read(file,buffer,count);
125: if ((Size >= 0) || (errno != EINTR)) return(Size);
126: if(sigintcnt > 0) sigcall(SIGINT);
127: goto again;
128: }
129:
130: lispval
131: Lpolyev()
132: {
133: register int count;
134: register double *handy, *base;
135: register struct argent *argp;
136: lispval result; int type;
137: char *alloca();
138: Keepxs();
139:
140: count = 2 * (((int) np) - (int) lbot);
141: if(count == 0)
142: return(inewint(0));
143: if(count == 8)
144: return(lbot->val);
145: base = handy = (double *) alloca(count);
146: for(argp = lbot; argp < np; argp++) {
147: while((type = TYPE(argp->val))!=DOUB && type!=INT)
148: argp->val = (lispval) errorh2(Vermisc,"%%machine-polyev:non-real arg",nil,TRUE,73,lbot,argp->val);
149: if(TYPE(argp->val)==INT) {
150: *handy++ = argp->val->i;
151: } else
152: *handy++ = argp->val->r;
153: }
154: count = count/sizeof(double) - 2;
155: asm("polyd (r9),r11,8(r9)");
156: asm("movd r0,(r9)");
157: result = newdoub();
158: result->r = *base;
159: Freexs();
160: return(result);
161: }
162:
163: lispval
164: Lrot()
165: {
166: register rot,val; /* these must be the first registers */
167: register struct argent *mylbot = lbot;
168:
169: chkarg(2,"rot");
170: if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT))
171: errorh2(Vermisc,
172: "Non ints to rot",
173: nil,FALSE,0,mylbot->val,mylbot[1].val);
174: val = mylbot[0].val->i;
175: rot = mylbot[1].val->i;
176: rot = rot % 32 ; /* bring it down below one byte in size */
177: asm(" rotl r11,r10,r10 "); /* rotate val by rot and put back in val */
178: return( inewint(val));
179: }
180: /* new version of showstack,
181: We will set fp to point where the register fp points.
182: Then fp+2 = saved ap
183: fp+4 = saved pc
184: fp+3 = saved fp
185: ap+1 = first arg
186: If we find that the saved pc is somewhere in the routine eval,
187: then we print the first argument to that eval frame. This is done
188: by looking one beyond the saved ap.
189: */
190: lispval
191: Lshostk()
192: { lispval isho();
193: return(isho(1));
194: }
195: static lispval
196: isho(f)
197: int f;
198: {
199: register struct machframe *myfp; register lispval handy;
200: int **fp; /* this must be the first local */
201: int virgin=1;
202: lispval linterp();
203: lispval _qfuncl(),tynames(); /* locations in qfuncl */
204: extern int plevel,plength;
205:
206: if(TYPE(Vprinlevel->a.clb) == INT)
207: {
208: plevel = Vprinlevel->a.clb->i;
209: }
210: else plevel = -1;
211: if(TYPE(Vprinlength->a.clb) == INT)
212: {
213: plength = Vprinlength->a.clb->i;
214: }
215: else plength = -1;
216:
217: if(f==1)
218: printf("Forms in evaluation:\n");
219: else
220: printf("Backtrace:\n\n");
221:
222: myfp = (struct machframe *) (&fp +1); /* point to current frame */
223:
224: while(TRUE)
225: {
226: if( (myfp->pc > eval && /* interpreted code */
227: myfp->pc < popnames)
228: ||
229: (myfp->pc > Lfuncal && /* compiled code */
230: myfp->pc < linterp) )
231: {
232: if(((int) myfp->ap[0]) == 1) /* only if arg given */
233: { handy = (myfp->ap[1]);
234: if(f==1)
235: printr(handy,stdout), putchar('\n');
236: else {
237: if(virgin)
238: virgin = 0;
239: else
240: printf(" -- ");
241: printr((TYPE(handy)==DTPR)?handy->d.car:handy,stdout);
242: }
243: }
244:
245: }
246:
247: if(myfp > myfp->fp) break; /* end of frames */
248: else myfp = myfp->fp;
249: }
250: putchar('\n');
251: return(nil);
252: }
253:
254: /*
255: *
256: * (baktrace)
257: *
258: * baktrace will print the names of all functions being evaluated
259: * from the current one (baktrace) down to the first one.
260: * currently it only prints the function name. Planned is a
261: * list of local variables in all stack frames.
262: * written by jkf.
263: *
264: */
265: lispval
266: Lbaktrace()
267: {
268: isho(0);
269: }
270:
271: /*
272: * (int:showstack 'stack_pointer)
273: * return
274: * nil if at the end of the stack or illegal
275: * ( expresssion . next_stack_pointer) otherwise
276: * where expression is something passed to eval
277: * very vax specific
278: */
279: lispval
280: LIshowstack()
281: {
282: int **fp; /* must be the first local variable */
283: register lispval handy;
284: register struct machframe *myfp;
285: lispval retval, Lfuncal(), Ifuncal();
286: Savestack(2);
287:
288: chkarg(1,"int:showstack");
289:
290: if((TYPE(handy=lbot[0].val) != INT) && (handy != nil))
291: error("int:showstack non fixnum arg", FALSE);
292:
293: if(handy == nil)
294: myfp = (struct machframe *) (&fp +1);
295: else
296: myfp = (struct machframe *) handy->i;
297:
298: if((int ***)myfp <= &fp) error("int:showstack illegal stack value",FALSE);
299: while(myfp > 0)
300: {
301: if( (myfp->pc > eval && /* interpreted code */
302: myfp->pc < popnames)
303: ||
304: (myfp->pc > Ifuncal && /* compiled code */
305: myfp->pc < Lfuncal) )
306: {
307: if(((int) myfp->ap[0]) == 1) /* only if arg given */
308: {
309: handy = (lispval)(myfp->ap[1]); /* arg to eval */
310:
311: protect(retval=newdot());
312: retval->d.car = handy;
313: if(myfp > myfp->fp)
314: myfp = 0; /* end of frames */
315: else
316: myfp = myfp->fp;
317: retval->d.cdr = inewint(myfp);
318: return(retval);
319: }
320: }
321: if(myfp > myfp->fp)
322: myfp = 0; /* end of frames */
323: else
324: myfp = myfp->fp;
325:
326: }
327: return(nil);
328: }
329: #include "frame.h"
330: /*
331: * this code is very similar to ftolsp.
332: * if it gets revised, so should this.
333: */
334: lispval
335: dothunk(func,count,arglist)
336: lispval func;
337: long count;
338: register long *arglist;
339: {
340:
341: lispval save;
342: pbuf pb;
343: Savestack(1);
344:
345: if(errp->class==F_TO_FORT)
346: np = errp->svnp;
347: errp = Pushframe(F_TO_LISP,nil,nil);
348: lbot = np;
349: np++->val = func;
350: arglist++;
351: for(; count > 0; count--)
352: np++->val = inewint(*arglist++);
353: save = Lfuncal();
354: errp = Popframe();
355: Restorestack();
356: return(save);
357: }
358: /*
359: _thcpy:
360: movl (sp),r0
361: pushl ap
362: pushl (r0)+
363: pushl (r0)+
364: calls $3,_dothunk
365: ret */
366: static char fourwords[] = "0123456789012345";
367:
368: lispval
369: Lmkcth()
370: {
371: register struct argent *mylbot = lbot;
372: register struct thunk {
373: short mask;
374: short jsri;
375: char *thcpy;
376: long count;
377: lispval func;
378: } *th;
379: extern char thcpy[];
380:
381: chkarg(2,"make-c-thunk");
382: th = (struct thunk *)pinewstr(fourwords);
383: th->mask = 0;
384: th->jsri = 0x9f16;
385: th->thcpy = thcpy;
386: th->func = mylbot->val;
387: th->count = mylbot[1].val->i;
388:
389: return((lispval)th);
390: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.