![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to 68k.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 / 68k|
Return to 68k.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz / 68k |
1.1 root 1: #include "global.h"
2: #include <signal.h>
3:
4:
5: mmuladd(a,b,c,m)
6: long a,b,c,m;
7: {
8: long work[2]; char err;
9: emul(a,b,c,work);
10: ediv(work,m,err);
11: return(work[0]);
12: }
13: /*mmuladd (a, b, c, m)
14: int a, b, c, m;
15: {
16: asm ("emul 4(ap),8(ap),12(ap),r0");
17: asm ("ediv 16(ap),r0,r2,r0");
18: }
19:
20: Imuldiv() {
21: asm(" emul 4(ap),8(ap),12(ap),r0");
22: asm(" ediv 16(ap),r0,*20(ap),*24(ap)");
23: }*/
24:
25: Imuldiv(p1,p2,add,dv,quo,rem)
26: long p1, p2, add, dv;
27: long *quo, *rem;
28: {
29: long work[2]; char err;
30:
31: emul(p1,p2,add,work);
32: *quo = ediv(work,dv, &err);
33: *rem = *work;
34: }
35: /*C library -- write
36: nwritten = write(file, buffer, count);
37: nwritten == -1 means error
38: */
39: write(file, buffer, count)
40: char *buffer;
41: {
42: register lispval handy;
43: int retval;
44: if((file != 1) || (Vcntlw->a.clb == nil)) goto top;
45: /* since ^w is non nil, we do not want to print to the terminal,
46: but we must be sure to return a correct value from the write
47: in case there is no write to ptport
48: */
49: retval = count;
50: goto skipit;
51:
52: top:
53:
54: retval = _write(file,buffer,count);
55:
56: skipit:
57: if(file==1) {
58: handy = Vptport->a.clb;
59: if(handy!=nil && TYPE(handy)==PORT && handy->p->_file!=1) {
60: fflush(handy->p);
61: file = handy->p->_file;
62: goto top;
63: }
64: }
65: return(retval);
66: }
67:
68: /*
69: # C library -- read
70:
71: # nread = read(file, buffer, count);
72: #
73: # nread ==0 means eof; nread == -1 means error
74: */
75: #include <errno.h>
76: read(file,buffer,count)
77: {
78: extern int errno;
79: register int Size;
80: again:
81:
82: Size = _read(file,buffer,count);
83: if ((Size >= 0) || (errno != EINTR)) return(Size);
84: if(sigintcnt > 0) sigcall(SIGINT);
85: goto again;
86: }
87:
88: lispval
89: Lpolyev()
90: {
91: register int count;
92: register double *handy, *base;
93: register struct argent *argp;
94: lispval result; int type;
95: char *alloca();
96:
97: count = 2 * (((int) np) - (int) lbot);
98: if(count == 0)
99: return(inewint(0));
100: if(count == 8)
101: return(lbot->val);
102: base = handy = (double *) alloca(count);
103: for(argp = lbot; argp < np; argp++) {
104: while((type = TYPE(argp->val))!=DOUB && type!=INT)
105: argp->val = (lispval) errorh2(Vermisc,"%%machine-polyev:non-real arg",nil,TRUE,73,lbot,argp->val);
106: if(TYPE(argp->val)==INT) {
107: *handy++ = argp->val->i;
108: } else
109: *handy++ = argp->val->r;
110: }
111: count = count/sizeof(double) - 2;
112: /* asm("polyd (r9),r11,8(r9)");
113: asm("movd r0,(r9)");*/
114: result = newdoub();
115: result->r = *base;
116: return(result);
117: }
118:
119: lispval
120: Lrot()
121: {
122: register rot,val; /* these must be the first registers */
123: register struct argent *mylbot = lbot;
124:
125: chkarg(2,"rot");
126: if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT))
127: errorh2(Vermisc,
128: "Non ints to rot",
129: nil,FALSE,0,mylbot->val,mylbot[1].val);
130: val = mylbot[0].val->i;
131: rot = mylbot[1].val->i;
132: rot = rot % 32 ; /* bring it down below one byte in size */
133: if(rot < 0) {
134: rot = -rot;
135: {asm("roll d7,d6");}
136: } else {asm("rorl d7,d6");}
137: return( inewint(val));
138: }
139:
140: myfrexp() { error("myfrexp called", FALSE);}
141: #if os_unisoft | os_unix_ts
142: syscall() { error("vsyscall called", FALSE);}
143: #endif
144:
145: #include "structs.h"
146: prunei(what)
147: register lispval what;
148: {
149: extern struct types int_str;
150: int gstart();
151: if(((long)what) > ((long) gstart)) {
152: --(int_items->i);
153: what->i = (long) int_str.next_free;
154: int_str.next_free = (char *) what;
155: }
156: }
157: #include "68kframe.h"
158: /* new version of showstack,
159: We will set fp to point where the register fp points.
160: If we find that the saved pc is somewhere in the routine eval,
161: then we print the first argument to that eval frame. This is done
162: by looking on the stack.
163: */
164: lispval
165: Lshostk()
166: { lispval isho();
167: return(isho(1));
168: }
169: static lispval
170: isho(f)
171: int f;
172: {
173: register struct machframe *myfp; register lispval handy;
174: int **fp; /* this must be the first local */
175: int virgin=1;
176: lispval linterp(), Ifuncal();
177: lispval _qfuncl(),tynames(); /* locations in qfuncl */
178: extern int plevel,plength;
179:
180: if(TYPE(Vprinlevel->a.clb) == INT)
181: {
182: plevel = Vprinlevel->a.clb->i;
183: }
184: else plevel = -1;
185: if(TYPE(Vprinlength->a.clb) == INT)
186: {
187: plength = Vprinlength->a.clb->i;
188: }
189: else plength = -1;
190:
191: if(f==1)
192: printf("Forms in evaluation:\n");
193: else
194: printf("Backtrace:\n\n");
195:
196: myfp = (struct machframe *) (&fp +1); /* point to current machframe */
197:
198: while(TRUE)
199: {
200: if( (myfp->pc > eval && /* interpreted code */
201: myfp->pc < popnames)
202: ||
203: (myfp->pc > Ifuncal && /* compiled code */
204: myfp->pc < Lfuncal) )
205: {
206: { handy = (myfp->fp->ap[0]);
207: if(f==1)
208: printr(handy,stdout), putchar('\n');
209: else {
210: if(virgin)
211: virgin = 0;
212: else
213: printf(" -- ");
214: printr((TYPE(handy)==DTPR)?handy->d.car:handy,stdout);
215: }
216: }
217:
218: }
219:
220: if(myfp > myfp->fp) break; /* end of frames */
221: else myfp = myfp->fp;
222: }
223: putchar('\n');
224: return(nil);
225: }
226:
227: /*
228: *
229: * (baktrace)
230: *
231: * baktrace will print the names of all functions being evaluated
232: * from the current one (baktrace) down to the first one.
233: * currently it only prints the function name. Planned is a
234: * list of local variables in all stack frames.
235: * written by jkf.
236: *
237: */
238: lispval
239: Lbaktrace()
240: {
241: isho(0);
242: }
243:
244: /*
245: * (int:showstack 'stack_pointer)
246: * return
247: * nil if at the end of the stack or illegal
248: * ( expresssion . next_stack_pointer) otherwise
249: * where expression is something passed to eval
250: * very vax specific
251: */
252: lispval
253: LIshowstack()
254: {
255: int **fp; /* must be the first local variable */
256: register lispval handy;
257: register struct machframe *myfp;
258: lispval retval, Ifuncal();
259: Savestack(2);
260:
261: chkarg(1,"int:showstack");
262:
263: if((TYPE(handy=lbot[0].val) != INT) && (handy != nil))
264: error("int:showstack non fixnum arg", FALSE);
265:
266: if(handy == nil)
267: myfp = (struct machframe *) (&fp +1);
268: else
269: myfp = (struct machframe *) handy->i;
270:
271: if((int ***)myfp <= &fp) error("int:showstack illegal stack value",FALSE);
272: while(myfp > 0)
273: {
274: if( (myfp->pc > eval && /* interpreted code */
275: myfp->pc < popnames)
276: ||
277: (myfp->pc > Ifuncal && /* compiled code */
278: myfp->pc < Lfuncal) )
279: {
280: {
281: handy = (lispval)(myfp->fp->ap[0]); /* arg to eval */
282:
283: protect(retval=newdot());
284: retval->d.car = handy;
285: if(myfp > myfp->fp)
286: myfp = 0; /* end of frames */
287: else
288: myfp = myfp->fp;
289: retval->d.cdr = inewint(myfp);
290: return(retval);
291: }
292: }
293: if(myfp > myfp->fp)
294: myfp = 0; /* end of frames */
295: else
296: myfp = myfp->fp;
297:
298: }
299: return(nil);
300: }
301: #include "frame.h"
302: /*
303: * this code is very similar to ftolsp.
304: * if it gets revised, so should this.
305: */
306: lispval
307: dothunk(func,count)
308: lispval func;
309: long count;
310: {
311: register long *arglist = (& count) + 3;
312: lispval save;
313: pbuf pb;
314: Savestack(1);
315:
316: if(errp->class==F_TO_FORT)
317: np = errp->svnp;
318: errp = Pushframe(F_TO_LISP,nil,nil);
319: lbot = np;
320: np++->val = func;
321: for(; count > 0; count--)
322: np++->val = inewint(*arglist++);
323: save = Lfuncal();
324: errp = Popframe();
325: Restorestack();
326: return(save);
327: }
328: /*
329: _thcpy:
330: movl sp@,a0
331: movl a0@+,sp@-
332: movl a0@+,sp@-
333: jsr _dothunk
334: lea sp@(12),sp
335: rts*/
336: static char fivewords[] = "01234567890123456789";
337:
338: lispval
339: Lmkcth()
340: {
341: register struct argent *mylbot = lbot;
342: register struct thunk {
343: short nop;
344: short jsri;
345: char *thcpy;
346: long count;
347: lispval func;
348: } *th;
349: long handy = (long) pinewstr(fivewords);
350: extern char thcpy[];
351:
352: chkarg(2,"make-c-thunk");
353: handy = ((handy - 1 ) | 3) + 1;
354: th = (struct thunk *) handy;
355: th->nop = 0x4e71;
356: th->jsri = 0x4eb9;
357: th->thcpy = thcpy;
358: th->func = mylbot->val;
359: th->count = mylbot[1].val->i;
360:
361: return((lispval)th);
362: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.