Return to fex4.c CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz

Annotation of 42BSD/ucb/lisp/franz/fex4.c, revision 1.1

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: fex4.c 1.3 83/07/06 12:20:20 layer Exp $";
        !             4: #endif
        !             5: 
        !             6: /*                                     -[Sat Jan 29 12:40:56 1983 by jkf]-
        !             7:  *     fex4.c                          $Locker:  $
        !             8:  * nlambda functions
        !             9:  *
        !            10:  * (c) copyright 1982, Regents of the University of California
        !            11:  */
        !            12: 
        !            13: 
        !            14: #include "global.h"
        !            15: #include "lfuncs.h"
        !            16: #include "chkrtab.h"
        !            17: #include <signal.h>
        !            18: #include <sys/types.h>
        !            19: 
        !            20: #ifdef os_4_2
        !            21: #include <sys/time.h>
        !            22: #else
        !            23: #include <time.h>
        !            24: #endif
        !            25: 
        !            26: /* this is now a lambda function instead of a nlambda.
        !            27:    the only reason that it wasn't a lambda to begin with is that 
        !            28:    the person who wrote it didn't know how to write a lexpr
        !            29:                                                - jkf
        !            30: */
        !            31: lispval
        !            32: Lsyscall() {
        !            33:        register lispval temp;
        !            34:        register struct argent *aptr;
        !            35:        register int acount = 1;
        !            36:        extern syscall();
        !            37:        int args[50];
        !            38:        Savestack(3);
        !            39: 
        !            40:        /* there must be at least one argument */
        !            41: 
        !            42:        if (np==lbot) { chkarg(1,"syscall"); }
        !            43: 
        !            44:        aptr = lbot;
        !            45:        temp = lbot->val;
        !            46:        if (TYPE(temp) != INT) {
        !            47:                Restorestack();
        !            48:                return(error("syscall: bad first argument ", FALSE));
        !            49:        }
        !            50:        args[acount++] = temp->i;
        !            51:        while( ++aptr < np && acount < 48) {
        !            52:                temp = aptr->val;
        !            53:                switch(TYPE(temp)) {
        !            54: 
        !            55:                        case ATOM:      
        !            56:                                args[acount++] = (int)temp->a.pname;
        !            57:                                break;
        !            58: 
        !            59:                        case STRNG:
        !            60:                                args[acount++] = (int) temp;
        !            61:                                break;
        !            62: 
        !            63:                        case INT:
        !            64:                                args[acount++] = (int)temp->i;
        !            65:                                break;
        !            66: 
        !            67:                        default:
        !            68:                                Restorestack();
        !            69:                                return(error("syscall: arg not symbol, string or fixnum", FALSE));
        !            70:                }
        !            71:        }
        !            72: 
        !            73:        Restorestack();
        !            74:        args[0] = acount - 1;
        !            75:        return(inewint(callg_(syscall,args)));
        !            76: }
        !            77: 
        !            78: /* eval-when: this has the form (eval-when <list> <form1> <form2> ...)
        !            79:    where the list may contain any combination of `eval', `load', `compile'.
        !            80:    The interpreter (us) looks for the atom `eval', if it is present
        !            81:    we treat the rest of the forms as a progn.
        !            82: */
        !            83: 
        !            84: lispval
        !            85: Nevwhen()
        !            86: {
        !            87:        register lispval handy;
        !            88:        register lispval handy2;
        !            89:        Savestack(2);
        !            90: 
        !            91:        for (handy=(lbot->val)->d.car ; handy != nil ; handy = handy->d.cdr) {
        !            92:           if (handy->d.car == (lispval) Veval) {
        !            93:                lbot=np;
        !            94:                protect(((lbot-1)->val)->d.cdr);
        !            95:                handy2 = Nprogn();
        !            96:                Restorestack();
        !            97:                return(handy2);
        !            98:            }
        !            99:        }
        !           100: 
        !           101: 
        !           102:        Restorestack();
        !           103:        return(nil);    /* eval not seen */
        !           104: }
        !           105: 
        !           106: 
        !           107: /*     Status functions. 
        !           108:  *  These operate on the statuslist stlist which has the form:
        !           109:  *     ( status_elem_1 status_elem_2 status_elem_3 ...)
        !           110:  *  where each status element has the form:
        !           111:  *     ( name readcode setcode .  readvalue)
        !           112:  *  where
        !           113:  *     name - name of the status feature (the first arg to the status
        !           114:  *             function).
        !           115:  *     readcode - fixnum which tells status how to read the value of
        !           116:  *             this status name.  The codes are #defined.
        !           117:  *     setcode - fixnum which tells sstatus how to set the value of
        !           118:  *             this status name
        !           119:  *     readvalue - the value of the status feature is usually stored
        !           120:  *             here.
        !           121:  *     
        !           122:  * Readcodes:
        !           123:  *
        !           124:  *     ST_READ - if no second arg, return readvalue.
        !           125:  *               if the second arg is given, we return t if it is eq to
        !           126:  *               the readvalue.
        !           127:  *     ST_FEATR - used in (status feature xxx) where we test for xxx being
        !           128:  *               in the status features list
        !           129:  *     ST_SYNT - used in (status syntax c) where we return c's syntax code
        !           130:  *     ST_INTB - read stattab entry
        !           131:  *     ST_NFETR - used in (status nofeature xxx) where we test for xxx not
        !           132:  *               being in the status features list
        !           133:  *     ST_DMPR - read the dumpmode 
        !           134:  *     ST_UNDEF - return the undefined functions in the transfer table
        !           135:  * 
        !           136:  * Setcodes:
        !           137:  *     ST_NO -  if not allowed to set this status through sstatus.
        !           138:  *     ST_SET - if the second arg is made the readvalue.
        !           139:  *     ST_FEATW - for (sstatus feature xxx), we add xxx to the 
        !           140:  *               (status features) list.
        !           141:  *     ST_TOLC - if non nil, map upper case chars in atoms to lc.
        !           142:  *     ST_CORE - if non nil, have bus errors and segmentation violations
        !           143:  *               dump core, if nil have them produce a bad-mem err msg
        !           144:  *     ST_INTB - set stattab table entry
        !           145:  *     ST_NFETW - use in (sstatus nofeature xxx) where we wish to remove xxx
        !           146:  *                from the status feature list.
        !           147:  *     ST_DMPW - set the dumpmode
        !           148:  *     ST_BCDTR - (ifdef RSET) if non nil, creat trace stack entries for
        !           149:  *                calls from BCD functions to BCD functions
        !           150:  *     ST_GCSTR - (ifdef GCSTRINGS) garbage collect strings
        !           151:  */
        !           152: 
        !           153: lispval
        !           154: Nstatus()
        !           155: {
        !           156:        register lispval handy,curitm,valarg;
        !           157:        int indx,ctim;
        !           158:        int typ;
        !           159:        char *cp;
        !           160:        char *ctime();
        !           161:        struct tm *lctime,*localtime();
        !           162:        extern unsigned char *ctable;
        !           163:        extern int dmpmode;
        !           164:        extern lispval chktt();
        !           165:        lispval Istsrch();
        !           166:        Savestack(3);
        !           167: 
        !           168:        if(lbot->val == nil) return(nil);
        !           169:        handy = lbot->val;              /* arg list */
        !           170: 
        !           171:        while(TYPE(handy) != DTPR) handy = error("status: bad arg list",TRUE); 
        !           172:        
        !           173:        curitm = Istsrch(handy->d.car); /* look for feature */
        !           174: 
        !           175:        if( curitm == nil ) return(nil);        /* non existant */
        !           176: 
        !           177:        if( handy->d.cdr == nil ) valarg = (lispval) CNIL;
        !           178:        else valarg = handy->d.cdr->d.car;
        !           179: 
        !           180:        /* now do the processing with curitm pointing to the requested
        !           181:           item in the status list 
        !           182:         */
        !           183:        
        !           184:        switch( typ = curitm->d.cdr->d.car->i ) {       /* look at readcode */
        !           185: 
        !           186: 
        !           187:        case ST_READ:
        !           188:                curitm = Istsrch(handy->d.car); /* look for name */
        !           189:                if(curitm == nil) return(nil);
        !           190:                if( valarg != (lispval) CNIL) 
        !           191:                    error("status: Second arg not allowed.",FALSE);
        !           192:                else return(curitm->d.cdr->d.cdr->d.cdr);
        !           193: 
        !           194:        case ST_NFETR:                          /* look for feature present */
        !           195:        case ST_FEATR:                          /* look for feature */
        !           196:                curitm = Istsrch(matom("features"));
        !           197:                if( valarg == (lispval) CNIL) 
        !           198:                    error("status: need second arg",FALSE);
        !           199: 
        !           200:                for( handy = curitm->d.cdr->d.cdr->d.cdr;
        !           201:                     handy != nil;
        !           202:                     handy = handy->d.cdr)
        !           203:                   if(handy->d.car == valarg) 
        !           204:                         return(typ == ST_FEATR ? tatom : nil);
        !           205:                
        !           206:                return(typ == ST_FEATR ? nil : tatom);
        !           207: 
        !           208:        case ST_SYNT:                           /* want character syntax */
        !           209:                handy = Vreadtable->a.clb;
        !           210:                chkrtab(handy);
        !           211:                if( valarg == (lispval) CNIL)
        !           212:                        error("status: need second arg",FALSE);
        !           213:                
        !           214:                while (TYPE(valarg) != ATOM) 
        !           215:                    valarg = error("status: second arg must be atom",TRUE);
        !           216:                
        !           217:                indx = valarg->a.pname[0];      /* get first char */
        !           218: 
        !           219:                if(valarg->a.pname[1] != '\0')
        !           220:                        error("status: only one character atom allowed",FALSE);
        !           221: 
        !           222:                handy = inewint((long) ctable[indx]);
        !           223:                return(handy);
        !           224: 
        !           225:        case ST_RINTB:
        !           226:                return(stattab[curitm->d.cdr->d.cdr->d.cdr->i]);
        !           227: 
        !           228:        case ST_DMPR:
        !           229:                return(inewint(dmpmode));
        !           230:                
        !           231:        case ST_CTIM:
        !           232:                 ctim = time((time_t *)0);
        !           233:                 cp = ctime(&ctim);
        !           234:                 cp[24] = '\0';
        !           235:                 return(matom(cp));
        !           236: 
        !           237:        case ST_LOCT:
        !           238:                 ctim = time((time_t *)0);
        !           239:                 lctime = localtime(&ctim);
        !           240:                 (handy = newdot())->d.car = inewint(lctime->tm_sec);
        !           241:                 protect(handy);
        !           242:                 handy->d.cdr =  (valarg = newdot());
        !           243:                 valarg->d.car = inewint(lctime->tm_min);
        !           244:                 valarg->d.cdr = (curitm = newdot());
        !           245:                 curitm->d.car = inewint(lctime->tm_hour);
        !           246:                 curitm->d.cdr = (valarg = newdot());
        !           247:                 valarg->d.car = inewint(lctime->tm_mday);
        !           248:                 valarg->d.cdr = (curitm = newdot());
        !           249:                 curitm->d.car = inewint(lctime->tm_mon);
        !           250:                 curitm->d.cdr = (valarg = newdot());
        !           251:                 valarg->d.car = inewint(lctime->tm_year);
        !           252:                 valarg->d.cdr = (curitm = newdot());
        !           253:                 curitm->d.car = inewint(lctime->tm_wday);
        !           254:                 curitm->d.cdr = (valarg = newdot());
        !           255:                 valarg->d.car = inewint(lctime->tm_yday);
        !           256:                 valarg->d.cdr = (curitm = newdot());
        !           257:                 curitm->d.car = inewint(lctime->tm_isdst);
        !           258:                 Restorestack();
        !           259:                 return(handy);
        !           260: 
        !           261:        case ST_ISTTY:
        !           262:                return( (isatty(0) == TRUE ? tatom : nil));
        !           263: 
        !           264:        case ST_UNDEF:
        !           265:                return(chktt());
        !           266:        }
        !           267:        error("Internal error in status: Couldn't figure out request",FALSE);
        !           268:        /* NOTREACHED */
        !           269: }
        !           270: lispval
        !           271: Nsstatus()
        !           272: {
        !           273:        register lispval handy;
        !           274:        lispval Isstatus();
        !           275: 
        !           276:        handy = lbot->val;
        !           277: 
        !           278:        while( TYPE(handy) != DTPR || TYPE(handy->d.cdr) != DTPR)
        !           279:             handy = error("sstatus: Bad args",TRUE);
        !           280:        
        !           281:        return(Isstatus(handy->d.car,handy->d.cdr->d.car));
        !           282: }
        !           283: 
        !           284: /* Isstatus - internal routine to do a set status.     */
        !           285: lispval
        !           286: Isstatus(curnam,curval)
        !           287: lispval curnam,curval;
        !           288: {
        !           289:        register lispval curitm,head;
        !           290:        lispval Istsrch(),Iaddstat();
        !           291:        int badmemr(),clrtt();
        !           292:        extern int uctolc, dmpmode, bcdtrsw, gcstrings;
        !           293: 
        !           294:        curitm = Istsrch(curnam);
        !           295:        /* if doesnt exist, make one up */
        !           296: 
        !           297:        if(curitm == nil) curitm = Iaddstat(curnam,ST_READ,ST_SET,nil);
        !           298: 
        !           299:        switch (curitm->d.cdr->d.cdr->d.car->i) {
        !           300: 
        !           301:        case ST_NO: error("sstatus: cannot set this status",FALSE);
        !           302: 
        !           303:        case ST_SET: goto setit;
        !           304: 
        !           305:        case ST_FEATW: curitm = Istsrch(matom("features"));
        !           306:                      (curnam = newdot())->d.car = curval;
        !           307:                      curnam->d.cdr = curitm->d.cdr->d.cdr->d.cdr;      /* old val */
        !           308:                      curitm->d.cdr->d.cdr->d.cdr = curnam;
        !           309:                      return(curval);
        !           310: 
        !           311:        case ST_NFETW:  /* remove from features list */
        !           312:                      curitm = Istsrch(matom("features"))->d.cdr->d.cdr;
        !           313:                      for(head = curitm->d.cdr; head != nil; head = head->d.cdr)
        !           314:                      {
        !           315:                           if(head->d.car == curval) curitm->d.cdr = head->d.cdr;
        !           316:                           else curitm = head;
        !           317:                      }
        !           318:                      return(nil);
        !           319: 
        !           320:                      
        !           321:        case ST_TOLC: if(curval == nil) uctolc = FALSE;
        !           322:                      else uctolc = TRUE;       
        !           323:                      goto setit;
        !           324: 
        !           325:        case ST_CORE: if(curval == nil)
        !           326:                      {
        !           327:                        signal(SIGBUS,badmemr);  /* catch bus errors */
        !           328:                        signal(SIGSEGV,badmemr); /* and segmentation viols */
        !           329:                      }
        !           330:                      else {
        !           331:                        signal(SIGBUS,SIG_DFL); /* let them core dump */
        !           332:                        signal(SIGSEGV,SIG_DFL);
        !           333:                      }
        !           334:                      goto setit;
        !           335: 
        !           336:        case ST_INTB: 
        !           337:                      stattab[curitm->d.cdr->d.cdr->d.cdr->i] = curval;
        !           338:                      return(curval);
        !           339: 
        !           340:        case ST_DMPW:   
        !           341:                      if(TYPE(curval) != INT ||
        !           342:                         (curval->i != 413    &&
        !           343:                          curval->i != 410)) errorh1(Vermisc,"sstatus: bad dump mode:",
        !           344:                                                  nil,FALSE,0,curval);
        !           345:                      dmpmode= curval->i;       
        !           346:                      return(curval);
        !           347: 
        !           348:         case ST_AUTR:
        !           349:                      if(curval != nil) Sautor = (lispval) TRUE;
        !           350:                      else Sautor = FALSE;
        !           351:                      goto setit;
        !           352:                        
        !           353:         case ST_TRAN:
        !           354:                      if(curval != nil) 
        !           355:                      {     
        !           356:                             Strans = (lispval) TRUE;
        !           357:                             /* the atom `on' set to set up all table
        !           358:                              * to their bcd fcn if possible
        !           359:                              */
        !           360:                             if(curval == matom("on")) clrtt(1);
        !           361:                      } 
        !           362:                      else { 
        !           363:                             Strans = (lispval) FALSE;
        !           364:                             clrtt(0);  /* clear all transfer tables */
        !           365:                      }
        !           366:                      goto setit;
        !           367:        case ST_BCDTR:
        !           368:                      if(curval == nil) bcdtrsw = FALSE;
        !           369:                      else bcdtrsw = TRUE;
        !           370:                      goto setit;
        !           371:        case ST_GCSTR:
        !           372:                      if(curval == nil) gcstrings = FALSE;
        !           373:                      else gcstrings = TRUE;
        !           374:                      goto setit;
        !           375:        }
        !           376: 
        !           377:     setit:           /* store value in status list */
        !           378:                      curitm->d.cdr->d.cdr->d.cdr = curval;
        !           379:                      return(curval);
        !           380: 
        !           381: 
        !           382: }
        !           383: 
        !           384: /* Istsrch - utility routine to search the status list for the
        !           385:    name given as an argument.  If such an entry is not found,
        !           386:    we return nil
        !           387:  */
        !           388:                        
        !           389: lispval Istsrch(nam)
        !           390: lispval nam;
        !           391: {
        !           392:        register lispval handy; 
        !           393: 
        !           394:        for(handy = stlist ; handy != nil ; handy = handy->d.cdr)
        !           395:          if(handy->d.car->d.car == nam) return(handy->d.car);
        !           396: 
        !           397:        return(nil);
        !           398: }
        !           399: 
        !           400: /* Iaddstat - add a status entry to the status list    */
        !           401: /*     return new entry in status list */
        !           402: 
        !           403: lispval
        !           404: Iaddstat(name,readcode,setcode,valu)
        !           405: lispval name,valu;
        !           406: int readcode,setcode;
        !           407: {
        !           408:        register lispval handy,handy2;
        !           409:        Savestack(2);
        !           410: 
        !           411: 
        !           412:        protect(handy=newdot());        /* build status list here */
        !           413: 
        !           414:        (handy2 = newdot())->d.car = name;
        !           415: 
        !           416:        handy->d.car = handy2;
        !           417: 
        !           418:        ((handy2->d.cdr = newdot())->d.car = newint())->i = readcode;
        !           419: 
        !           420:        handy2 = handy2->d.cdr;
        !           421: 
        !           422:        ((handy2->d.cdr = newdot())->d.car = newint())->i = setcode;
        !           423: 
        !           424:        handy2->d.cdr->d.cdr = valu;
        !           425: 
        !           426:        /* link this one in */
        !           427: 
        !           428:        handy->d.cdr = stlist;  
        !           429:        stlist = handy;
        !           430: 
        !           431:        Restorestack();
        !           432:        return(handy->d.car);   /* return new item in stlist */
        !           433: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.