Return to rval.c CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / pascal / src

Annotation of 43BSDTahoe/ucb/pascal/src/rval.c, revision 1.1

1.1     ! root        1: /*
        !             2:  * Copyright (c) 1980 Regents of the University of California.
        !             3:  * All rights reserved.  The Berkeley software License Agreement
        !             4:  * specifies the terms and conditions for redistribution.
        !             5:  */
        !             6: 
        !             7: #ifndef lint
        !             8: static char sccsid[] = "@(#)rval.c     5.2 (Berkeley) 4/7/87";
        !             9: #endif not lint
        !            10: 
        !            11: #include "whoami.h"
        !            12: #include "0.h"
        !            13: #include "tree.h"
        !            14: #include "opcode.h"
        !            15: #include "objfmt.h"
        !            16: #ifdef PC
        !            17: #   include    "pc.h"
        !            18: #   include <pcc.h>
        !            19: #endif PC
        !            20: #include "tmps.h"
        !            21: #include "tree_ty.h"
        !            22: 
        !            23: extern char *opnames[];
        !            24: 
        !            25:     /* line number of the last record comparison warning */
        !            26: short reccompline = 0;
        !            27:     /* line number of the last non-standard set comparison */
        !            28: short nssetline = 0;
        !            29: 
        !            30: #ifdef PC
        !            31:     char       *relts[] =  {
        !            32:                                "_RELEQ" , "_RELNE" ,
        !            33:                                "_RELTLT" , "_RELTGT" ,
        !            34:                                "_RELTLE" , "_RELTGE"
        !            35:                            };
        !            36:     char       *relss[] =  {
        !            37:                                "_RELEQ" , "_RELNE" ,
        !            38:                                "_RELSLT" , "_RELSGT" ,
        !            39:                                "_RELSLE" , "_RELSGE"
        !            40:                            };
        !            41:     long       relops[] =  {   
        !            42:                                PCC_EQ , PCC_NE ,
        !            43:                                PCC_LT , PCC_GT ,
        !            44:                                PCC_LE , PCC_GE 
        !            45:                            };
        !            46:     long       mathop[] =  {   PCC_MUL , PCC_PLUS , PCC_MINUS };
        !            47:     char       *setop[] =  {   "_MULT" , "_ADDT" , "_SUBT" };
        !            48: #endif PC
        !            49: /*
        !            50:  * Rvalue - an expression.
        !            51:  *
        !            52:  * Contype is the type that the caller would prefer, nand is important
        !            53:  * if constant strings are involved, because of string padding.
        !            54:  * required is a flag whether an lvalue or an rvalue is required.
        !            55:  * only VARs and structured things can have gt their lvalue this way.
        !            56:  */
        !            57: /*ARGSUSED*/
        !            58: struct nl *
        !            59: rvalue(r, contype , required )
        !            60:        struct tnode *r;
        !            61:        struct nl *contype;
        !            62:        int     required;
        !            63: {
        !            64:        register struct nl *p, *p1;
        !            65:        register struct nl *q;
        !            66:        int c, c1, w;
        !            67: #ifdef OBJ
        !            68:        int g;
        !            69: #endif
        !            70:        struct tnode *rt;
        !            71:        char *cp, *cp1, *opname;
        !            72:        long l;
        !            73:        union
        !            74:        {
        !            75:            long plong[2];
        !            76:            double pdouble;
        !            77:        }f;
        !            78:        extern int      flagwas;
        !            79:        struct csetstr  csetd;
        !            80: #      ifdef PC
        !            81:            struct nl   *rettype;
        !            82:            long        ctype;
        !            83:            struct nl   *tempnlp;
        !            84: #      endif PC
        !            85: 
        !            86:        if (r == TR_NIL)
        !            87:                return (NLNIL);
        !            88:        if (nowexp(r))
        !            89:                return (NLNIL);
        !            90:        /*
        !            91:         * Pick up the name of the operation
        !            92:         * for future error messages.
        !            93:         */
        !            94:        if (r->tag <= T_IN)
        !            95:                opname = opnames[r->tag];
        !            96: 
        !            97:        /*
        !            98:         * The root of the tree tells us what sort of expression we have.
        !            99:         */
        !           100:        switch (r->tag) {
        !           101: 
        !           102:        /*
        !           103:         * The constant nil
        !           104:         */
        !           105:        case T_NIL:
        !           106: #              ifdef OBJ
        !           107:                    (void) put(2, O_CON2, 0);
        !           108: #              endif OBJ
        !           109: #              ifdef PC
        !           110:                    putleaf( PCC_ICON , 0 , 0 , PCCTM_PTR|PCCT_UNDEF , (char *) 0 );
        !           111: #              endif PC
        !           112:                return (nl+TNIL);
        !           113: 
        !           114:        /*
        !           115:         * Function call with arguments.
        !           116:         */
        !           117:        case T_FCALL:
        !           118: #          ifdef OBJ
        !           119:                return (funccod(r));
        !           120: #          endif OBJ
        !           121: #          ifdef PC
        !           122:                return (pcfunccod( r ));
        !           123: #          endif PC
        !           124: 
        !           125:        case T_VAR:
        !           126:                p = lookup(r->var_node.cptr);
        !           127:                if (p == NLNIL || p->class == BADUSE)
        !           128:                        return (NLNIL);
        !           129:                switch (p->class) {
        !           130:                    case VAR:
        !           131:                            /*
        !           132:                             * If a variable is
        !           133:                             * qualified then get
        !           134:                             * the rvalue by a
        !           135:                             * lvalue and an ind.
        !           136:                             */
        !           137:                            if (r->var_node.qual != TR_NIL)
        !           138:                                    goto ind;
        !           139:                            q = p->type;
        !           140:                            if (q == NIL)
        !           141:                                    return (NLNIL);
        !           142: #                          ifdef OBJ
        !           143:                                w = width(q);
        !           144:                                switch (w) {
        !           145:                                    case 8:
        !           146:                                        (void) put(2, O_RV8 | bn << 8+INDX,
        !           147:                                                (int)p->value[0]);
        !           148:                                        break;
        !           149:                                    case 4:
        !           150:                                        (void) put(2, O_RV4 | bn << 8+INDX,
        !           151:                                                (int)p->value[0]);
        !           152:                                        break;
        !           153:                                    case 2:
        !           154:                                        (void) put(2, O_RV2 | bn << 8+INDX,
        !           155:                                                (int)p->value[0]);
        !           156:                                        break;
        !           157:                                    case 1:
        !           158:                                        (void) put(2, O_RV1 | bn << 8+INDX,
        !           159:                                                (int)p->value[0]);
        !           160:                                        break;
        !           161:                                    default:
        !           162:                                        (void) put(3, O_RV | bn << 8+INDX,
        !           163:                                                (int)p->value[0], w);
        !           164:                                }
        !           165: #                         endif OBJ
        !           166: #                         ifdef PC
        !           167:                                if ( required == RREQ ) {
        !           168:                                    putRV( p -> symbol , bn , p -> value[0] ,
        !           169:                                            p -> extra_flags , p2type( q ) );
        !           170:                                } else {
        !           171:                                    putLV( p -> symbol , bn , p -> value[0] ,
        !           172:                                            p -> extra_flags , p2type( q ) );
        !           173:                                }
        !           174: #                         endif PC
        !           175:                           return (q);
        !           176: 
        !           177:                    case WITHPTR:
        !           178:                    case REF:
        !           179:                            /*
        !           180:                             * A lvalue for these
        !           181:                             * is actually what one
        !           182:                             * might consider a rvalue.
        !           183:                             */
        !           184: ind:
        !           185:                            q = lvalue(r, NOFLAGS , LREQ );
        !           186:                            if (q == NIL)
        !           187:                                    return (NLNIL);
        !           188: #                          ifdef OBJ
        !           189:                                w = width(q);
        !           190:                                switch (w) {
        !           191:                                    case 8:
        !           192:                                            (void) put(1, O_IND8);
        !           193:                                            break;
        !           194:                                    case 4:
        !           195:                                            (void) put(1, O_IND4);
        !           196:                                            break;
        !           197:                                    case 2:
        !           198:                                            (void) put(1, O_IND2);
        !           199:                                            break;
        !           200:                                    case 1:
        !           201:                                            (void) put(1, O_IND1);
        !           202:                                            break;
        !           203:                                    default:
        !           204:                                            (void) put(2, O_IND, w);
        !           205:                                }
        !           206: #                          endif OBJ
        !           207: #                          ifdef PC
        !           208:                                if ( required == RREQ ) {
        !           209:                                    putop( PCCOM_UNARY PCC_MUL , p2type( q ) );
        !           210:                                }
        !           211: #                          endif PC
        !           212:                            return (q);
        !           213: 
        !           214:                    case CONST:
        !           215:                            if (r->var_node.qual != TR_NIL) {
        !           216:                                error("%s is a constant and cannot be qualified", r->var_node.cptr);
        !           217:                                return (NLNIL);
        !           218:                            }
        !           219:                            q = p->type;
        !           220:                            if (q == NLNIL)
        !           221:                                    return (NLNIL);
        !           222:                            if (q == nl+TSTR) {
        !           223:                                    /*
        !           224:                                     * Find the size of the string
        !           225:                                     * constant if needed.
        !           226:                                     */
        !           227:                                    cp = (char *) p->ptr[0];
        !           228: cstrng:
        !           229:                                    cp1 = cp;
        !           230:                                    for (c = 0; *cp++; c++)
        !           231:                                            continue;
        !           232:                                    w = c;
        !           233:                                    if (contype != NIL && !opt('s')) {
        !           234:                                            if (width(contype) < c && classify(contype) == TSTR) {
        !           235:                                                    error("Constant string too long");
        !           236:                                                    return (NLNIL);
        !           237:                                            }
        !           238:                                            w = width(contype);
        !           239:                                    }
        !           240: #                                  ifdef OBJ
        !           241:                                        (void) put(2, O_CONG, w);
        !           242:                                        putstr(cp1, w - c);
        !           243: #                                  endif OBJ
        !           244: #                                  ifdef PC
        !           245:                                        putCONG( cp1 , w , required );
        !           246: #                                  endif PC
        !           247:                                    /*
        !           248:                                     * Define the string temporarily
        !           249:                                     * so later people can know its
        !           250:                                     * width.
        !           251:                                     * cleaned out by stat.
        !           252:                                     */
        !           253:                                    q = defnl((char *) 0, STR, NLNIL, w);
        !           254:                                    q->type = q;
        !           255:                                    return (q);
        !           256:                            }
        !           257:                            if (q == nl+T1CHAR) {
        !           258: #                                  ifdef OBJ
        !           259:                                        (void) put(2, O_CONC, (int)p->value[0]);
        !           260: #                                  endif OBJ
        !           261: #                                  ifdef PC
        !           262:                                        putleaf( PCC_ICON , p -> value[0] , 0
        !           263:                                                , PCCT_CHAR , (char *) 0 );
        !           264: #                                  endif PC
        !           265:                                    return (q);
        !           266:                            }
        !           267:                            /*
        !           268:                             * Every other kind of constant here
        !           269:                             */
        !           270:                            switch (width(q)) {
        !           271:                            case 8:
        !           272: #ifndef DEBUG
        !           273: #                                  ifdef OBJ
        !           274:                                        (void) put(2, O_CON8, p->real);
        !           275: #                                  endif OBJ
        !           276: #                                  ifdef PC
        !           277:                                        putCON8( p -> real );
        !           278: #                                  endif PC
        !           279: #else
        !           280:                                    if (hp21mx) {
        !           281:                                            f.pdouble = p->real;
        !           282:                                            conv((int *) (&f.pdouble));
        !           283:                                            l = f.plong[1];
        !           284:                                            (void) put(2, O_CON4, l);
        !           285:                                    } else
        !           286: #                                          ifdef OBJ
        !           287:                                                (void) put(2, O_CON8, p->real);
        !           288: #                                          endif OBJ
        !           289: #                                          ifdef PC
        !           290:                                                putCON8( p -> real );
        !           291: #                                          endif PC
        !           292: #endif
        !           293:                                    break;
        !           294:                            case 4:
        !           295: #                                  ifdef OBJ
        !           296:                                        (void) put(2, O_CON4, p->range[0]);
        !           297: #                                  endif OBJ
        !           298: #                                  ifdef PC
        !           299:                                        putleaf( PCC_ICON , (int) p->range[0] , 0
        !           300:                                                , PCCT_INT , (char *) 0 );
        !           301: #                                  endif PC
        !           302:                                    break;
        !           303:                            case 2:
        !           304: #                                  ifdef OBJ
        !           305:                                        (void) put(2, O_CON2, (short)p->range[0]);
        !           306: #                                  endif OBJ
        !           307: #                                  ifdef PC
        !           308:                                        putleaf( PCC_ICON , (short) p -> range[0]
        !           309:                                                , 0 , PCCT_SHORT , (char *) 0 );
        !           310: #                                  endif PC
        !           311:                                    break;
        !           312:                            case 1:
        !           313: #                                  ifdef OBJ
        !           314:                                        (void) put(2, O_CON1, p->value[0]);
        !           315: #                                  endif OBJ
        !           316: #                                  ifdef PC
        !           317:                                        putleaf( PCC_ICON , p -> value[0] , 0
        !           318:                                                , PCCT_CHAR , (char *) 0 );
        !           319: #                                  endif PC
        !           320:                                    break;
        !           321:                            default:
        !           322:                                    panic("rval");
        !           323:                            }
        !           324:                            return (q);
        !           325: 
        !           326:                    case FUNC:
        !           327:                    case FFUNC:
        !           328:                            /*
        !           329:                             * Function call with no arguments.
        !           330:                             */
        !           331:                            if (r->var_node.qual != TR_NIL) {
        !           332:                                    error("Can't qualify a function result value");
        !           333:                                    return (NLNIL);
        !           334:                            }
        !           335: #                          ifdef OBJ
        !           336:                                return (funccod(r));
        !           337: #                          endif OBJ
        !           338: #                          ifdef PC
        !           339:                                return (pcfunccod( r ));
        !           340: #                          endif PC
        !           341: 
        !           342:                    case TYPE:
        !           343:                            error("Type names (e.g. %s) allowed only in declarations", p->symbol);
        !           344:                            return (NLNIL);
        !           345: 
        !           346:                    case PROC:
        !           347:                    case FPROC:
        !           348:                            error("Procedure %s found where expression required", p->symbol);
        !           349:                            return (NLNIL);
        !           350:                    default:
        !           351:                            panic("rvid");
        !           352:                }
        !           353:        /*
        !           354:         * Constant sets
        !           355:         */
        !           356:        case T_CSET:
        !           357: #              ifdef OBJ
        !           358:                    if ( precset( r , contype , &csetd ) ) {
        !           359:                        if ( csetd.csettype == NIL ) {
        !           360:                            return (NLNIL);
        !           361:                        }
        !           362:                        postcset( r , &csetd );
        !           363:                    } else {
        !           364:                        (void) put( 2, O_PUSH, -lwidth(csetd.csettype));
        !           365:                        postcset( r , &csetd );
        !           366:                        setran( ( csetd.csettype ) -> type );
        !           367:                        (void) put( 2, O_CON24, set.uprbp);
        !           368:                        (void) put( 2, O_CON24, set.lwrb);
        !           369:                        (void) put( 2, O_CTTOT,
        !           370:                                (int)(4 + csetd.singcnt + 2 * csetd.paircnt));
        !           371:                    }
        !           372:                    return csetd.csettype;
        !           373: #              endif OBJ
        !           374: #              ifdef PC
        !           375:                    if ( precset( r , contype , &csetd ) ) {
        !           376:                        if ( csetd.csettype == NIL ) {
        !           377:                            return (NLNIL);
        !           378:                        }
        !           379:                        postcset( r , &csetd );
        !           380:                    } else {
        !           381:                        putleaf( PCC_ICON , 0 , 0
        !           382:                                , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
        !           383:                                , "_CTTOT" );
        !           384:                        /*
        !           385:                         *      allocate a temporary and use it
        !           386:                         */
        !           387:                        tempnlp = tmpalloc(lwidth(csetd.csettype),
        !           388:                                csetd.csettype, NOREG);
        !           389:                        putLV( (char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
        !           390:                                tempnlp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
        !           391:                        setran( ( csetd.csettype ) -> type );
        !           392:                        putleaf( PCC_ICON , set.lwrb , 0 , PCCT_INT , (char *) 0 );
        !           393:                        putop( PCC_CM , PCCT_INT );
        !           394:                        putleaf( PCC_ICON , set.uprbp , 0 , PCCT_INT , (char *) 0 );
        !           395:                        putop( PCC_CM , PCCT_INT );
        !           396:                        postcset( r , &csetd );
        !           397:                        putop( PCC_CALL , PCCT_INT );
        !           398:                    }
        !           399:                    return csetd.csettype;
        !           400: #              endif PC
        !           401: 
        !           402:        /*
        !           403:         * Unary plus and minus
        !           404:         */
        !           405:        case T_PLUS:
        !           406:        case T_MINUS:
        !           407:                q = rvalue(r->un_expr.expr, NLNIL , RREQ );
        !           408:                if (q == NLNIL)
        !           409:                        return (NLNIL);
        !           410:                if (isnta(q, "id")) {
        !           411:                        error("Operand of %s must be integer or real, not %s", opname, nameof(q));
        !           412:                        return (NLNIL);
        !           413:                }
        !           414:                if (r->tag == T_MINUS) {
        !           415: #                  ifdef OBJ
        !           416:                        (void) put(1, O_NEG2 + (width(q) >> 2));
        !           417:                        return (isa(q, "d") ? q : nl+T4INT);
        !           418: #                  endif OBJ
        !           419: #                  ifdef PC
        !           420:                        if (isa(q, "i")) {
        !           421:                            sconv(p2type(q), PCCT_INT);
        !           422:                            putop( PCCOM_UNARY PCC_MINUS, PCCT_INT);
        !           423:                            return nl+T4INT;
        !           424:                        }
        !           425:                        putop( PCCOM_UNARY PCC_MINUS, PCCT_DOUBLE);
        !           426:                        return nl+TDOUBLE;
        !           427: #                  endif PC
        !           428:                }
        !           429:                return (q);
        !           430: 
        !           431:        case T_NOT:
        !           432:                q = rvalue(r->un_expr.expr, NLNIL , RREQ );
        !           433:                if (q == NLNIL)
        !           434:                        return (NLNIL);
        !           435:                if (isnta(q, "b")) {
        !           436:                        error("not must operate on a Boolean, not %s", nameof(q));
        !           437:                        return (NLNIL);
        !           438:                }
        !           439: #              ifdef OBJ
        !           440:                    (void) put(1, O_NOT);
        !           441: #              endif OBJ
        !           442: #              ifdef PC
        !           443:                    sconv(p2type(q), PCCT_INT);
        !           444:                    putop( PCC_NOT , PCCT_INT);
        !           445:                    sconv(PCCT_INT, p2type(q));
        !           446: #              endif PC
        !           447:                return (nl+T1BOOL);
        !           448: 
        !           449:        case T_AND:
        !           450:        case T_OR:
        !           451:                p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
        !           452: #              ifdef PC
        !           453:                    sconv(p2type(p),PCCT_INT);
        !           454: #              endif PC
        !           455:                p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
        !           456: #              ifdef PC
        !           457:                    sconv(p2type(p1),PCCT_INT);
        !           458: #              endif PC
        !           459:                if (p == NLNIL || p1 == NLNIL)
        !           460:                        return (NLNIL);
        !           461:                if (isnta(p, "b")) {
        !           462:                        error("Left operand of %s must be Boolean, not %s", opname, nameof(p));
        !           463:                        return (NLNIL);
        !           464:                }
        !           465:                if (isnta(p1, "b")) {
        !           466:                        error("Right operand of %s must be Boolean, not %s", opname, nameof(p1));
        !           467:                        return (NLNIL);
        !           468:                }
        !           469: #              ifdef OBJ
        !           470:                    (void) put(1, r->tag == T_AND ? O_AND : O_OR);
        !           471: #              endif OBJ
        !           472: #              ifdef PC
        !           473:                        /*
        !           474:                         * note the use of & and | rather than && and ||
        !           475:                         * to force evaluation of all the expressions.
        !           476:                         */
        !           477:                    putop( r->tag == T_AND ? PCC_AND : PCC_OR , PCCT_INT );
        !           478:                    sconv(PCCT_INT, p2type(p));
        !           479: #              endif PC
        !           480:                return (nl+T1BOOL);
        !           481: 
        !           482:        case T_DIVD:
        !           483: #              ifdef OBJ
        !           484:                    p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
        !           485:                    p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
        !           486: #              endif OBJ
        !           487: #              ifdef PC
        !           488:                        /*
        !           489:                         *      force these to be doubles for the divide
        !           490:                         */
        !           491:                    p = rvalue( r->expr_node.lhs , NLNIL , RREQ );
        !           492:                    sconv(p2type(p), PCCT_DOUBLE);
        !           493:                    p1 = rvalue( r->expr_node.rhs , NLNIL , RREQ );
        !           494:                    sconv(p2type(p1), PCCT_DOUBLE);
        !           495: #              endif PC
        !           496:                if (p == NLNIL || p1 == NLNIL)
        !           497:                        return (NLNIL);
        !           498:                if (isnta(p, "id")) {
        !           499:                        error("Left operand of / must be integer or real, not %s", nameof(p));
        !           500:                        return (NLNIL);
        !           501:                }
        !           502:                if (isnta(p1, "id")) {
        !           503:                        error("Right operand of / must be integer or real, not %s", nameof(p1));
        !           504:                        return (NLNIL);
        !           505:                }
        !           506: #              ifdef OBJ
        !           507:                    return gen(NIL, r->tag, width(p), width(p1));
        !           508: #              endif OBJ
        !           509: #              ifdef PC
        !           510:                    putop( PCC_DIV , PCCT_DOUBLE );
        !           511:                    return nl + TDOUBLE;
        !           512: #              endif PC
        !           513: 
        !           514:        case T_MULT:
        !           515:        case T_ADD:
        !           516:        case T_SUB:
        !           517: #              ifdef OBJ
        !           518:                    /*
        !           519:                     * get the type of the right hand side.
        !           520:                     * if it turns out to be a set,
        !           521:                     * use that type when getting
        !           522:                     * the type of the left hand side.
        !           523:                     * and then use the type of the left hand side
        !           524:                     * when generating code.
        !           525:                     * this will correctly decide the type of any
        !           526:                     * empty sets in the tree, since if the empty set 
        !           527:                     * is on the left hand side it will inherit
        !           528:                     * the type of the right hand side,
        !           529:                     * and if it's on the right hand side, its type (intset)
        !           530:                     * will be overridden by the type of the left hand side.
        !           531:                     * this is an awful lot of tree traversing, 
        !           532:                     * but it works.
        !           533:                     */
        !           534:                    codeoff();
        !           535:                    p1 = rvalue( r->expr_node.rhs , NLNIL , RREQ );
        !           536:                    codeon();
        !           537:                    if ( p1 == NLNIL ) {
        !           538:                        return NLNIL;
        !           539:                    }
        !           540:                    if (isa(p1, "t")) {
        !           541:                        codeoff();
        !           542:                        contype = rvalue(r->expr_node.lhs, p1, RREQ);
        !           543:                        codeon();
        !           544:                        if (contype == NLNIL) {
        !           545:                            return NLNIL;
        !           546:                        }
        !           547:                    }
        !           548:                    p = rvalue( r->expr_node.lhs , contype , RREQ );
        !           549:                    p1 = rvalue( r->expr_node.rhs , p , RREQ );
        !           550:                    if ( p == NLNIL || p1 == NLNIL )
        !           551:                            return NLNIL;
        !           552:                    if (isa(p, "id") && isa(p1, "id"))
        !           553:                        return (gen(NIL, r->tag, width(p), width(p1)));
        !           554:                    if (isa(p, "t") && isa(p1, "t")) {
        !           555:                            if (p != p1) {
        !           556:                                    error("Set types of operands of %s must be identical", opname);
        !           557:                                    return (NLNIL);
        !           558:                            }
        !           559:                            (void) gen(TSET, r->tag, width(p), 0);
        !           560:                            return (p);
        !           561:                    }
        !           562: #              endif OBJ
        !           563: #              ifdef PC
        !           564:                        /*
        !           565:                         * the second pass can't do
        !           566:                         *      long op double  or  double op long
        !           567:                         * so we have to know the type of both operands.
        !           568:                         * also, see the note for obj above on determining
        !           569:                         * the type of empty sets.
        !           570:                         */
        !           571:                    codeoff();
        !           572:                    p1 = rvalue(r->expr_node.rhs, NLNIL, RREQ);
        !           573:                    codeon();
        !           574:                    if ( isa( p1 , "id" ) ) {
        !           575:                        p = rvalue( r->expr_node.lhs , contype , RREQ );
        !           576:                        if ( ( p == NLNIL ) || ( p1 == NLNIL ) ) {
        !           577:                            return NLNIL;
        !           578:                        }
        !           579:                        tuac(p, p1, &rettype, (int *) (&ctype));
        !           580:                        p1 = rvalue( r->expr_node.rhs , contype , RREQ );
        !           581:                        tuac(p1, p, &rettype, (int *) (&ctype));
        !           582:                        if ( isa( p , "id" ) ) {
        !           583:                            putop( (int) mathop[r->tag - T_MULT], (int) ctype);
        !           584:                            return rettype;
        !           585:                        }
        !           586:                    }
        !           587:                    if ( isa( p1 , "t" ) ) {
        !           588:                        putleaf( PCC_ICON , 0 , 0
        !           589:                            , PCCM_ADDTYPE( PCCM_ADDTYPE( PCCTM_PTR | PCCT_STRTY , PCCTM_FTN )
        !           590:                                        , PCCTM_PTR )
        !           591:                            , setop[ r->tag - T_MULT ] );
        !           592:                        codeoff();
        !           593:                        contype = rvalue( r->expr_node.lhs, p1 , LREQ );
        !           594:                        codeon();
        !           595:                        if ( contype == NLNIL ) {
        !           596:                            return NLNIL;
        !           597:                        }
        !           598:                            /*
        !           599:                             *  allocate a temporary and use it
        !           600:                             */
        !           601:                        tempnlp = tmpalloc(lwidth(contype), contype, NOREG);
        !           602:                        putLV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
        !           603:                                tempnlp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
        !           604:                        p = rvalue( r->expr_node.lhs , contype , LREQ );
        !           605:                        if ( isa( p , "t" ) ) {
        !           606:                            putop( PCC_CM , PCCT_INT );
        !           607:                            if ( p == NLNIL || p1 == NLNIL ) {
        !           608:                                return NLNIL;
        !           609:                            }
        !           610:                            p1 = rvalue( r->expr_node.rhs , p , LREQ );
        !           611:                            if ( p != p1 ) {
        !           612:                                error("Set types of operands of %s must be identical", opname);
        !           613:                                return NLNIL;
        !           614:                            }
        !           615:                            putop( PCC_CM , PCCT_INT );
        !           616:                            putleaf( PCC_ICON , (int) (lwidth(p1)) / sizeof( long ) , 0
        !           617:                                    , PCCT_INT , (char *) 0 );
        !           618:                            putop( PCC_CM , PCCT_INT );
        !           619:                            putop( PCC_CALL , PCCTM_PTR | PCCT_STRTY );
        !           620:                            return p;
        !           621:                        }
        !           622:                    }
        !           623:                    if ( isnta( p1 , "idt" ) ) {
        !           624:                            /*
        !           625:                             *  find type of left operand for error message.
        !           626:                             */
        !           627:                        p = rvalue( r->expr_node.lhs , contype , RREQ );
        !           628:                    }
        !           629:                        /*
        !           630:                         *      don't give spurious error messages.
        !           631:                         */
        !           632:                    if ( p == NLNIL || p1 == NLNIL ) {
        !           633:                        return NLNIL;
        !           634:                    }
        !           635: #              endif PC
        !           636:                if (isnta(p, "idt")) {
        !           637:                        error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p));
        !           638:                        return (NLNIL);
        !           639:                }
        !           640:                if (isnta(p1, "idt")) {
        !           641:                        error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1));
        !           642:                        return (NLNIL);
        !           643:                }
        !           644:                error("Cannot mix sets with integers and reals as operands of %s", opname);
        !           645:                return (NLNIL);
        !           646: 
        !           647:        case T_MOD:
        !           648:        case T_DIV:
        !           649:                p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
        !           650: #              ifdef PC
        !           651:                    sconv(p2type(p), PCCT_INT);
        !           652: #              ifdef tahoe
        !           653:                    /* prepare for ediv workaround, see below. */
        !           654:                    if (r->tag == T_MOD) {
        !           655:                        (void) rvalue(r->expr_node.lhs, NLNIL, RREQ);
        !           656:                        sconv(p2type(p), PCCT_INT);
        !           657:                    }
        !           658: #              endif tahoe
        !           659: #              endif PC
        !           660:                p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
        !           661: #              ifdef PC
        !           662:                    sconv(p2type(p1), PCCT_INT);
        !           663: #              endif PC
        !           664:                if (p == NLNIL || p1 == NLNIL)
        !           665:                        return (NLNIL);
        !           666:                if (isnta(p, "i")) {
        !           667:                        error("Left operand of %s must be integer, not %s", opname, nameof(p));
        !           668:                        return (NLNIL);
        !           669:                }
        !           670:                if (isnta(p1, "i")) {
        !           671:                        error("Right operand of %s must be integer, not %s", opname, nameof(p1));
        !           672:                        return (NLNIL);
        !           673:                }
        !           674: #              ifdef OBJ
        !           675:                    return (gen(NIL, r->tag, width(p), width(p1)));
        !           676: #              endif OBJ
        !           677: #              ifdef PC
        !           678: #              ifndef tahoe
        !           679:                    putop( r->tag == T_DIV ? PCC_DIV : PCC_MOD , PCCT_INT );
        !           680:                    return ( nl + T4INT );
        !           681: #              else tahoe
        !           682:                    putop( PCC_DIV , PCCT_INT );
        !           683:                    if (r->tag == T_MOD) {
        !           684:                    /*
        !           685:                     * avoid f1 bug: PCC_MOD would generate an 'ediv',
        !           686:                     * which would reuire too many registers to evaluate
        !           687:                     * things like
        !           688:                     * var i:boolean;j:integer; i := (j+1) = (j mod 2);
        !           689:                     * so, instead of
        !           690:                     *                PCC_MOD
        !           691:                     *                  / \
        !           692:                     *                 p   p1
        !           693:                     * we put
        !           694:                     *                  PCC_MINUS
        !           695:                     *                    /   \
        !           696:                     *                   p   PCC_MUL               
        !           697:                     *                        /   \
        !           698:                     *                    PCC_DIV  p1
        !           699:                     *                      / \
        !           700:                     *                     p  p1
        !           701:                     *
        !           702:                     * we already have put p, p, p1, PCC_DIV. and now...
        !           703:                     */
        !           704:                            rvalue(r->expr_node.rhs, NLNIL , RREQ );
        !           705:                            sconv(p2type(p1), PCCT_INT);
        !           706:                            putop( PCC_MUL, PCCT_INT );
        !           707:                            putop( PCC_MINUS, PCCT_INT );
        !           708:                    }
        !           709:                    return ( nl + T4INT );
        !           710: #              endif tahoe
        !           711: #              endif PC
        !           712: 
        !           713:        case T_EQ:
        !           714:        case T_NE:
        !           715:        case T_LT:
        !           716:        case T_GT:
        !           717:        case T_LE:
        !           718:        case T_GE:
        !           719:                /*
        !           720:                 * Since there can be no, a priori, knowledge
        !           721:                 * of the context type should a constant string
        !           722:                 * or set arise, we must poke around to find such
        !           723:                 * a type if possible.  Since constant strings can
        !           724:                 * always masquerade as identifiers, this is always
        !           725:                 * necessary.
        !           726:                 * see the note in the obj section of case T_MULT above
        !           727:                 * for the determination of the base type of empty sets.
        !           728:                 */
        !           729:                codeoff();
        !           730:                p1 = rvalue(r->expr_node.rhs, NLNIL , RREQ );
        !           731:                codeon();
        !           732:                if (p1 == NLNIL)
        !           733:                        return (NLNIL);
        !           734:                contype = p1;
        !           735: #              ifdef OBJ
        !           736:                    if (p1->class == STR) {
        !           737:                            /*
        !           738:                             * For constant strings we want
        !           739:                             * the longest type so as to be
        !           740:                             * able to do padding (more importantly
        !           741:                             * avoiding truncation). For clarity,
        !           742:                             * we get this length here.
        !           743:                             */
        !           744:                            codeoff();
        !           745:                            p = rvalue(r->expr_node.lhs, NLNIL , RREQ );
        !           746:                            codeon();
        !           747:                            if (p == NLNIL)
        !           748:                                    return (NLNIL);
        !           749:                            if (width(p) > width(p1))
        !           750:                                    contype = p;
        !           751:                    }
        !           752:                    if (isa(p1, "t")) {
        !           753:                        codeoff();
        !           754:                        contype = rvalue(r->expr_node.lhs, p1, RREQ);
        !           755:                        codeon();
        !           756:                        if (contype == NLNIL) {
        !           757:                            return NLNIL;
        !           758:                        }
        !           759:                    }
        !           760:                    /*
        !           761:                     * Now we generate code for
        !           762:                     * the operands of the relational
        !           763:                     * operation.
        !           764:                     */
        !           765:                    p = rvalue(r->expr_node.lhs, contype , RREQ );
        !           766:                    if (p == NLNIL)
        !           767:                            return (NLNIL);
        !           768:                    p1 = rvalue(r->expr_node.rhs, p , RREQ );
        !           769:                    if (p1 == NLNIL)
        !           770:                            return (NLNIL);
        !           771: #              endif OBJ
        !           772: #              ifdef PC
        !           773:                    c1 = classify( p1 );
        !           774:                    if ( c1 == TSET || c1 == TSTR || c1 == TREC ) {
        !           775:                        putleaf( PCC_ICON , 0 , 0
        !           776:                                , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
        !           777:                                , c1 == TSET  ? relts[ r->tag - T_EQ ]
        !           778:                                              : relss[ r->tag - T_EQ ] );
        !           779:                            /*
        !           780:                             *  for [] and strings, comparisons are done on
        !           781:                             *  the maximum width of the two sides.
        !           782:                             *  for other sets, we have to ask the left side
        !           783:                             *  what type it is based on the type of the right.
        !           784:                             *  (this matters for intsets).
        !           785:                             */
        !           786:                        if ( c1 == TSTR ) {
        !           787:                            codeoff();
        !           788:                            p = rvalue( r->expr_node.lhs , NLNIL , LREQ );
        !           789:                            codeon();
        !           790:                            if ( p == NLNIL ) {
        !           791:                                return NLNIL;
        !           792:                            }
        !           793:                            if ( lwidth( p ) > lwidth( p1 ) ) {
        !           794:                                contype = p;
        !           795:                            }
        !           796:                        } else if ( c1 == TSET ) {
        !           797:                            codeoff();
        !           798:                            contype = rvalue(r->expr_node.lhs, p1, LREQ);
        !           799:                            codeon();
        !           800:                            if (contype == NLNIL) {
        !           801:                                return NLNIL;
        !           802:                            }
        !           803:                        } 
        !           804:                            /*
        !           805:                             *  put out the width of the comparison.
        !           806:                             */
        !           807:                        putleaf(PCC_ICON, (int) lwidth(contype), 0, PCCT_INT, (char *) 0);
        !           808:                            /*
        !           809:                             *  and the left hand side,
        !           810:                             *  for sets, strings, records
        !           811:                             */
        !           812:                        p = rvalue( r->expr_node.lhs , contype , LREQ );
        !           813:                        if ( p == NLNIL ) {
        !           814:                            return NLNIL;
        !           815:                        }
        !           816:                        putop( PCC_CM , PCCT_INT );
        !           817:                        p1 = rvalue( r->expr_node.rhs , p , LREQ );
        !           818:                        if ( p1 == NLNIL ) {
        !           819:                            return NLNIL;
        !           820:                        }
        !           821:                        putop( PCC_CM , PCCT_INT );
        !           822:                        putop( PCC_CALL , PCCT_INT );
        !           823:                    } else {
        !           824:                            /*
        !           825:                             *  the easy (scalar or error) case
        !           826:                             */
        !           827:                        p = rvalue( r->expr_node.lhs , contype , RREQ );
        !           828:                        if ( p == NLNIL ) {
        !           829:                            return NLNIL;
        !           830:                        }
        !           831:                            /*
        !           832:                             * since the second pass can't do
        !           833:                             *  long op double  or  double op long
        !           834:                             * we may have to do some coercing.
        !           835:                             */
        !           836:                        tuac(p, p1, &rettype, (int *) (&ctype));
        !           837:                        p1 = rvalue( r->expr_node.rhs , p , RREQ );
        !           838:                        if ( p1 == NLNIL ) {
        !           839:                            return NLNIL;
        !           840:                        }
        !           841:                        tuac(p1, p, &rettype, (int *) (&ctype));
        !           842:                        putop((int) relops[ r->tag - T_EQ ] , PCCT_INT );
        !           843:                        sconv(PCCT_INT, PCCT_CHAR);
        !           844:                    }
        !           845: #              endif PC
        !           846:                c = classify(p);
        !           847:                c1 = classify(p1);
        !           848:                if (nocomp(c) || nocomp(c1))
        !           849:                        return (NLNIL);
        !           850: #              ifdef OBJ
        !           851:                    g = NIL;
        !           852: #              endif
        !           853:                switch (c) {
        !           854:                        case TBOOL:
        !           855:                        case TCHAR:
        !           856:                                if (c != c1)
        !           857:                                        goto clash;
        !           858:                                break;
        !           859:                        case TINT:
        !           860:                        case TDOUBLE:
        !           861:                                if (c1 != TINT && c1 != TDOUBLE)
        !           862:                                        goto clash;
        !           863:                                break;
        !           864:                        case TSCAL:
        !           865:                                if (c1 != TSCAL)
        !           866:                                        goto clash;
        !           867:                                if (scalar(p) != scalar(p1))
        !           868:                                        goto nonident;
        !           869:                                break;
        !           870:                        case TSET:
        !           871:                                if (c1 != TSET)
        !           872:                                        goto clash;
        !           873:                                if ( opt( 's' ) &&
        !           874:                                    ( ( r->tag == T_LT) || (r->tag == T_GT) ) &&
        !           875:                                    ( line != nssetline ) ) {
        !           876:                                    nssetline = line;
        !           877:                                    standard();
        !           878:                                    error("%s comparison on sets is non-standard" , opname );
        !           879:                                }
        !           880:                                if (p != p1)
        !           881:                                        goto nonident;
        !           882: #                              ifdef OBJ
        !           883:                                    g = TSET;
        !           884: #                              endif
        !           885:                                break;
        !           886:                        case TREC:
        !           887:                                if ( c1 != TREC ) {
        !           888:                                    goto clash;
        !           889:                                }
        !           890:                                if ( p != p1 ) {
        !           891:                                    goto nonident;
        !           892:                                }
        !           893:                                if (r->tag != T_EQ && r->tag != T_NE) {
        !           894:                                        error("%s not allowed on records - only allow = and <>" , opname );
        !           895:                                        return (NLNIL);
        !           896:                                }
        !           897: #                              ifdef OBJ
        !           898:                                    g = TREC;
        !           899: #                              endif
        !           900:                                break;
        !           901:                        case TPTR:
        !           902:                        case TNIL:
        !           903:                                if (c1 != TPTR && c1 != TNIL)
        !           904:                                        goto clash;
        !           905:                                if (r->tag != T_EQ && r->tag != T_NE) {
        !           906:                                        error("%s not allowed on pointers - only allow = and <>" , opname );
        !           907:                                        return (NLNIL);
        !           908:                                }
        !           909:                                if (p != nl+TNIL && p1 != nl+TNIL && p != p1)
        !           910:                                        goto nonident;
        !           911:                                break;
        !           912:                        case TSTR:
        !           913:                                if (c1 != TSTR)
        !           914:                                        goto clash;
        !           915:                                if (width(p) != width(p1)) {
        !           916:                                        error("Strings not same length in %s comparison", opname);
        !           917:                                        return (NLNIL);
        !           918:                                }
        !           919: #                              ifdef OBJ
        !           920:                                    g = TSTR;
        !           921: #                              endif OBJ
        !           922:                                break;
        !           923:                        default:
        !           924:                                panic("rval2");
        !           925:                }
        !           926: #              ifdef OBJ
        !           927:                    return (gen(g, r->tag, width(p), width(p1)));
        !           928: #              endif OBJ
        !           929: #              ifdef PC
        !           930:                    return nl + TBOOL;
        !           931: #              endif PC
        !           932: clash:
        !           933:                error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname);
        !           934:                return (NLNIL);
        !           935: nonident:
        !           936:                error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname);
        !           937:                return (NLNIL);
        !           938: 
        !           939:        case T_IN:
        !           940:            rt = r->expr_node.rhs;
        !           941: #          ifdef OBJ
        !           942:                if (rt != TR_NIL && rt->tag == T_CSET) {
        !           943:                        (void) precset( rt , NLNIL , &csetd );
        !           944:                        p1 = csetd.csettype;
        !           945:                        if (p1 == NLNIL)
        !           946:                            return NLNIL;
        !           947:                        postcset( rt, &csetd);
        !           948:                    } else {
        !           949:                        p1 = stkrval(r->expr_node.rhs, NLNIL , (long) RREQ );
        !           950:                        rt = TR_NIL;
        !           951:                    }
        !           952: #              endif OBJ
        !           953: #              ifdef PC
        !           954:                    if (rt != TR_NIL && rt->tag == T_CSET) {
        !           955:                        if ( precset( rt , NLNIL , &csetd ) ) {
        !           956:                            putleaf( PCC_ICON , 0 , 0
        !           957:                                    , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
        !           958:                                    , "_IN" );
        !           959:                        } else {
        !           960:                            putleaf( PCC_ICON , 0 , 0
        !           961:                                    , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
        !           962:                                    , "_INCT" );
        !           963:                        }
        !           964:                        p1 = csetd.csettype;
        !           965:                        if (p1 == NIL)
        !           966:                            return NLNIL;
        !           967:                    } else {
        !           968:                        putleaf( PCC_ICON , 0 , 0
        !           969:                                , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
        !           970:                                , "_IN" );
        !           971:                        codeoff();
        !           972:                        p1 = rvalue(r->expr_node.rhs, NLNIL , LREQ );
        !           973:                        codeon();
        !           974:                    }
        !           975: #              endif PC
        !           976:                p = stkrval(r->expr_node.lhs, NLNIL , (long) RREQ );
        !           977:                if (p == NIL || p1 == NIL)
        !           978:                        return (NLNIL);
        !           979:                if (p1->class != (char) SET) {
        !           980:                        error("Right operand of 'in' must be a set, not %s", nameof(p1));
        !           981:                        return (NLNIL);
        !           982:                }
        !           983:                if (incompat(p, p1->type, r->expr_node.lhs)) {
        !           984:                        cerror("Index type clashed with set component type for 'in'");
        !           985:                        return (NLNIL);
        !           986:                }
        !           987:                setran(p1->type);
        !           988: #              ifdef OBJ
        !           989:                    if (rt == TR_NIL || csetd.comptime)
        !           990:                            (void) put(4, O_IN, width(p1), set.lwrb, set.uprbp);
        !           991:                    else
        !           992:                            (void) put(2, O_INCT,
        !           993:                                (int)(3 + csetd.singcnt + 2*csetd.paircnt));
        !           994: #              endif OBJ
        !           995: #              ifdef PC
        !           996:                    if ( rt == TR_NIL || rt->tag != T_CSET ) {
        !           997:                        putleaf( PCC_ICON , set.lwrb , 0 , PCCT_INT , (char *) 0 );
        !           998:                        putop( PCC_CM , PCCT_INT );
        !           999:                        putleaf( PCC_ICON , set.uprbp , 0 , PCCT_INT , (char *) 0 );
        !          1000:                        putop( PCC_CM , PCCT_INT );
        !          1001:                        p1 = rvalue( r->expr_node.rhs , NLNIL , LREQ );
        !          1002:                        if ( p1 == NLNIL ) {
        !          1003:                            return NLNIL;
        !          1004:                        }
        !          1005:                        putop( PCC_CM , PCCT_INT );
        !          1006:                    } else if ( csetd.comptime ) {
        !          1007:                        putleaf( PCC_ICON , set.lwrb , 0 , PCCT_INT , (char *) 0 );
        !          1008:                        putop( PCC_CM , PCCT_INT );
        !          1009:                        putleaf( PCC_ICON , set.uprbp , 0 , PCCT_INT , (char *) 0 );
        !          1010:                        putop( PCC_CM , PCCT_INT );
        !          1011:                        postcset( r->expr_node.rhs , &csetd );
        !          1012:                        putop( PCC_CM , PCCT_INT );
        !          1013:                    } else {
        !          1014:                        postcset( r->expr_node.rhs , &csetd );
        !          1015:                    }
        !          1016:                    putop( PCC_CALL , PCCT_INT );
        !          1017:                    sconv(PCCT_INT, PCCT_CHAR);
        !          1018: #              endif PC
        !          1019:                return (nl+T1BOOL);
        !          1020:        default:
        !          1021:                if (r->expr_node.lhs == TR_NIL)
        !          1022:                        return (NLNIL);
        !          1023:                switch (r->tag) {
        !          1024:                default:
        !          1025:                        panic("rval3");
        !          1026: 
        !          1027: 
        !          1028:                /*
        !          1029:                 * An octal number
        !          1030:                 */
        !          1031:                case T_BINT:
        !          1032:                        f.pdouble = a8tol(r->const_node.cptr);
        !          1033:                        goto conint;
        !          1034:        
        !          1035:                /*
        !          1036:                 * A decimal number
        !          1037:                 */
        !          1038:                case T_INT:
        !          1039:                        f.pdouble = atof(r->const_node.cptr);
        !          1040: conint:
        !          1041:                        if (f.pdouble > MAXINT || f.pdouble < MININT) {
        !          1042:                                error("Constant too large for this implementation");
        !          1043:                                return (NLNIL);
        !          1044:                        }
        !          1045:                        l = f.pdouble;
        !          1046: #                      ifdef OBJ
        !          1047:                            if (bytes(l, l) <= 2) {
        !          1048:                                    (void) put(2, O_CON2, ( short ) l);
        !          1049:                                    return (nl+T2INT);
        !          1050:                            }
        !          1051:                            (void) put(2, O_CON4, l); 
        !          1052:                            return (nl+T4INT);
        !          1053: #                      endif OBJ
        !          1054: #                      ifdef PC
        !          1055:                            switch (bytes(l, l)) {
        !          1056:                                case 1:
        !          1057:                                    putleaf(PCC_ICON, (int) l, 0, PCCT_CHAR, 
        !          1058:                                                (char *) 0);
        !          1059:                                    return nl+T1INT;
        !          1060:                                case 2:
        !          1061:                                    putleaf(PCC_ICON, (int) l, 0, PCCT_SHORT, 
        !          1062:                                                (char *) 0);
        !          1063:                                    return nl+T2INT;
        !          1064:                                case 4:
        !          1065:                                    putleaf(PCC_ICON, (int) l, 0, PCCT_INT,
        !          1066:                                                (char *) 0);
        !          1067:                                    return nl+T4INT;
        !          1068:                            }
        !          1069: #                      endif PC
        !          1070:        
        !          1071:                /*
        !          1072:                 * A floating point number
        !          1073:                 */
        !          1074:                case T_FINT:
        !          1075: #                      ifdef OBJ
        !          1076:                            (void) put(2, O_CON8, atof(r->const_node.cptr));
        !          1077: #                      endif OBJ
        !          1078: #                      ifdef PC
        !          1079:                            putCON8( atof( r->const_node.cptr ) );
        !          1080: #                      endif PC
        !          1081:                        return (nl+TDOUBLE);
        !          1082:        
        !          1083:                /*
        !          1084:                 * Constant strings.  Note that constant characters
        !          1085:                 * are constant strings of length one; there is
        !          1086:                 * no constant string of length one.
        !          1087:                 */
        !          1088:                case T_STRNG:
        !          1089:                        cp = r->const_node.cptr;
        !          1090:                        if (cp[1] == 0) {
        !          1091: #                              ifdef OBJ
        !          1092:                                    (void) put(2, O_CONC, cp[0]);
        !          1093: #                              endif OBJ
        !          1094: #                              ifdef PC
        !          1095:                                    putleaf( PCC_ICON , cp[0] , 0 , PCCT_CHAR ,
        !          1096:                                                (char *) 0 );
        !          1097: #                              endif PC
        !          1098:                                return (nl+T1CHAR);
        !          1099:                        }
        !          1100:                        goto cstrng;
        !          1101:                }
        !          1102:        
        !          1103:        }
        !          1104: }
        !          1105: 
        !          1106: /*
        !          1107:  * Can a class appear
        !          1108:  * in a comparison ?
        !          1109:  */
        !          1110: nocomp(c)
        !          1111:        int c;
        !          1112: {
        !          1113: 
        !          1114:        switch (c) {
        !          1115:                case TREC:
        !          1116:                        if ( line != reccompline ) {
        !          1117:                            reccompline = line;
        !          1118:                            warning();
        !          1119:                            if ( opt( 's' ) ) {
        !          1120:                                standard();
        !          1121:                            }
        !          1122:                            error("record comparison is non-standard");
        !          1123:                        }
        !          1124:                        break;
        !          1125:                case TFILE:
        !          1126:                case TARY:
        !          1127:                        error("%ss may not participate in comparisons", clnames[c]);
        !          1128:                        return (1);
        !          1129:        }
        !          1130:        return (NIL);
        !          1131: }
        !          1132: 
        !          1133:     /*
        !          1134:      * this is sort of like gconst, except it works on expression trees
        !          1135:      * rather than declaration trees, and doesn't give error messages for
        !          1136:      * non-constant things.
        !          1137:      * as a side effect this fills in the con structure that gconst uses.
        !          1138:      * this returns TRUE or FALSE.
        !          1139:      */
        !          1140: 
        !          1141: bool 
        !          1142: constval(r)
        !          1143:        register struct tnode *r;
        !          1144: {
        !          1145:        register struct nl *np;
        !          1146:        register struct tnode *cn;
        !          1147:        char *cp;
        !          1148:        int negd, sgnd;
        !          1149:        long ci;
        !          1150: 
        !          1151:        con.ctype = NIL;
        !          1152:        cn = r;
        !          1153:        negd = sgnd = 0;
        !          1154: loop:
        !          1155:            /*
        !          1156:             *  cn[2] is nil if error recovery generated a T_STRNG
        !          1157:             */
        !          1158:        if (cn == TR_NIL || cn->expr_node.lhs == TR_NIL)
        !          1159:                return FALSE;
        !          1160:        switch (cn->tag) {
        !          1161:                default:
        !          1162:                        return FALSE;
        !          1163:                case T_MINUS:
        !          1164:                        negd = 1 - negd;
        !          1165:                        /* and fall through */
        !          1166:                case T_PLUS:
        !          1167:                        sgnd++;
        !          1168:                        cn = cn->un_expr.expr;
        !          1169:                        goto loop;
        !          1170:                case T_NIL:
        !          1171:                        con.cpval = NIL;
        !          1172:                        con.cival = 0;
        !          1173:                        con.crval = con.cival;
        !          1174:                        con.ctype = nl + TNIL;
        !          1175:                        break;
        !          1176:                case T_VAR:
        !          1177:                        np = lookup(cn->var_node.cptr);
        !          1178:                        if (np == NLNIL || np->class != CONST) {
        !          1179:                                return FALSE;
        !          1180:                        }
        !          1181:                        if ( cn->var_node.qual != TR_NIL ) {
        !          1182:                                return FALSE;
        !          1183:                        }
        !          1184:                        con.ctype = np->type;
        !          1185:                        switch (classify(np->type)) {
        !          1186:                                case TINT:
        !          1187:                                        con.crval = np->range[0];
        !          1188:                                        break;
        !          1189:                                case TDOUBLE:
        !          1190:                                        con.crval = np->real;
        !          1191:                                        break;
        !          1192:                                case TBOOL:
        !          1193:                                case TCHAR:
        !          1194:                                case TSCAL:
        !          1195:                                        con.cival = np->value[0];
        !          1196:                                        con.crval = con.cival;
        !          1197:                                        break;
        !          1198:                                case TSTR:
        !          1199:                                        con.cpval = (char *) np->ptr[0];
        !          1200:                                        break;
        !          1201:                                default:
        !          1202:                                        con.ctype = NIL;
        !          1203:                                        return FALSE;
        !          1204:                        }
        !          1205:                        break;
        !          1206:                case T_BINT:
        !          1207:                        con.crval = a8tol(cn->const_node.cptr);
        !          1208:                        goto restcon;
        !          1209:                case T_INT:
        !          1210:                        con.crval = atof(cn->const_node.cptr);
        !          1211:                        if (con.crval > MAXINT || con.crval < MININT) {
        !          1212:                                derror("Constant too large for this implementation");
        !          1213:                                con.crval = 0;
        !          1214:                        }
        !          1215: restcon:
        !          1216:                        ci = con.crval;
        !          1217: #ifndef PI0
        !          1218:                        if (bytes(ci, ci) <= 2)
        !          1219:                                con.ctype = nl+T2INT;
        !          1220:                        else    
        !          1221: #endif
        !          1222:                                con.ctype = nl+T4INT;
        !          1223:                        break;
        !          1224:                case T_FINT:
        !          1225:                        con.ctype = nl+TDOUBLE;
        !          1226:                        con.crval = atof(cn->const_node.cptr);
        !          1227:                        break;
        !          1228:                case T_STRNG:
        !          1229:                        cp = cn->const_node.cptr;
        !          1230:                        if (cp[1] == 0) {
        !          1231:                                con.ctype = nl+T1CHAR;
        !          1232:                                con.cival = cp[0];
        !          1233:                                con.crval = con.cival;
        !          1234:                                break;
        !          1235:                        }
        !          1236:                        con.ctype = nl+TSTR;
        !          1237:                        con.cpval = cp;
        !          1238:                        break;
        !          1239:        }
        !          1240:        if (sgnd) {
        !          1241:                if (isnta(con.ctype, "id")) {
        !          1242:                        derror("%s constants cannot be signed", nameof(con.ctype));
        !          1243:                        return FALSE;
        !          1244:                } else if (negd)
        !          1245:                        con.crval = -con.crval;
        !          1246:        }
        !          1247:        return TRUE;
        !          1248: }

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