```   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
72:
73: #ifdef os_vms
75: #define _write _\$real_write
76: #else
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:  *
116:  *
117:  */
118:
120: {
121:     extern int errno;
122:     register int Size;
123: again:
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 {
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);
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: }
```

Defined functions

Imuldiv defined in line 57; never used
LIshowstack defined in line 279; never used
Lbaktrace defined in line 265; never used
Lmkcth defined in line 368; never used
Lpolyev defined in line 130; never used
Lrot defined in line 163; never used
Lshostk defined in line 190; never used
callg_ defined in line 62; never used
dothunk defined in line 334; never used
exarith defined in line 36; never used
isho defined in line 195; used 3 times
lispval defined in line 62; used 22 times
mmuladd defined in line 50; never used
read defined in line 119; never used
write defined in line 85; never used

Defined variables

fourwords defined in line 366; used 1 times
rcsid defined in line 3; never used

Defined struct's

thunk defined in line 372; used 2 times
• in line 382(2)

Defined macros

READ defined in line 71; used 1 times
• in line 77
WRITE defined in line 70; used 1 times
• in line 78
_read defined in line 77; used 1 times
_write defined in line 78; used 1 times
• in line 98
 Last modified: 1985-08-14 Generated: 2016-12-26 Generated by src2html V0.67 page hit count: 1132