Return to lam3.c CVS log

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

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

1.1     ! root        1: #ifndef lint
        !             2: static char *rcsid =
        !             3:    "$Header: /na/franz/franz/RCS/lam3.c,v 1.2 83/08/06 08:37:32 jkf Exp $";
        !             4: #endif
        !             5: 
        !             6: /*                                     -[Fri Aug  5 12:47:19 1983 by jkf]-
        !             7:  *     lam3.c                          $Locker:  $
        !             8:  * lambda functions
        !             9:  *
        !            10:  * (c) copyright 1982, Regents of the University of California
        !            11:  */
        !            12: 
        !            13: # include "global.h"
        !            14: # include "chars.h"
        !            15: # include "chkrtab.h"
        !            16: 
        !            17: lispval
        !            18: Lalfalp()
        !            19: {
        !            20:        register char  *first, *second;
        !            21: 
        !            22:        chkarg(2,"alphalessp");
        !            23:        first = (char *) verify(lbot->val,"alphalessp: non symbol or string arg");
        !            24:        second = (char *) verify((lbot+1)->val,"alphalessp: non symbol or string arg");
        !            25:        if(strcmp(first,second) < 0)
        !            26:                return(tatom);
        !            27:        else
        !            28:                return(nil);
        !            29: }
        !            30: 
        !            31: lispval
        !            32: Lncons()
        !            33: {
        !            34:        register lispval handy;
        !            35: 
        !            36:        chkarg(1,"ncons");
        !            37:        handy = newdot();
        !            38:        handy->d.cdr = nil;
        !            39:        handy->d.car = lbot->val;
        !            40:        return(handy);
        !            41: }
        !            42: lispval
        !            43: Lzerop()
        !            44: {
        !            45:        register lispval handy;
        !            46: 
        !            47:        chkarg(1,"zerop");
        !            48:        handy = lbot->val;
        !            49:        switch(TYPE(handy)) {
        !            50:        case INT:
        !            51:                return(handy->i==0?tatom:nil);
        !            52:        case DOUB:
        !            53:                return(handy->r==0.0?tatom:nil);
        !            54:        }
        !            55:        return(nil);
        !            56: }
        !            57: lispval
        !            58: Lonep()
        !            59: {
        !            60:        register lispval handy; 
        !            61:        lispval Ladd();
        !            62: 
        !            63:        handy = lbot->val;
        !            64:        switch(TYPE(handy)) {
        !            65:        case INT:
        !            66:                return(handy->i==1?tatom:nil);
        !            67:        case DOUB:
        !            68:                return(handy->r==1.0?tatom:nil);
        !            69:        case SDOT:
        !            70:                protect(inewint(0));
        !            71:                handy = Ladd();
        !            72:                if(TYPE(handy)!=INT || handy->i !=1)
        !            73:                        return(nil);
        !            74:                else
        !            75:                        return(tatom);
        !            76:        }
        !            77:        return(nil);
        !            78: }
        !            79: 
        !            80: lispval
        !            81: cmpx(lssp)
        !            82: {
        !            83:        register struct argent *argp;
        !            84:        register struct argent *outarg;
        !            85:        register struct argent *onp = np;
        !            86:        Savestack(3);
        !            87: 
        !            88: 
        !            89:        argp = lbot + 1;
        !            90:        outarg = np;
        !            91:        while(argp < onp) {
        !            92: 
        !            93:                np = outarg + 2;
        !            94:                lbot = outarg;
        !            95:                if(lssp)
        !            96:                        *outarg = argp[-1], outarg[1]  = *argp++;
        !            97:                else
        !            98:                        outarg[1]  = argp[-1], *outarg = *argp++;
        !            99:                lbot->val = Lsub();
        !           100:                np = lbot + 1;
        !           101:                if(Lnegp()==nil) 
        !           102:                {
        !           103:                    Restorestack();
        !           104:                    return(nil);
        !           105:                }
        !           106:        }
        !           107:        Restorestack();
        !           108:        return(tatom);
        !           109: }
        !           110: 
        !           111: lispval
        !           112: Lgreaterp()
        !           113: {
        !           114:        register int typ;
        !           115:        /* do the easy cases first */
        !           116:        if(np-lbot == 2)
        !           117:        {   if((typ=TYPE(lbot->val)) == INT)
        !           118:            {    if((typ=TYPE(lbot[1].val)) == INT)
        !           119:                   return((lbot[0].val->i - lbot[1].val->i) > 0 ? tatom : nil);
        !           120:                 else if(typ == DOUB)
        !           121:                  return((lbot[0].val->i - lbot[1].val->r) > 0.0 ? tatom : nil);
        !           122:            }
        !           123:            else if(typ == DOUB)
        !           124:            {    if((typ=TYPE(lbot[1].val)) == INT)
        !           125:                  return((lbot[0].val->r - lbot[1].val->i) > 0.0 ? tatom : nil);
        !           126:                 else if(typ == DOUB)
        !           127:                  return((lbot[0].val->r - lbot[1].val->r) > 0.0 ? tatom : nil);
        !           128:            }
        !           129:        }
        !           130:                  
        !           131:        return(cmpx(FALSE));
        !           132: }
        !           133: 
        !           134: lispval
        !           135: Llessp()
        !           136: {
        !           137:        register int typ;
        !           138:        /* do the easy cases first */
        !           139:        if(np-lbot == 2)
        !           140:        {   if((typ=TYPE(lbot->val)) == INT)
        !           141:            {    if((typ=TYPE(lbot[1].val)) == INT)
        !           142:                   return((lbot[0].val->i - lbot[1].val->i) < 0 ? tatom : nil);
        !           143:                 else if(typ == DOUB)
        !           144:                  return((lbot[0].val->i - lbot[1].val->r) < 0.0 ? tatom : nil);
        !           145:            }
        !           146:            else if(typ == DOUB)
        !           147:            {    if((typ=TYPE(lbot[1].val)) == INT)
        !           148:                  return((lbot[0].val->r - lbot[1].val->i) < 0.0 ? tatom : nil);
        !           149:                 else if(typ == DOUB)
        !           150:                  return((lbot[0].val->r - lbot[1].val->r) < 0.0 ? tatom : nil);
        !           151:            }
        !           152:        }
        !           153:                  
        !           154:        return(cmpx(TRUE));
        !           155: }
        !           156: 
        !           157: lispval
        !           158: Ldiff()
        !           159: {
        !           160:        register lispval arg1,arg2; 
        !           161:        register handy = 0;
        !           162: 
        !           163: 
        !           164:        chkarg(2,"Ldiff");
        !           165:        arg1 = lbot->val;
        !           166:        arg2 = (lbot+1)->val;
        !           167:        if(TYPE(arg1)==INT && TYPE(arg2)==INT) {
        !           168:                handy=arg1->i - arg2->i;
        !           169:        }
        !           170:        else error("non-numeric argument",FALSE);
        !           171:        return(inewint(handy));
        !           172: }
        !           173: 
        !           174: lispval
        !           175: Lmod()
        !           176: {
        !           177:        register lispval arg1,arg2;
        !           178:        lispval  handy;
        !           179:        struct sdot fake1, fake2;
        !           180:        fake2.CDR = 0;
        !           181:        fake1.CDR = 0;
        !           182: 
        !           183:        chkarg(2,"mod");
        !           184:        handy = arg1 = lbot->val;
        !           185:        arg2 = (lbot+1)->val;
        !           186:        switch(TYPE(arg1)) {
        !           187:        case SDOT:
        !           188:                switch(TYPE(arg2)) {
        !           189:                case SDOT:                      /* both are already bignums */
        !           190:                        break;
        !           191:                case INT:                       /* convert arg2 to bignum   */
        !           192:                        fake2.I = arg2->i;
        !           193:                        arg2 =(lispval) &fake2;
        !           194:                        break;
        !           195:                default:
        !           196:                        error("non-numeric argument",FALSE);
        !           197:                }
        !           198:                break;
        !           199:        case INT:
        !           200:                switch(TYPE(arg2)) {
        !           201:                case SDOT:                      /* convert arg1 to bignum */
        !           202:                        fake1.I = arg1->i;
        !           203:                        arg1 =(lispval) &fake1;
        !           204:                        break;
        !           205:                case INT:                       /* both are fixnums       */
        !           206:                        return( inewint ((arg1->i) % (arg2->i)) );
        !           207:                default:
        !           208:                        error("non-numeric argument",FALSE);
        !           209:                }
        !           210:                break;
        !           211:        default:
        !           212:                error("non-numeric argument",FALSE);
        !           213:        }
        !           214:        if(TYPE((lbot+1)->val)==INT && lbot[1].val->i==0)
        !           215:                return(handy);
        !           216:        divbig(arg1,arg2,(lispval *)0,&handy);
        !           217:        if(handy==((lispval)&fake1))
        !           218:                handy = inewint(fake1.I);
        !           219:        if(handy==((lispval)&fake2))
        !           220:                handy = inewint(fake2.I);
        !           221:        return(handy);
        !           222: }
        !           223: lispval
        !           224: Ladd1()
        !           225: {
        !           226:        register lispval handy;
        !           227:        lispval Ladd();
        !           228:        Savestack(1); /* fixup entry mask */
        !           229:        chkarg(1,"add1");
        !           230: 
        !           231:        /* simple test first */
        !           232:        if((TYPE(lbot->val) == INT) && (lbot->val->i < MaxINT))
        !           233:        {
        !           234:            Restorestack();
        !           235:            return(inewint(lbot->val->i + 1));
        !           236:        }
        !           237:        
        !           238:        handy = rdrint;
        !           239:        handy->i = 1;
        !           240:        protect(handy);
        !           241:        handy=Ladd();
        !           242:        Restorestack();
        !           243:        return(handy);
        !           244: 
        !           245: }
        !           246: 
        !           247: 
        !           248: 
        !           249: lispval
        !           250: Lsub1()
        !           251: {
        !           252:        register lispval handy;
        !           253:        lispval Ladd();
        !           254:        Savestack(1); /* fixup entry mask */
        !           255:        chkarg(1,"sub1");
        !           256:        
        !           257:        if((TYPE(lbot->val) == INT) && (lbot->val->i > MinINT))
        !           258:        {
        !           259:            Restorestack();
        !           260:            return(inewint(lbot->val->i - 1));
        !           261:        }
        !           262: 
        !           263:        handy = rdrint;
        !           264:        handy->i = - 1;
        !           265:        protect(handy);
        !           266:        handy=Ladd();
        !           267:        Restorestack();
        !           268:        return(handy);
        !           269: }
        !           270: 
        !           271: lispval
        !           272: Lminus()
        !           273: {
        !           274:        register lispval arg1, handy;
        !           275:        lispval subbig();
        !           276: 
        !           277:        chkarg(1,"minus");
        !           278:        arg1 = lbot->val;
        !           279:        handy = nil;
        !           280:        switch(TYPE(arg1)) {
        !           281:        case INT:
        !           282:                handy= inewint(0 - arg1->i);
        !           283:                break;
        !           284:        case DOUB:
        !           285:                handy = newdoub();
        !           286:                handy->r = -arg1->r;
        !           287:                break;
        !           288:        case SDOT: { struct sdot dummyb;
        !           289:                handy = (lispval) &dummyb;
        !           290:                handy->s.I = 0;
        !           291:                handy->s.CDR = (lispval) 0;
        !           292:                handy = subbig(handy,arg1);
        !           293:                break; }
        !           294: 
        !           295:        default:
        !           296:                error("non-numeric argument",FALSE);
        !           297:        }
        !           298:        return(handy);
        !           299: }
        !           300: 
        !           301: lispval
        !           302: Lnegp()
        !           303: {
        !           304:        register lispval handy = np[-1].val, work;
        !           305:        register flag = 0;
        !           306: 
        !           307: loop:
        !           308:        switch(TYPE(handy)) {
        !           309:        case INT:
        !           310:                if(handy->i < 0) flag = TRUE;
        !           311:                break;
        !           312:        case DOUB:
        !           313:                if(handy->r < 0) flag = TRUE;
        !           314:                break;
        !           315:        case SDOT:
        !           316:                for(work = handy;
        !           317:                    work->s.CDR!=(lispval) 0;
        !           318:                    work = work->s.CDR) {;}
        !           319:                if(work->s.I < 0) flag = TRUE;
        !           320:                break;
        !           321:        default:
        !           322:                handy = errorh1(Vermisc,
        !           323:                                  "minusp: Non-(int,real,bignum) arg: ",
        !           324:                                  nil,
        !           325:                                  TRUE,
        !           326:                                  0,
        !           327:                                  handy);
        !           328:                goto loop;
        !           329:        }
        !           330:        if(flag) return(tatom);
        !           331:        return(nil);
        !           332: }
        !           333: 
        !           334: lispval
        !           335: Labsval()
        !           336: {
        !           337:        register lispval arg1;
        !           338: 
        !           339:        chkarg(1,"absval");
        !           340:        arg1 = lbot->val;
        !           341:        if(Lnegp()!=nil) return(Lminus());
        !           342: 
        !           343:        return(arg1);
        !           344: }
        !           345: 
        !           346: /*
        !           347:  *
        !           348:  * (oblist)
        !           349:  *
        !           350:  * oblist returns a list of all symbols in the oblist
        !           351:  *
        !           352:  * written by jkf.
        !           353:  */
        !           354: lispval
        !           355: Loblist()
        !           356: {
        !           357:     int indx;
        !           358:     lispval headp, tailp ;
        !           359:     struct atom *symb ;
        !           360:     extern int hashtop;
        !           361:     Savestack(0);
        !           362: 
        !           363:     headp = tailp = newdot(); /* allocate first DTPR */
        !           364:     protect(headp);            /*protect the list from garbage collection*/
        !           365:                                /*line added by kls                       */
        !           366: 
        !           367:     for( indx=0 ; indx <= hashtop-1 ; indx++ ) /* though oblist */
        !           368:     {
        !           369:        for( symb = hasht[indx] ;
        !           370:             symb != (struct atom *) CNIL ;
        !           371:             symb = symb-> hshlnk)
        !           372:        {
        !           373:            if(TYPE(symb) != ATOM) 
        !           374:            {   printf(" non symbol in hasht[%d] = %x: ",indx,symb);
        !           375:                printr((lispval) symb,stdout);
        !           376:                printf(" \n");
        !           377:                fflush(stdout);
        !           378:            }
        !           379:            tailp->d.car = (lispval) symb  ; /* remember this atom */
        !           380:            tailp = tailp->d.cdr = newdot() ; /* link to next DTPR */
        !           381:        }
        !           382:     }
        !           383: 
        !           384:     tailp->d.cdr = nil ; /* close the list unfortunately throwing away
        !           385:                          the last DTPR
        !           386:                          */
        !           387:     Restorestack();
        !           388:     return(headp);
        !           389: }
        !           390: 
        !           391: /*
        !           392:  * Maclisp setsyntax function:
        !           393:  *    (setsyntax c s x)
        !           394:  * c represents character either by fixnum or atom
        !           395:  * s is the atom "macro" or the atom "splicing" (in which case x is the
        !           396:  * macro to be invoked); or nil (meaning don't change syntax of c); or
        !           397:  * (well thats enough for now) if s is a fixnum then we modify the bits
        !           398:  * for c in the readtable.
        !           399:  */
        !           400: 
        !           401: lispval
        !           402: Lsetsyn()
        !           403: {
        !           404:        register lispval s, c;
        !           405:        register struct argent *mynp;
        !           406:        register index;
        !           407:        lispval x   /*  ,debugmode  */;
        !           408:        extern unsigned char *ctable;
        !           409:        extern lispval Istsrch();
        !           410: 
        !           411:        switch(np-lbot) {
        !           412:        case 2:
        !           413:                x= nil;                 /* only 2 args given */
        !           414:        case 3:
        !           415:                x = lbot[2].val;        /* all three args given */
        !           416:                break;
        !           417:        default:
        !           418:                argerr("setsyntax");
        !           419:        }
        !           420:        s = Vreadtable->a.clb;
        !           421:        chkrtab(s);
        !           422:        /* debugging code 
        !           423:        debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr;
        !           424:        if(debugmode)  printf("Readtable addr: %x\n",ctable);
        !           425:          end debugging code */
        !           426:        mynp = lbot;
        !           427:        c = (mynp++)->val;
        !           428:        s = (mynp++)->val;
        !           429: 
        !           430:        switch(TYPE(c)) {
        !           431:        default:
        !           432:                error("neither fixnum, atom or string as char to setsyntax",FALSE);
        !           433: 
        !           434:        case ATOM:
        !           435:                index = *(c->a.pname);
        !           436:                if((c->a.pname)[1])
        !           437:                    errorh1(Vermisc,"Only 1 char atoms to setsyntax",
        !           438:                         nil,FALSE,0,c);
        !           439:                break;
        !           440: 
        !           441:        case INT:
        !           442:                index = c->i;
        !           443:                break;
        !           444: 
        !           445:        case STRNG:
        !           446:                index = (int) *((char *) c);
        !           447:        }
        !           448:        switch(TYPE(s)) {
        !           449:        case ATOM:
        !           450:                if(s==splice || s==macro) {
        !           451:                    if(s==splice)
        !           452:                            ctable[index] = VSPL;
        !           453:                    else if(s==macro)
        !           454:                            ctable[index] = VMAC;
        !           455:                    if(TYPE(c)!=ATOM) {
        !           456:                            strbuf[0] = index;
        !           457:                            strbuf[1] = 0;
        !           458:                            c = (getatom(TRUE));
        !           459:                    }
        !           460:                    Iputprop(c,x,lastrtab);
        !           461:                    return(tatom);
        !           462:                }
        !           463: 
        !           464:                /* ... fall into */
        !           465:        default:  errorh1(Vermisc,"int:setsyntax : illegal second argument ",
        !           466:                                nil,FALSE,0,s);
        !           467:                /* not reached */
        !           468:                
        !           469:        case INT:
        !           470:                switch(synclass(s->i)) {
        !           471:                case CESC: Xesc = (char) index; break;
        !           472:                case CDQ: Xdqc = (char) index; break;
        !           473:                case CSD: Xsdc = (char) index;  /* string */
        !           474:                }
        !           475: 
        !           476:                if(synclass(ctable[index])==CESC   /* if we changed the current esc */
        !           477:                  && (synclass(s->i)!=CESC)          /* to something else, pick current */
        !           478:                  && Xesc == (char) index) {
        !           479:                        ctable[index] = s->i;
        !           480:                        rpltab(CESC,&Xesc);
        !           481:                }
        !           482:                else if(synclass(ctable[index])==CDQ   /*  likewise for double quote */
        !           483:                       && synclass(s->i) != CDQ
        !           484:                       && Xdqc == (char) index)  {
        !           485:                        ctable[index] = s->i;
        !           486:                        rpltab(CDQ,&Xdqc);
        !           487:                }
        !           488:                else if(synclass(ctable[index]) == CSD  /* and for string delimiter */
        !           489:                        && synclass(s->i) != CSD
        !           490:                        && Xsdc == (char) index) {
        !           491:                         ctable[index] = s->i;
        !           492:                         rpltab(CSD,&Xsdc);
        !           493:                }
        !           494:                else ctable[index] = s->i;
        !           495: 
        !           496:                break;
        !           497: 
        !           498:        }
        !           499:        return(tatom);
        !           500: }
        !           501: 
        !           502: /*
        !           503:  * this aux function is used by setsyntax to determine the new current
        !           504:  * escape or double quote character.  It scans the character table for
        !           505:  * the first character with the given class (either VESC or VDQ) and
        !           506:  * puts that character in Xesc or Xdqc (whichever is pointed to by
        !           507:  * addr).
        !           508:  */
        !           509: rpltab(cclass,addr)
        !           510: char cclass;
        !           511: unsigned char *addr;
        !           512: {
        !           513:        register int i;
        !           514:        extern unsigned char *ctable;
        !           515:        for(i=0; i<=127 && synclass(ctable[i]) != cclass; i++);
        !           516:        if(i<=127) *addr = (unsigned char) i;
        !           517:        else *addr = '\0';
        !           518: }
        !           519: 
        !           520: 
        !           521: /*
        !           522:  * int:getsyntax from lisp.
        !           523:  * returns the fixnum syntax code from the readtable for the given character.
        !           524:  * to be used by the lisp-code function getsyntax, not to be used by 
        !           525:  * joe user.
        !           526:  */
        !           527: lispval
        !           528: Lgetsyntax()
        !           529: {
        !           530:     register char *name;
        !           531:     int number, typ;
        !           532:     lispval handy;
        !           533:     
        !           534:     chkarg(1,"int:getsyntax");
        !           535:     handy = lbot[0].val;
        !           536:     while (1)
        !           537:     {
        !           538:        if((typ = TYPE(handy)) == ATOM)
        !           539:        {
        !           540:            name = handy->a.pname;
        !           541:        }
        !           542:        else if (typ == STRNG)
        !           543:        {
        !           544:            name = (char *)handy;
        !           545:        }
        !           546:        else if(typ == INT)
        !           547:        {
        !           548:            number = handy->i;
        !           549:            break;
        !           550:        }
        !           551:        else {
        !           552:            handy =
        !           553:              errorh1(Vermisc,"int:getsyntax : bad character ",
        !           554:                        nil,TRUE,0,handy);
        !           555:            continue;   /* start at the top */
        !           556:        }
        !           557:        /* figure out the number of the first byte */
        !           558:        number = (int) name[0];
        !           559:        if(name[1] != '\0')
        !           560:        {
        !           561:            handy = errorh1(Vermisc,
        !           562:            "int:getsyntax : only single character allowed ",
        !           563:            nil,TRUE,0,handy);
        !           564:        }
        !           565:        else break;
        !           566:     }
        !           567:     /* see if number is within range */
        !           568:     if(number < 0 || number > 255)
        !           569:        errorh1(Vermisc,"int:getsyntax : character number out of range ",nil,
        !           570:                FALSE,0,inewint(number));
        !           571:     chkrtab(Vreadtable->a.clb);  /* make sure readtable is correct */
        !           572:     return(inewint(ctable[number]));
        !           573: }
        !           574:     
        !           575:     
        !           576:        
        !           577:     
        !           578: lispval
        !           579: Lzapline()
        !           580: {
        !           581:        register FILE *port;
        !           582:        extern FILE * rdrport;
        !           583: 
        !           584:        port = rdrport;
        !           585:        while (!feof(port) && (getc(port)!='\n') );
        !           586:        return(nil);
        !           587: }

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