Return to fex4.c CVS log

Up to [CSRG BSD Unix] / 41BSD / cmd / lisp

Annotation of 41BSD/cmd/lisp/fex4.c, revision 1.1

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

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