home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / const.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  7.2 KB  |  312 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[] = "@(#)const.c    5.5 (Berkeley) 4/16/91";
  36. #endif /* not lint */
  37.  
  38. #include "whoami.h"
  39. #include "0.h"
  40. #include "tree.h"
  41. #include "tree_ty.h"
  42.  
  43. /*
  44.  * Const enters the definitions
  45.  * of the constant declaration
  46.  * part into the namelist.
  47.  */
  48. #ifndef PI1
  49. constbeg( lineofyconst , linenum )
  50.     int    lineofyconst, linenum;
  51. {
  52.     static bool    const_order = FALSE;
  53.     static bool    const_seen = FALSE;
  54.  
  55. /*
  56.  * this allows for multiple declaration
  57.  * parts, unless the "standard" option
  58.  * has been specified.
  59.  * If a routine segment is being compiled,
  60.  * do level one processing.
  61.  */
  62.  
  63.     if (!progseen)
  64.         level1();
  65.     line = lineofyconst;
  66.     if (parts[ cbn ] & (TPRT|VPRT|RPRT)) {
  67.         if ( opt( 's' ) ) {
  68.         standard();
  69.         error("Constant declarations should precede type, var and routine declarations");
  70.         } else {
  71.         if ( !const_order ) {
  72.             const_order = TRUE;
  73.             warning();
  74.             error("Constant declarations should precede type, var and routine declarations");
  75.         }
  76.         }
  77.     }
  78.     if (parts[ cbn ] & CPRT) {
  79.         if ( opt( 's' ) ) {
  80.         standard();
  81.         error("All constants should be declared in one const part");
  82.         } else {
  83.         if ( !const_seen ) {
  84.             const_seen = TRUE;
  85.             warning();
  86.             error("All constants should be declared in one const part");
  87.         }
  88.         }
  89.     }
  90.     parts[ cbn ] |= CPRT;
  91. }
  92. #endif PI1
  93.  
  94. constant(cline, cid, cdecl)
  95.     int cline;
  96.     register char *cid;
  97.     register struct tnode *cdecl;
  98. {
  99.     register struct nl *np;
  100.  
  101. #ifdef PI0
  102.     send(REVCNST, cline, cid, cdecl);
  103. #endif
  104.     line = cline;
  105.     gconst(cdecl);
  106.     np = enter(defnl(cid, CONST, con.ctype, con.cival));
  107. #ifndef PI0
  108.     np->nl_flags |= NMOD;
  109. #endif
  110.  
  111. #ifdef PC
  112.     if (cbn == 1) {
  113.         stabgconst( cid , line );
  114.     }
  115. #endif PC
  116.  
  117. #    ifdef PTREE
  118.         {
  119.         pPointer    Const = ConstDecl( cid , cdecl );
  120.         pPointer    *Consts;
  121.  
  122.         pSeize( PorFHeader[ nesting ] );
  123.         Consts = &( pDEF( PorFHeader[ nesting ] ).PorFConsts );
  124.         *Consts = ListAppend( *Consts , Const );
  125.         pRelease( PorFHeader[ nesting ] );
  126.         }
  127. #    endif
  128.     if (con.ctype == NIL)
  129.         return;
  130.     if ( con.ctype == nl + TSTR )
  131.         np->ptr[0] = (struct nl *) con.cpval;
  132.     if (isa(con.ctype, "i"))
  133.         np->range[0] = con.crval;
  134.     else if (isa(con.ctype, "d"))
  135.         np->real = con.crval;
  136. #       ifdef PC
  137.         if (cbn == 1 && con.ctype != NIL) {
  138.             stabconst(np);
  139.         }
  140. #       endif
  141. }
  142.  
  143. #ifndef PI0
  144. #ifndef PI1
  145. constend()
  146. {
  147.  
  148. }
  149. #endif
  150. #endif
  151.  
  152. /*
  153.  * Gconst extracts
  154.  * a constant declaration
  155.  * from the tree for it.
  156.  * only types of constants
  157.  * are integer, reals, strings
  158.  * and scalars, the first two
  159.  * being possibly signed.
  160.  */
  161. gconst(c_node)
  162.     struct tnode *c_node;
  163. {
  164.     register struct nl *np;
  165.     register struct tnode *cn;
  166.     char *cp;
  167.     int negd, sgnd;
  168.     long ci;
  169.  
  170.     con.ctype = NIL;
  171.     cn = c_node;
  172.     negd = sgnd = 0;
  173. loop:
  174.     if (cn == TR_NIL || cn->sign_const.number == TR_NIL)
  175.         return;
  176.     switch (cn->tag) {
  177.         default:
  178.             panic("gconst");
  179.         case T_MINUSC:
  180.             negd = 1 - negd;
  181.         case T_PLUSC:
  182.             sgnd++;
  183.             cn = cn->sign_const.number;
  184.             goto loop;
  185.         case T_ID:
  186.             np = lookup(cn->char_const.cptr);
  187.             if (np == NLNIL)
  188.                 return;
  189.             if (np->class != CONST) {
  190.                 derror("%s is a %s, not a constant as required", cn->char_const.cptr, classes[np->class]);
  191.                 return;
  192.             }
  193.             con.ctype = np->type;
  194.             switch (classify(np->type)) {
  195.                 case TINT:
  196.                     con.crval = np->range[0];
  197.                     break;
  198.                 case TDOUBLE:
  199.                     con.crval = np->real;
  200.                     break;
  201.                 case TBOOL:
  202.                 case TCHAR:
  203.                 case TSCAL:
  204.                     con.cival = np->value[0];
  205.                     con.crval = con.cival;
  206.                     break;
  207.                 case TSTR:
  208.                     con.cpval = (char *) np->ptr[0];
  209.                     break;
  210.                 case NIL:
  211.                     con.ctype = NIL;
  212.                     return;
  213.                 default:
  214.                     panic("gconst2");
  215.             }
  216.             break;
  217.         case T_CBINT:
  218.             con.crval = a8tol(cn->char_const.cptr);
  219.             goto restcon;
  220.         case T_CINT:
  221.             con.crval = atof(cn->char_const.cptr);
  222.             if (con.crval > MAXINT || con.crval < MININT) {
  223.                 derror("Constant too large for this implementation");
  224.                 con.crval = 0;
  225.             }
  226. restcon:
  227.             ci = con.crval;
  228. #ifndef PI0
  229.             if (bytes(ci, ci) <= 2)
  230.                 con.ctype = nl+T2INT;
  231.             else    
  232. #endif
  233.                 con.ctype = nl+T4INT;
  234.             break;
  235.         case T_CFINT:
  236.             con.ctype = nl+TDOUBLE;
  237.             con.crval = atof(cn->char_const.cptr);
  238.             break;
  239.         case T_CSTRNG:
  240.             cp = cn->char_const.cptr;
  241.             if (cp[1] == 0) {
  242.                 con.ctype = nl+T1CHAR;
  243.                 con.cival = cp[0];
  244.                 con.crval = con.cival;
  245.                 break;
  246.             }
  247.             con.ctype = nl+TSTR;
  248.             con.cpval = savestr(cp);
  249.             break;
  250.     }
  251.     if (sgnd) {
  252.         if (isnta((struct nl *) con.ctype, "id"))
  253.             derror("%s constants cannot be signed",
  254.                 nameof((struct nl *) con.ctype));
  255.         else {
  256.             if (negd)
  257.                 con.crval = -con.crval;
  258.             ci = con.crval;
  259.         }
  260.     }
  261. }
  262.  
  263. #ifndef PI0
  264. isconst(cn)
  265.     register struct tnode *cn;
  266. {
  267.  
  268.     if (cn == TR_NIL)
  269.         return (1);
  270.     switch (cn->tag) {
  271.         case T_MINUS:
  272.             cn->tag = T_MINUSC;
  273.             cn->sign_const.number = 
  274.                      cn->un_expr.expr;
  275.             return (isconst(cn->sign_const.number));
  276.         case T_PLUS:
  277.             cn->tag = T_PLUSC;
  278.             cn->sign_const.number = 
  279.                      cn->un_expr.expr;
  280.             return (isconst(cn->sign_const.number));
  281.         case T_VAR:
  282.             if (cn->var_node.qual != TR_NIL)
  283.                 return (0);
  284.             cn->tag = T_ID;
  285.             cn->char_const.cptr = 
  286.                     cn->var_node.cptr;
  287.             return (1);
  288.         case T_BINT:
  289.             cn->tag = T_CBINT;
  290.             cn->char_const.cptr = 
  291.                 cn->const_node.cptr;
  292.             return (1);
  293.         case T_INT:
  294.             cn->tag = T_CINT;
  295.             cn->char_const.cptr = 
  296.                 cn->const_node.cptr;
  297.             return (1);
  298.         case T_FINT:
  299.             cn->tag = T_CFINT;
  300.             cn->char_const.cptr = 
  301.                 cn->const_node.cptr;
  302.             return (1);
  303.         case T_STRNG:
  304.             cn->tag = T_CSTRNG;
  305.             cn->char_const.cptr = 
  306.                 cn->const_node.cptr;
  307.             return (1);
  308.     }
  309.     return (0);
  310. }
  311. #endif
  312.