home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / stkrval.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  10.5 KB  |  465 lines
  1. /*-
  2.  * Copyright (c) 1980 The Regents of the University of California.
  3.  * All rights reserved.
  4.  *
  5.  * Redistribution and use in source and binary forms, with or without
  6.  * modification, are permitted provided that the following conditions
  7.  * are met:
  8.  * 1. Redistributions of source code must retain the above copyright
  9.  *    notice, this list of conditions and the following disclaimer.
  10.  * 2. Redistributions in binary form must reproduce the above copyright
  11.  *    notice, this list of conditions and the following disclaimer in the
  12.  *    documentation and/or other materials provided with the distribution.
  13.  * 3. All advertising materials mentioning features or use of this software
  14.  *    must display the following acknowledgement:
  15.  *    This product includes software developed by the University of
  16.  *    California, Berkeley and its contributors.
  17.  * 4. Neither the name of the University nor the names of its contributors
  18.  *    may be used to endorse or promote products derived from this software
  19.  *    without specific prior written permission.
  20.  *
  21.  * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
  22.  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  23.  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  24.  * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  25.  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  26.  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  27.  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  28.  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  29.  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  30.  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  31.  * SUCH DAMAGE.
  32.  */
  33.  
  34. #ifndef lint
  35. static char sccsid[] = "@(#)stkrval.c    5.3 (Berkeley) 4/16/91";
  36. #endif /* not lint */
  37.  
  38. #include "whoami.h"
  39. #include "0.h"
  40. #include "tree.h"
  41. #include "opcode.h"
  42. #include "objfmt.h"
  43. #include "align.h"
  44. #ifdef PC
  45. #   include <pcc.h>
  46. #endif PC
  47. #include "tree_ty.h"
  48.  
  49. /*
  50.  * stkrval Rvalue - an expression, and coerce it to be a stack quantity.
  51.  *
  52.  * Contype is the type that the caller would prefer, nand is important
  53.  * if constant sets or constant strings are involved, the latter
  54.  * because of string padding.
  55.  */
  56. /*
  57.  * for the obj version, this is a copy of rvalue hacked to use fancy new
  58.  * push-onto-stack-and-convert opcodes.
  59.  * for the pc version, i just call rvalue and convert if i have to,
  60.  * based on the return type of rvalue.
  61.  */
  62. struct nl *
  63. stkrval(r, contype , required )
  64.     register struct tnode *r;
  65.     struct nl *contype;
  66.     long    required;
  67. {
  68.     register struct nl *p;
  69.     register struct nl *q;
  70.     register char *cp, *cp1;
  71.     register int c, w;
  72.     struct tnode *pt;
  73.     long l;
  74.     union
  75.     {
  76.         double pdouble;
  77.         long   plong[2];
  78.     }f;
  79.  
  80.     if (r == TR_NIL)
  81.         return (NLNIL);
  82.     if (nowexp(r))
  83.         return (NLNIL);
  84.     /*
  85.      * The root of the tree tells us what sort of expression we have.
  86.      */
  87.     switch (r->tag) {
  88.  
  89.     /*
  90.      * The constant nil
  91.      */
  92.     case T_NIL:
  93. #        ifdef OBJ
  94.             (void) put(2, O_CON14, 0);
  95. #        endif OBJ
  96. #        ifdef PC
  97.             putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 );
  98. #        endif PC
  99.         return (nl+TNIL);
  100.  
  101.     case T_FCALL:
  102.     case T_VAR:
  103.         p = lookup(r->var_node.cptr);
  104.         if (p == NLNIL || p->class == BADUSE)
  105.             return (NLNIL);
  106.         switch (p->class) {
  107.         case VAR:
  108.             /*
  109.              * if a variable is
  110.              * qualified then get
  111.              * the rvalue by a
  112.              * stklval and an ind.
  113.              */
  114.             if (r->var_node.qual != TR_NIL)
  115.                 goto ind;
  116.             q = p->type;
  117.             if (q == NLNIL)
  118.                 return (NLNIL);
  119.             if (classify(q) == TSTR)
  120.                 return(stklval(r, NOFLAGS));
  121. #            ifdef OBJ
  122.                 return (stackRV(p));
  123. #            endif OBJ
  124. #            ifdef PC
  125.                 q = rvalue( r , contype , (int) required );
  126.                 if (isa(q, "sbci")) {
  127.                 sconv(p2type(q),PCCT_INT);
  128.                 }
  129.                 return q;
  130. #            endif PC
  131.  
  132.         case WITHPTR:
  133.         case REF:
  134.             /*
  135.              * A stklval for these
  136.              * is actually what one
  137.              * might consider a rvalue.
  138.              */
  139. ind:
  140.             q = stklval(r, NOFLAGS);
  141.             if (q == NLNIL)
  142.                 return (NLNIL);
  143.             if (classify(q) == TSTR)
  144.                 return(q);
  145. #            ifdef OBJ
  146.                 w = width(q);
  147.                 switch (w) {
  148.                     case 8:
  149.                         (void) put(1, O_IND8);
  150.                         return(q);
  151.                     case 4:
  152.                         (void) put(1, O_IND4);
  153.                         return(q);
  154.                     case 2:
  155.                         (void) put(1, O_IND24);
  156.                         return(q);
  157.                     case 1:
  158.                         (void) put(1, O_IND14);
  159.                         return(q);
  160.                     default:
  161.                         (void) put(2, O_IND, w);
  162.                         return(q);
  163.                 }
  164. #            endif OBJ
  165. #            ifdef PC
  166.                 if ( required == RREQ ) {
  167.                 putop( PCCOM_UNARY PCC_MUL , p2type( q ) );
  168.                 if (isa(q,"sbci")) {
  169.                     sconv(p2type(q),PCCT_INT);
  170.                 }
  171.                 }
  172.                 return q;
  173. #            endif PC
  174.  
  175.         case CONST:
  176.             if (r->var_node.qual != TR_NIL) {
  177.                 error("%s is a constant and cannot be qualified", r->var_node.cptr);
  178.                 return (NLNIL);
  179.             }
  180.             q = p->type;
  181.             if (q == NLNIL)
  182.                 return (NLNIL);
  183.             if (q == nl+TSTR) {
  184.                 /*
  185.                  * Find the size of the string
  186.                  * constant if needed.
  187.                  */
  188.                 cp = (char *) p->ptr[0];
  189. cstrng:
  190.                 cp1 = cp;
  191.                 for (c = 0; *cp++; c++)
  192.                     continue;
  193.                 w = c;
  194.                 if (contype != NIL && !opt('s')) {
  195.                     if (width(contype) < c && classify(contype) == TSTR) {
  196.                         error("Constant string too long");
  197.                         return (NLNIL);
  198.                     }
  199.                     w = width(contype);
  200.                 }
  201. #                ifdef OBJ
  202.                     (void) put(2, O_LVCON, lenstr(cp1, w - c));
  203.                     putstr(cp1, w - c);
  204. #                endif OBJ
  205. #                ifdef PC
  206.                     putCONG( cp1 , w , LREQ );
  207. #                endif PC
  208.                 /*
  209.                  * Define the string temporarily
  210.                  * so later people can know its
  211.                  * width.
  212.                  * cleaned out by stat.
  213.                  */
  214.                 q = defnl((char *) 0, STR, NLNIL, w);
  215.                 q->type = q;
  216.                 return (q);
  217.             }
  218.             if (q == nl+T1CHAR) {
  219. #                ifdef OBJ
  220.                 (void) put(2, O_CONC4, (int)p->value[0]);
  221. #                endif OBJ
  222. #                ifdef PC
  223.                 putleaf(PCC_ICON, p -> value[0], 0, PCCT_INT, 
  224.                         (char *) 0);
  225. #                endif PC
  226.                 return(q);
  227.             }
  228.             /*
  229.              * Every other kind of constant here
  230.              */
  231. #            ifdef OBJ
  232.                 switch (width(q)) {
  233.                 case 8:
  234. #ifndef DEBUG
  235.                     (void) put(2, O_CON8, p->real);
  236.                     return(q);
  237. #else
  238.                     if (hp21mx) {
  239.                         f.pdouble = p->real;
  240.                         conv((int *) (&f.pdouble));
  241.                         l = f.plong[1];
  242.                         (void) put(2, O_CON4, l);
  243.                     } else
  244.                         (void) put(2, O_CON8, p->real);
  245.                     return(q);
  246. #endif
  247.                 case 4:
  248.                     (void) put(2, O_CON4, p->range[0]);
  249.                     return(q);
  250.                 case 2:
  251.                     (void) put(2, O_CON24, (short)p->range[0]);
  252.                     return(q);
  253.                 case 1:
  254.                     (void) put(2, O_CON14, p->value[0]);
  255.                     return(q);
  256.                 default:
  257.                     panic("stkrval");
  258.                 }
  259. #            endif OBJ
  260. #            ifdef PC
  261.                 q = rvalue( r , contype , (int) required );
  262.                 if (isa(q,"sbci")) {
  263.                 sconv(p2type(q),PCCT_INT);
  264.                 }
  265.                 return q;
  266. #            endif PC
  267.  
  268.         case FUNC:
  269.         case FFUNC:
  270.             /*
  271.              * Function call
  272.              */
  273.             pt = r->var_node.qual;
  274.             if (pt != TR_NIL) {
  275.                 switch (pt->list_node.list->tag) {
  276.                 case T_PTR:
  277.                 case T_ARGL:
  278.                 case T_ARY:
  279.                 case T_FIELD:
  280.                     error("Can't qualify a function result value");
  281.                     return (NLNIL);
  282.                 }
  283.             }
  284. #            ifdef OBJ
  285.                 q = p->type;
  286.                 if (classify(q) == TSTR) {
  287.                     c = width(q);
  288.                     (void) put(2, O_LVCON,
  289.                     roundup(c+1, (long) A_SHORT));
  290.                     putstr("", c);
  291.                     (void) put(1, PTR_DUP);
  292.                     p = funccod(r);
  293.                     (void) put(2, O_AS, c);
  294.                     return(p);
  295.                 }
  296.                 p = funccod(r);
  297.                 if (width(p) <= 2)
  298.                     (void) put(1, O_STOI);
  299. #            endif OBJ
  300. #            ifdef PC
  301.                 p = pcfunccod( r );
  302.                 if (isa(p,"sbci")) {
  303.                 sconv(p2type(p),PCCT_INT);
  304.                 }
  305. #            endif PC
  306.             return (p);
  307.  
  308.         case TYPE:
  309.             error("Type names (e.g. %s) allowed only in declarations", p->symbol);
  310.             return (NLNIL);
  311.  
  312.         case PROC:
  313.         case FPROC:
  314.             error("Procedure %s found where expression required", p->symbol);
  315.             return (NLNIL);
  316.         default:
  317.             panic("stkrvid");
  318.         }
  319.     case T_PLUS:
  320.     case T_MINUS:
  321.     case T_NOT:
  322.     case T_AND:
  323.     case T_OR:
  324.     case T_DIVD:
  325.     case T_MULT:
  326.     case T_SUB:
  327.     case T_ADD:
  328.     case T_MOD:
  329.     case T_DIV:
  330.     case T_EQ:
  331.     case T_NE:
  332.     case T_GE:
  333.     case T_LE:
  334.     case T_GT:
  335.     case T_LT:
  336.     case T_IN:
  337.         p = rvalue(r, contype , (int) required );
  338. #        ifdef OBJ
  339.             if (width(p) <= 2)
  340.                 (void) put(1, O_STOI);
  341. #        endif OBJ
  342. #        ifdef PC
  343.             if (isa(p,"sbci")) {
  344.             sconv(p2type(p),PCCT_INT);
  345.             }
  346. #        endif PC
  347.         return (p);
  348.     case T_CSET:
  349.         p = rvalue(r, contype , (int) required );
  350.         return (p);
  351.     default:
  352.         if (r->const_node.cptr == (char *) NIL)
  353.             return (NLNIL);
  354.         switch (r->tag) {
  355.         default:
  356.             panic("stkrval3");
  357.  
  358.         /*
  359.          * An octal number
  360.          */
  361.         case T_BINT:
  362.             f.pdouble = a8tol(r->const_node.cptr);
  363.             goto conint;
  364.     
  365.         /*
  366.          * A decimal number
  367.          */
  368.         case T_INT:
  369.             f.pdouble = atof(r->const_node.cptr);
  370. conint:
  371.             if (f.pdouble > MAXINT || f.pdouble < MININT) {
  372.                 error("Constant too large for this implementation");
  373.                 return (NLNIL);
  374.             }
  375.             l = f.pdouble;
  376.             if (bytes(l, l) <= 2) {
  377. #                ifdef OBJ
  378.                 (void) put(2, O_CON24, (short)l);
  379. #                endif OBJ
  380. #                ifdef PC
  381.                 putleaf( PCC_ICON , (short) l , 0 , PCCT_INT , 
  382.                         (char *) 0 );
  383. #                endif PC
  384.                 return(nl+T4INT);
  385.             }
  386. #            ifdef OBJ
  387.                 (void) put(2, O_CON4, l); 
  388. #            endif OBJ
  389. #            ifdef PC
  390.                 putleaf( PCC_ICON , (int) l , 0 , PCCT_INT , (char *) 0 );
  391. #            endif PC
  392.             return (nl+T4INT);
  393.     
  394.         /*
  395.          * A floating point number
  396.          */
  397.         case T_FINT:
  398. #               ifdef OBJ
  399.                 (void) put(2, O_CON8, atof(r->const_node.cptr));
  400. #            endif OBJ
  401. #            ifdef PC
  402.                 putCON8( atof( r->const_node.cptr ) );
  403. #            endif PC
  404.             return (nl+TDOUBLE);
  405.     
  406.         /*
  407.          * Constant strings.  Note that constant characters
  408.          * are constant strings of length one; there is
  409.          * no constant string of length one.
  410.          */
  411.         case T_STRNG:
  412.             cp = r->const_node.cptr;
  413.             if (cp[1] == 0) {
  414. #                ifdef OBJ
  415.                     (void) put(2, O_CONC4, cp[0]);
  416. #                endif OBJ
  417. #                ifdef PC
  418.                     putleaf( PCC_ICON , cp[0] , 0 , PCCT_INT , 
  419.                         (char *) 0 );
  420. #                endif PC
  421.                 return(nl+T1CHAR);
  422.             }
  423.             goto cstrng;
  424.         }
  425.     
  426.     }
  427. }
  428.  
  429. #ifdef OBJ
  430. /*
  431.  * push a value onto the interpreter stack, longword aligned.
  432.  */
  433. struct nl 
  434. *stackRV(p)
  435.     struct nl *p;
  436. {
  437.     struct nl *q;
  438.     int w, bn;
  439.  
  440.     q = p->type;
  441.     if (q == NLNIL)
  442.         return (NLNIL);
  443.     bn = BLOCKNO(p->nl_block);
  444.     w = width(q);
  445.     switch (w) {
  446.     case 8:
  447.         (void) put(2, O_RV8 | bn << 8+INDX, (int)p->value[0]);
  448.         break;
  449.     case 4:
  450.         (void) put(2, O_RV4 | bn << 8+INDX, (int)p->value[0]);
  451.         break;
  452.     case 2:
  453.         (void) put(2, O_RV24 | bn << 8+INDX, (int)p->value[0]);
  454.         break;
  455.     case 1:
  456.         (void) put(2, O_RV14 | bn << 8+INDX, (int)p->value[0]);
  457.         break;
  458.     default:
  459.         (void) put(3, O_RV | bn << 8+INDX, (int)p->value[0], w);
  460.         break;
  461.     }
  462.     return (q);
  463. }
  464. #endif OBJ
  465.