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