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: }
|
Last modified: 1985-08-14
Generated: 2016-12-26 |
Generated by src2html V0.67
page hit count: 1594 |
|