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: }

Defined functions

Igtpgsz defined in line 520; used 2 times
Lgetaddress defined in line 474; used 2 times
Ndumplisp defined in line 152; never used
pagenorm defined in line 454; used 2 times
pagerand defined in line 452; used 1 times
pageseql defined in line 453; used 1 times
  • in line 39

Defined variables

pagrnd defined in line 14; used 12 times
pagsiz defined in line 14; used 10 times
rcsid defined in line 2; never used

Defined macros

N_name defined in line 470; used 2 times
STASSGN defined in line 471; used 2 times
Last modified: 1985-08-14
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 1281
Valid CSS Valid XHTML 1.0 Strict