![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fex3.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|
Return to fex3.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid = "$Header: fex3.c,v 1.15 85/03/13 17:18:29 sklower Exp $";
3: #endif
4: /* -[Sat Apr 9 17:03:02 1983 by layer]-
5: * fex3.c $Locker: $
6: * nlambda functions
7: *
8: * (c) copyright 1982, Regents of the University of California
9: */
10:
11:
12: #include "global.h"
13: extern char *gstab();
14: static int pagsiz, pagrnd;
15:
16:
17: /*
18: *Ndumplisp -- create executable version of current state of this lisp.
19: */
20: #ifndef os_vms
21: #include "aout.h"
22:
23: lispval
24: Ndumplisp()
25: {
26: register struct exec *workp;
27: register lispval argptr, temp;
28: register char *fname;
29: extern int reborn;
30: struct exec work, old;
31: extern int dmpmode,usehole;
32: extern char etext[], *curhbeg;
33: int descrip, des2, ax,mode;
34: extern int holesize;
35: char tbuf[BUFSIZ];
36: long count, lseek();
37:
38:
39: pageseql();
40: pagsiz = Igtpgsz();
41: pagrnd = pagsiz - 1;
42:
43: /* dump mode is kept in decimal (which looks like octal in dmpmode)
44: and is changeable via (sstatus dumpmode n) where n is 413 or 410
45: base 10
46: */
47: if(dmpmode == 413) mode = 0413;
48: else if(dmpmode == 407) mode = 0407;
49: else mode = 0410;
50:
51: workp = &work;
52: workp->a_magic = mode;
53: #ifdef os_masscomp
54: workp->a_stamp = 1;
55: #endif
56:
57: if(holesize) { /* was ifdef HOLE */
58: curhbeg = (char *) (1 + (pagrnd | ((int)curhbeg)-1));
59: workp->a_text = (unsigned long)curhbeg - (unsigned long)OFFSET;
60: workp->a_data = (unsigned) sbrk(0) - workp->a_text - OFFSET;
61: } else {
62: if(mode==0407)
63: workp->a_text = ((int)etext) - OFFSET;
64: else
65: workp->a_text = 1 + ((((int)etext)-1-OFFSET) | pagrnd);
66: workp->a_data = (int) sbrk(0) - ((int)curhbeg);
67: }
68: workp->a_bss = 0;
69: workp->a_syms = 0;
70: workp->a_entry = (unsigned) gstart();
71: workp->a_trsize = 0;
72: workp->a_drsize = 0;
73:
74: fname = "savedlisp"; /*set defaults*/
75: reborn = (int) CNIL;
76: argptr = lbot->val;
77: if (argptr != nil) {
78: temp = argptr->d.car;
79: if((TYPE(temp))==ATOM)
80: fname = temp->a.pname;
81: }
82: des2 = open(gstab(),0);
83: if(des2 >= 0) {
84: if(read(des2,(char *)&old,sizeof(old))>=0)
85: work.a_syms = old.a_syms;
86: }
87: descrip=creat(fname,0777); /*doit!*/
88: if(-1==write(descrip,(char *)workp,sizeof(work)))
89: {
90: close(descrip);
91: error("Dumplisp header failed",FALSE);
92: }
93: if(mode == 0413) lseek(descrip,(long)pagsiz,0);
94: if( -1==write(descrip,(char *)nil,(int)workp->a_text) )
95: {
96: close(descrip);
97: error("Dumplisp text failed",FALSE);
98: }
99: if( -1==write(descrip,(char *)curhbeg,(int)workp->a_data) )
100: {
101: close(descrip);
102: error("Dumplisp data failed",FALSE);
103: }
104: if(des2>0 && work.a_syms) {
105: count = old.a_text + old.a_data + (old.a_magic == 0413 ? pagsiz
106: : sizeof(old));
107: if(-1==lseek(des2,count,0))
108: error("Could not seek to stab",FALSE);
109: for(count = old.a_syms;count > 0; count -=BUFSIZ) {
110: ax = read(des2,tbuf,(int)(count < BUFSIZ ? count : BUFSIZ));
111: if(ax==0) {
112: printf("Unexpected end of syms",count);
113: fflush(stdout);
114: break;
115: } else if(ax > 0)
116: write(descrip,tbuf,ax);
117: else
118: error("Failure to write dumplisp stab",FALSE);
119: }
120: #if ! (os_unix_ts | os_unisoft)
121: if(-1 == lseek(des2,(long)
122: ((old.a_magic == 0413 ? pagsiz : sizeof(old))
123: + old.a_text + old.a_data
124: + old.a_trsize + old.a_drsize + old.a_syms),
125: 0))
126: error(" Could not seek to string table ",FALSE);
127: for( ax = 1 ; ax > 0;) {
128: ax = read(des2,tbuf,BUFSIZ);
129: if(ax > 0)
130: write(descrip,tbuf,ax);
131: else if (ax < 0)
132: error("Error in string table read ",FALSE);
133: }
134: #endif
135: }
136: close(descrip);
137: if(des2>0) close(des2);
138: reborn = 0;
139:
140: pagenorm();
141:
142: return(nil);
143: }
144:
145:
146: /*** VMS version of Ndumplisp ***/
147: #else
148: #include "aout.h"
149: #undef protect
150: #include <vms/vmsexe.h>
151:
152: lispval
153: Ndumplisp()
154: {
155: register struct exec *workp;
156: register lispval argptr, temp;
157: char *fname;
158: register ISD *Isd;
159: register int i;
160: extern lispval reborn;
161: struct exec work,old;
162: extern etext;
163: extern int dmpmode,holend,curhbeg,usehole,holesize;
164: int extra_cref_page = 0;
165: char *start_of_data;
166: int descrip, des2, count, ax,mode;
167: char buf[5000],stabname[100],tbuf[BUFSIZ];
168: int fp,fp1;
169: union {
170: char Buffer[512];
171: struct {
172: IHD Ihd;
173: IHA Iha;
174: IHS Ihs;
175: IHI Ihi;
176: } Header;
177: } Buffer; /* VMS Header */
178:
179: /*
180: * Dumpmode is always 413!!
181: */
182: mode = 0413;
183: pagsiz = Igtpgsz();
184: pagrnd = pagsiz - 1;
185:
186: workp = &work;
187: workp->a_magic = mode;
188: if (holesize) {
189: workp->a_text =
190: ((unsigned)curhbeg) & (~pagrnd);
191: if (((unsigned)curhbeg) & pagrnd) extra_cref_page = 1;
192: start_of_data = (char *)
193: (((((unsigned) (&holend)) -1) & (~pagrnd)) + pagsiz);
194: } else {
195: workp->a_text =
196: ((((unsigned) (&etext)) -1) & (~pagrnd)) + pagsiz;
197: start_of_data = (char *)workp->a_text;
198: }
199: workp->a_data =
200: (unsigned) sbrk(0) - (unsigned)start_of_data;
201: workp->a_bss = 0;
202: workp->a_syms = 0;
203: workp->a_entry = (unsigned) gstart();
204: workp->a_trsize = 0;
205: workp->a_drsize = 0;
206:
207: fname = "savedlisp"; /* set defaults */
208: reborn = CNIL;
209: argptr = lbot->val;
210: if (argptr != nil) {
211: temp = argptr->d.car;
212: if((TYPE(temp))==ATOM)
213: fname = temp->a.pname;
214: }
215: /*
216: * Open the new executable file
217: */
218: strcpy(buf,fname);
219: if (index(buf,'.') == 0) strcat(buf,".exe");
220: if ((descrip = creat(buf,0777)) < 0) error("Dumplisp failed",FALSE);
221: /*
222: * Create the VMS header
223: */
224: for(i = 0; i < 512; i++) Buffer.Buffer[i] = 0; /* Clear Header */
225: Buffer.Header.Ihd.size = sizeof(Buffer.Header);
226: Buffer.Header.Ihd.activoff = sizeof(IHD);
227: Buffer.Header.Ihd.symdbgoff = sizeof(IHD) + sizeof(IHA);
228: Buffer.Header.Ihd.imgidoff = sizeof(IHD) + sizeof(IHA) + sizeof(IHS);
229: Buffer.Header.Ihd.majorid[0] = '0';
230: Buffer.Header.Ihd.majorid[1] = '2';
231: Buffer.Header.Ihd.minorid[0] = '0';
232: Buffer.Header.Ihd.minorid[1] = '2';
233: Buffer.Header.Ihd.imgtype = IHD_EXECUTABLE;
234: Buffer.Header.Ihd.privreqs[0] = -1;
235: Buffer.Header.Ihd.privreqs[1] = -1;
236: Buffer.Header.Ihd.lnkflags.nopobufs = 1;
237: Buffer.Header.Ihd.imgiocnt = 250;
238:
239: Buffer.Header.Iha.tfradr1 = SYS$IMGSTA;
240: Buffer.Header.Iha.tfradr2 = workp->a_entry;
241:
242: strcpy(Buffer.Header.Ihi.imgnam+1,"SAVEDLISP");
243: Buffer.Header.Ihi.imgnam[0] = 9;
244: Buffer.Header.Ihi.imgid[0] = 0;
245: Buffer.Header.Ihi.imgid[1] = '0';
246: sys$gettim(Buffer.Header.Ihi.linktime);
247: strcpy(Buffer.Header.Ihi.linkid+1," Opus 38");
248: Buffer.Header.Ihi.linkid[0] = 8;
249:
250: Isd = (ISD *)&Buffer.Buffer[sizeof(Buffer.Header)];
251: /* Text ISD */
252: Isd->size = ISDSIZE_TEXT;
253: Isd->pagcnt = workp->a_text >> 9;
254: Isd->vpnpfc.vpn = 0;
255: Isd->flags.type = ISD_NORMAL;
256: Isd->vbn = 3;
257: Isd = (ISD *)((char *)Isd + Isd->size);
258: /* Hole ISDs (if necessary) */
259: if (usehole) {
260: /* Copy on Ref ISD for possible extra text page */
261: if(extra_cref_page) {
262: Isd->size = ISDSIZE_TEXT;
263: Isd->pagcnt = 1;
264: Isd->vpnpfc.vpn = (((unsigned)curhbeg) & (~pagrnd)) >> 9;
265: Isd->flags.type = ISD_NORMAL;
266: Isd->flags.crf = 1;
267: Isd->flags.wrt = 1;
268: Isd->vbn = (workp->a_text >> 9) + 3;
269: Isd = (ISD *)((char *)Isd + Isd->size);
270: }
271: /* Demand Zero ISD for rest of Hole */
272: Isd->size = ISDSIZE_DZRO;
273: Isd->pagcnt =
274: ((((unsigned)&holend)
275: - (unsigned)curhbeg) & (~pagrnd)) >> 9;
276: Isd->vpnpfc.vpn =
277: ((((unsigned)curhbeg) & (~pagrnd)) >> 9) + extra_cref_page;
278: Isd->flags.type = ISD_NORMAL;
279: Isd->flags.dzro = 1;
280: Isd->flags.wrt = 1;
281: Isd = (ISD *)((char *)Isd + Isd->size);
282: }
283: /* Data ISD */
284: Isd->size = ISDSIZE_TEXT;
285: Isd->pagcnt = workp->a_data >> 9;
286: Isd->vpnpfc.vpn = ((unsigned)start_of_data) >> 9;
287: Isd->flags.type = ISD_NORMAL;
288: Isd->flags.crf = 1;
289: Isd->flags.wrt = 1;
290: Isd->vbn = (workp->a_text >> 9) + 3;
291: if (holesize) {
292: /*
293: * Correct the Data ISD
294: */
295: Isd->vbn += extra_cref_page;
296: }
297: Isd = (ISD *)((char *)Isd + Isd->size);
298: /* Stack ISD */
299: Isd->size = ISDSIZE_DZRO;
300: Isd->pagcnt = ISDSTACK_SIZE;
301: Isd->vpnpfc.vpn = ISDSTACK_BASE;
302: Isd->flags.type = ISD_USERSTACK;
303: Isd->flags.dzro = 1;
304: Isd->flags.wrt = 1;
305: Isd = (ISD *)((char *)Isd + Isd->size);
306: /* End of ISD List */
307: Isd->size = 0;
308: Isd = (ISD *)((char *)Isd + 2);
309: /*
310: * Make the rest of the header -1s
311: */
312: for (i = ((char *)Isd - Buffer.Buffer); i < 512; i++)
313: Buffer.Buffer[i] = -1;
314: /*
315: * Write the VMS Header
316: */
317: if (write(descrip,Buffer.Buffer,512) == -1)
318: error("Dumplisp failed",FALSE);
319: #if EUNICE_UNIX_OBJECT_FILE_CFASL
320: /*
321: * Get the UNIX symbol table file header
322: */
323: des2 = open(gstab(),0);
324: if (des2 >= 0) {
325: old.a_magic = 0;
326: if (read(des2,(char *)&old,sizeof(old)) >= 0) {
327: if (N_BADMAG(old)) {
328: lseek(des2,512,0); /* Try block #1 */
329: read(des2,(char *)&old,sizeof(old));
330: }
331: if (!N_BADMAG(old)) work.a_syms = old.a_syms;
332: }
333: }
334: #endif EUNICE_UNIX_OBJECT_FILE_CFASL
335: /*
336: * Update the UNIX header so that the extra cref page is
337: * considered part of data space.
338: */
339: if (extra_cref_page) work.a_data += 512;
340: /*
341: * Write the UNIX header
342: */
343: if (write(descrip,&work,sizeof(work)) == -1)
344: error("Dumplisp failed",FALSE);
345: /*
346: * seek to 1024 (end of headers)
347: */
348: if (lseek(descrip,1024,0) == -1)
349: error("Dumplisp failed",FALSE);
350: /*
351: * write the world
352: */
353: if (write(descrip,0,workp->a_text) == -1)
354: error("Dumplisp failed",FALSE);
355: if (extra_cref_page)
356: if (write(descrip,(((unsigned)curhbeg) & pagrnd), pagsiz) == -1)
357: error("Dumplisp failed",FALSE);
358: if (write(descrip,start_of_data,workp->a_data) == -1)
359: error("Dumplisp failed",FALSE);
360:
361: #if !EUNICE_UNIX_OBJECT_FILE_CFASL
362: /*
363: * VMS OBJECT files: We are done with the executable file
364: */
365: close(descrip);
366: /*
367: * Now try to write the symbol table file!
368: */
369: strcpy(buf,gstab());
370:
371: strcpy(stabname,fname);
372: if (index(stabname,'.') == 0) strcat(stabname,".stb");
373: else strcpy(index(stabname,'.'), ".stb");
374:
375: /* Use Link/Unlink to rename the symbol table */
376: if (!strncmp(gstab(),"tmp:",4))
377: if (link(buf,stabname) >= 0)
378: if (unlink(buf) >= 0) return(nil);
379:
380: /* Copy the symbol table */
381: if ((fp = open(buf,0)) < 0)
382: error("Symbol table file not there\n",FALSE);
383: fp1 = creat(stabname,0666,"var");
384: while((i = read(fp,buf,5000)) > 0)
385: if (write(fp1,buf,i) == -1) {
386: close(fp); close(fp1);
387: error("Error writing symbol table\n",FALSE);
388: }
389: close(fp); close(fp1);
390: if (i < 0) error("Error reading symbol table\n",FALSE);
391: if (!strncmp(gstab(),"tmp:",4)) unlink(gstab);
392: /*
393: * Done
394: */
395: reborn = 0;
396: return(nil);
397: #else EUNICE_UNIX_OBJECT_FILE_CFASL
398: /*
399: * UNIX OBJECT files: append the new symbol table
400: */
401: if(des2>0 && work.a_syms) {
402: count = old.a_text + old.a_data + (old.a_magic == 0413 ? 1024
403: : sizeof(old));
404: if(-1==lseek(des2,count,0))
405: error("Could not seek to stab",FALSE);
406: for(count = old.a_syms;count > 0; count -=BUFSIZ) {
407: ax = read(des2,tbuf,(int)(count < BUFSIZ ? count : BUFSIZ));
408: if(ax==0) {
409: printf("Unexpected end of syms",count);
410: fflush(stdout);
411: break;
412: } else if(ax > 0)
413: write(descrip,tbuf,ax);
414: else
415: error("Failure to write dumplisp stab",FALSE);
416: }
417: if(-1 == lseek(des2,(long)
418: ((old.a_magic == 0413 ? 1024 : sizeof(old))
419: + old.a_text + old.a_data
420: + old.a_trsize + old.a_drsize + old.a_syms),
421: 0))
422: error(" Could not seek to string table ",FALSE);
423: for( ax = 1 ; ax > 0;) {
424: ax = read(des2,tbuf,BUFSIZ);
425: if(ax > 0)
426: write(descrip,tbuf,ax);
427: else if (ax < 0)
428: error("Error in string table read ",FALSE);
429: }
430: }
431: close(descrip);
432: if(des2>0) close(des2);
433: reborn = 0;
434:
435: return(nil);
436: #endif EUNICE_UNIX_OBJECT_FILE_CFASL
437: }
438: #endif
439: #if (os_4_1 | os_4_1a | os_4_1c | os_4_2| os_4_3)
440:
441: #if (os_4_2 | os_4_3)
442: #include <sys/vadvise.h>
443: #else
444: #include <vadvise.h>
445: #endif
446:
447: pagerand() { vadvise(VA_ANOM); }
448: pageseql() { vadvise(VA_SEQL); }
449: pagenorm() { vadvise(VA_NORM); }
450: #endif
451: #if (os_unisoft | os_vms | os_unix_ts | os_masscomp)
452: pagerand() { }
453: pageseql() { }
454: pagenorm() { }
455: #endif
456:
457: /* getaddress --
458: *
459: * (getaddress '|_entry1| 'fncname1 '|_entry2| 'fncname2 ...)
460: *
461: * binds value of symbol |_entry1| to function defition of atom fncname1, etc.
462: *
463: * returns fnc-binding of fncname1.
464: *
465: */
466: #if os_unisoft || os_unix_ts
467: #define N_name n_name
468: #define STASSGN(p,q) strncpy(NTABLE[(p)].n_name,(q),8)
469: #else
470: #define N_name n_un.n_name
471: #define STASSGN(p,q) (NTABLE[p].N_name = (q))
472: #endif
473:
474: lispval
475: Lgetaddress(){
476: register struct argent *mlbot = lbot;
477: register lispval work;
478: register int numberofargs, i;
479: char ostabf[128];
480: struct nlist NTABLE[100];
481: lispval dispget();
482:
483: Savestack(4);
484:
485: if(np-lbot == 2) protect(nil); /* allow 2 args */
486: numberofargs = (np - lbot)/3;
487: if(numberofargs * 3 != np-lbot)
488: error("getaddress: arguments must come in triples ",FALSE);
489:
490: for ( i=0; i<numberofargs; i++,mlbot += 3) {
491: NTABLE[i].n_value = 0;
492: mlbot[0].val = verify(mlbot[0].val,"Incorrect entry specification for binding");
493: STASSGN(i,(char *) mlbot[0].val);
494: while(TYPE(mlbot[1].val) != ATOM)
495: mlbot[1].val = errorh1(Vermisc,
496: "Bad associated atom name for binding",
497: nil,TRUE,0,mlbot[1].val);
498: mlbot[2].val = dispget(mlbot[2].val,"getaddress: Incorrect discipline specification ",(lispval)Vsubrou->a.pname);
499: }
500: STASSGN(numberofargs,"");
501: strncpy(ostabf,gstab(),128);
502: if ( nlist(ostabf,NTABLE) == -1 ) {
503: errorh1(Vermisc,"Getaddress: Bad file",nil,FALSE,0,inewstr(ostabf));
504: } else
505: for (i=0,mlbot=lbot+1; i<numberofargs; i++,mlbot+=3) {
506: if ( NTABLE[i].n_value == 0 )
507: fprintf(stderr,"Undefined symbol: %s\n",
508: NTABLE[i].N_name);
509: else {
510: work= newfunct();
511: work->bcd.start = (lispval (*) ())NTABLE[i].n_value;
512: work->bcd.discipline = mlbot[1].val;
513: mlbot->val->a.fnbnd = work;
514: }
515: };
516: Restorestack();
517: return(lbot[1].val->a.fnbnd);
518: };
519:
520: Igtpgsz()
521: {
522: #if (os_4_1c | os_4_2 | os_4_3)
523: return(getpagesize());
524: #else
525: #if (vax_eunice_vms | os_unisoft)
526: return(512);
527: #else
528: #if os_masscomp
529: return(4096);
530: #else
531: return(1024);
532: #endif
533: #endif
534: #endif
535: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.