home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / cset.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  14.4 KB  |  499 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[] = "@(#)cset.c    5.2 (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 "tree_ty.h"
  44. #ifdef PC
  45. #include "pc.h"
  46. #include <pcc.h>
  47. #include "align.h"
  48. #endif PC
  49.  
  50. /*
  51.  * CONSETS causes compile time constant sets to be constructed here.
  52.  *
  53.  * COMPSETSZE defines the maximum number of longs to be used in
  54.  *    constant set construction
  55.  */
  56. #define CONSETS
  57. #define COMPSETSZE 10
  58.  
  59. #define BITSPERBYTE 8
  60. #define BITSPERLONG 32
  61. #define LG2BITSBYTE 3
  62. #define MSKBITSBYTE 0x07
  63. #define LG2BITSLONG 5
  64. #define MSKBITSLONG 0x1f
  65.  
  66. /*
  67.  *    rummage through a `constant' set (i.e. anything within [ ]'s) tree
  68.  *    and decide if this is a compile time constant set or a runtime set.
  69.  *    this information is returned in a structure passed from the caller.
  70.  *    while rummaging, this also reorders the tree so that all ranges
  71.  *    preceed all singletons.
  72.  */
  73. bool
  74. precset( r , settype , csetp )
  75.     struct tnode    *r;
  76.     struct nl    *settype;
  77.     struct csetstr    *csetp;
  78. {
  79.     register struct tnode    *e;
  80.     register struct nl    *t;
  81.     register struct nl    *exptype;
  82.     register struct tnode    *el;
  83.     register struct tnode    *pairp;
  84.     register struct tnode    *singp;
  85.     struct tnode        *ip;
  86.     int            lower;
  87.     int            upper;
  88.     bool            setofint;
  89.  
  90.     csetp -> csettype = NIL;
  91.     csetp -> paircnt = 0;
  92.     csetp -> singcnt = 0;
  93.     csetp -> comptime = TRUE;
  94.     setofint = FALSE;
  95.     if ( settype != NIL ) {
  96.         if ( settype -> class == SET ) {
  97.             /*
  98.              *    the easy case, we are told the type of the set.
  99.              */
  100.         exptype = settype -> type;
  101.         } else {
  102.             /*
  103.              *    we are told the type, but it's not a set
  104.              *    supposedly possible if someone tries
  105.              *    e.g string context [1,2] = 'abc'
  106.              */
  107.         error("Constant set involved in non set context");
  108.         return csetp -> comptime;
  109.         }
  110.     } else {
  111.         /*
  112.          * So far we have no indication
  113.          * of what the set type should be.
  114.          * We "look ahead" and try to infer
  115.          * The type of the constant set
  116.          * by evaluating one of its members.
  117.          */
  118.         e = r->cset_node.el_list;
  119.         if (e == NIL) {
  120.             /*
  121.              *    tentative for [], return type of `intset'
  122.              */
  123.         settype = lookup( (char *) intset );
  124.         if ( settype == NIL ) {
  125.             panic( "empty set" );
  126.         }
  127.         settype = settype -> type;
  128.         if ( settype == NIL ) {
  129.             return csetp -> comptime;
  130.         }
  131.         if ( isnta( settype , "t" ) ) {
  132.             error("Set default type \"intset\" is not a set");
  133.             return csetp -> comptime;
  134.         }
  135.         csetp -> csettype = settype;
  136.         setran( settype -> type );
  137.         if (((set.uprbp + 1) >> LG2BITSLONG) >= COMPSETSZE)
  138.             csetp -> comptime = FALSE;
  139.         return csetp -> comptime;
  140.         }
  141.         e = e->list_node.list;
  142.         if (e == NIL) {
  143.         return csetp -> comptime;
  144.         }
  145.         if (e->tag == T_RANG) {
  146.             e = e->rang.expr1;
  147.         }
  148.         codeoff();
  149.         t = rvalue(e, NLNIL , RREQ );
  150.         codeon();
  151.         if (t == NIL) {
  152.         return csetp -> comptime;
  153.         }
  154.         /*
  155.          * The type of the set, settype, is
  156.          * deemed to be a set of the base type
  157.          * of t, which we call exptype.  If,
  158.          * however, this would involve a
  159.          * "set of integer", we cop out
  160.          * and use "intset"'s current scoped
  161.          * type instead.
  162.          */
  163.         if (isa(t, "r")) {
  164.             error("Sets may not have 'real' elements");
  165.             return csetp -> comptime;
  166.         }
  167.         if (isnta(t, "bcsi")) {
  168.             error("Set elements must be scalars, not %ss", nameof(t));
  169.             return csetp -> comptime;
  170.         }
  171.         if (isa(t, "i")) {
  172.             settype = lookup((char *) intset);
  173.             if (settype == NIL)
  174.                 panic("intset");
  175.             settype = settype->type;
  176.             if (settype == NIL)
  177.                 return csetp -> comptime;
  178.             if (isnta(settype, "t")) {
  179.                 error("Set default type \"intset\" is not a set");
  180.                 return csetp -> comptime;
  181.             }
  182.             exptype = settype->type;
  183.             /*
  184.              *    say we are doing an intset
  185.              *    but, if we get out of range errors for intset
  186.              *    we punt constructing the set at    compile time.
  187.              */
  188.             setofint = TRUE;
  189.         } else {
  190.             exptype = t->type;
  191.             if (exptype == NIL)
  192.                 return csetp -> comptime;
  193.             if (exptype->class != RANGE)
  194.                 exptype = exptype->type;
  195.             settype = defnl((char *) 0, SET, exptype, 0);
  196.         }
  197.     }
  198.     csetp -> csettype = settype;
  199. #    ifndef CONSETS
  200.         csetp -> comptime = FALSE;
  201. #    endif CONSETS
  202.     setran( exptype );
  203.     if (((set.uprbp + 1) >> LG2BITSLONG) >= COMPSETSZE)
  204.         csetp -> comptime = FALSE;
  205.     lower = set.lwrb;
  206.     upper = set.lwrb + set.uprbp;
  207.     pairp = NIL;
  208.     singp = NIL;
  209.     codeoff();
  210.     while ( el = r->cset_node.el_list ) {
  211.         e = el->list_node.list;
  212.         if (e == NIL) {
  213.                 /*
  214.                  *    don't hang this one anywhere.
  215.                  */
  216.             csetp -> csettype = NIL;
  217.             r->cset_node.el_list = el->list_node.next;
  218.             continue;
  219.         }
  220.         if (e->tag == T_RANG) {
  221.             if ( csetp -> comptime && constval( e->rang.expr2 ) ) {
  222. #ifdef CONSETS
  223.                 t = con.ctype;
  224.                 if ( con.crval < lower || con.crval > upper ) {
  225.                 if ( setofint ) {
  226.                     csetp -> comptime = FALSE;
  227.                 } else {
  228.                     error("Range upper bound of %D out of set bounds" , ((long)con.crval) );
  229.                     csetp -> csettype = NIL;
  230.                 }
  231.                 }
  232. #endif CONSETS
  233.             } else {
  234.                 csetp -> comptime = FALSE;
  235.                 t = rvalue(e->rang.expr2, NLNIL , RREQ );
  236.                 if (t == NIL) {
  237.                     (void) rvalue(e->rang.expr1, NLNIL , RREQ );
  238.                     goto pairhang;
  239.                 }
  240.             }
  241.             if (incompat(t, exptype, e->rang.expr2)) {
  242.                 cerror("Upper bound of element type clashed with set type in constant set");
  243.             }
  244.             if ( csetp -> comptime && constval( e->rang.expr1 ) ) {
  245. #ifdef CONSETS
  246.                 t = con.ctype;
  247.                 if ( con.crval < lower || con.crval > upper ) {
  248.                 if ( setofint ) {
  249.                     csetp -> comptime = FALSE;
  250.                 } else {
  251.                     error("Range lower bound of %D out of set bounds" , ((long)con.crval) );
  252.                     csetp -> csettype = NIL;
  253.                 }
  254.                 }
  255. #endif CONSETS
  256.             } else {
  257.                 csetp -> comptime = FALSE;
  258.                 t = rvalue(e->rang.expr1, NLNIL , RREQ );
  259.                 if (t == NIL) {
  260.                     goto pairhang;
  261.                 }
  262.             }
  263.             if (incompat(t, exptype, e->rang.expr1)) {
  264.                 cerror("Lower bound of element type clashed with set type in constant set");
  265.             }
  266. pairhang:
  267.                 /*
  268.                  *    remove this range from the tree list and 
  269.                  *    hang it on the pairs list.
  270.                  */
  271.             ip = el->list_node.next;
  272.             el->list_node.next = pairp;
  273.             pairp = r->cset_node.el_list;
  274.             r->cset_node.el_list = ip;
  275.             csetp -> paircnt++;
  276.         } else {
  277.             if ( csetp -> comptime && constval( e ) ) {
  278. #ifdef CONSETS
  279.                 t = con.ctype;
  280.                 if ( con.crval < lower || con.crval > upper ) {
  281.                 if ( setofint ) {
  282.                     csetp -> comptime = FALSE;
  283.                 } else {
  284.                     error("Value of %D out of set bounds" , ((long)con.crval) );
  285.                     csetp -> csettype = NIL;
  286.                 }
  287.                 }
  288. #endif CONSETS
  289.             } else {
  290.                 csetp -> comptime = FALSE;
  291.                 t = rvalue( e, NLNIL , RREQ );
  292.                 if (t == NIL) {
  293.                     goto singhang;
  294.                 }
  295.             }
  296.             if (incompat(t, exptype, e)) {
  297.                 cerror("Element type clashed with set type in constant set");
  298.             }
  299. singhang:
  300.                 /*
  301.                  *    take this expression off the tree list and
  302.                  *    hang it on the list of singletons.
  303.                  */
  304.             ip = el->list_node.next;
  305.             el->list_node.next = singp;
  306.             singp = r->cset_node.el_list;
  307.             r->cset_node.el_list = ip;
  308.             csetp -> singcnt++;
  309.         }
  310.     }
  311.     codeon();
  312. #    ifdef PC
  313.         if ( pairp != NIL ) {
  314.         for ( el = pairp ; el->list_node.next != NIL ; el = el->list_node.next ) /* void */;
  315.         el->list_node.next = singp;
  316.         r->cset_node.el_list = pairp;
  317.         } else {
  318.         r->cset_node.el_list = singp;
  319.         }
  320. #    endif PC
  321. #    ifdef OBJ
  322.         if ( singp != NIL ) {
  323.         for ( el = singp ; el->list_node.next != NIL ; el = el->list_node.next ) /* void */;
  324.         el->list_node.next = pairp;
  325.         r->cset_node.el_list = singp;
  326.         } else {
  327.         r->cset_node.el_list = pairp;
  328.         }
  329. #    endif OBJ
  330.     if ( csetp -> csettype == NIL ) {
  331.         csetp -> comptime = TRUE;
  332.     }
  333.     return csetp -> comptime;
  334. }
  335.  
  336. #ifdef CONSETS
  337.     /*
  338.      *    mask[i] has the low i bits turned off.
  339.      */
  340. long    mask[] = {    
  341. #        ifdef DEC11
  342.             0xffffffff , 0xfffffffe , 0xfffffffc , 0xfffffff8 ,
  343.             0xfffffff0 , 0xffffffe0 , 0xffffffc0 , 0xffffff80 ,
  344.             0xffffff00 , 0xfffffe00 , 0xfffffc00 , 0xfffff800 ,
  345.             0xfffff000 , 0xffffe000 , 0xffffc000 , 0xffff8000 ,
  346.             0xffff0000 , 0xfffe0000 , 0xfffc0000 , 0xfff80000 ,
  347.             0xfff00000 , 0xffe00000 , 0xffc00000 , 0xff800000 ,
  348.             0xff000000 , 0xfe000000 , 0xfc000000 , 0xf8000000 ,
  349.             0xf0000000 , 0xe0000000 , 0xc0000000 , 0x80000000 ,
  350.             0x00000000
  351. #        else
  352.             0xffffffff , 0xfeffffff , 0xfcffffff , 0xf8ffffff ,
  353.             0xf0ffffff , 0xe0ffffff , 0xc0ffffff , 0x80ffffff ,
  354.             0x00ffffff , 0x00feffff , 0x00fcffff , 0x00f8ffff ,
  355.             0x00f0ffff , 0x00e0ffff , 0x00c0ffff , 0x0080ffff ,
  356.             0x0000ffff , 0x0000feff , 0x0000fcff , 0x0000f8ff ,
  357.             0x0000f0ff , 0x0000e0ff , 0x0000c0ff , 0x000080ff ,
  358.             0x000000ff , 0x000000fe , 0x000000fc , 0x000000f8 ,
  359.             0x000000f0 , 0x000000e0 , 0x000000c0 , 0x00000080 ,
  360.             0x00000000
  361. #        endif DEC11
  362.         };
  363.     /*
  364.      *    given a csetstr, either
  365.      *        put out a compile time constant set and an lvalue to it.
  366.      *    or
  367.      *        put out rvalues for the singletons and the pairs
  368.      *        and counts of each.
  369.      */
  370. #endif CONSETS
  371. postcset( r , csetp )
  372.     struct tnode    *r;
  373.     struct csetstr    *csetp;
  374.     {
  375.     register struct tnode    *el;
  376.     register struct tnode    *e;
  377.     int        lower;
  378.     int        upper;
  379.     int        lowerdiv;
  380.     int        lowermod;
  381.     int        upperdiv;
  382.     int        uppermod;
  383.     long        *lp;
  384.     long        *limit;
  385.     long        tempset[ COMPSETSZE ];
  386.     long        temp;
  387.     char        *cp;
  388. #    ifdef PC
  389.         int        label;
  390.         char    labelname[ BUFSIZ ];
  391. #    endif PC
  392.  
  393.     if ( csetp -> comptime ) {
  394. #ifdef CONSETS
  395.         setran( ( csetp -> csettype ) -> type );
  396.         limit = &tempset[ ( set.uprbp >> LG2BITSLONG ) + 1 ];
  397.         for ( lp = &tempset[0] ; lp < limit ; lp++ ) {
  398.         *lp = 0;
  399.         }
  400.         for ( el = r->cset_node.el_list ; el != NIL ; el = el->list_node.next ) {
  401.         e = el->list_node.list;
  402.         if ( e->tag == T_RANG ) {
  403.             (void) constval( e->rang.expr1 );
  404.             lower = con.crval;
  405.             (void) constval( e->rang.expr2 );
  406.             upper = con.crval;
  407.             if ( upper < lower ) {
  408.             continue;
  409.             }
  410.             lowerdiv = ( lower - set.lwrb ) >> LG2BITSLONG;
  411.             lowermod = ( lower - set.lwrb ) & MSKBITSLONG;
  412.             upperdiv = ( upper - set.lwrb ) >> LG2BITSLONG;
  413.             uppermod = ( upper - set.lwrb ) & MSKBITSLONG;
  414.             temp = mask[ lowermod ];
  415.             if ( lowerdiv == upperdiv ) {
  416.             temp &= ~mask[ uppermod + 1 ];
  417.             }
  418.             tempset[ lowerdiv ] |= temp;
  419.             limit = &tempset[ upperdiv-1 ];
  420.             for ( lp = &tempset[ lowerdiv+1 ] ; lp <= limit ; lp++ ) {
  421.             *lp |= 0xffffffff;
  422.             }
  423.             if ( lowerdiv != upperdiv ) {
  424.             tempset[ upperdiv ] |= ~mask[ uppermod + 1 ];
  425.             }
  426.         } else {
  427.             (void) constval( e );
  428.             temp = con.crval - set.lwrb;
  429.             cp = (char *)tempset;
  430.             cp[temp >> LG2BITSBYTE] |= (1 << (temp & MSKBITSBYTE));
  431.         }
  432.         }
  433.         if ( !CGENNING )
  434.         return;
  435. #        ifdef PC
  436.         label = (int) getlab();
  437.         putprintf("    .data" , 0 );
  438.         aligndot(A_SET);
  439.         (void) putlab( (char *) label );
  440.         lp = &( tempset[0] );
  441.         limit = &tempset[ ( set.uprbp >> LG2BITSLONG ) + 1 ];
  442.         while (lp < limit) {
  443.             putprintf("    .long    0x%x", 1, (int) (*lp++));
  444.             for (temp = 2 ; temp <= 8 && lp < limit ; temp++) {
  445.             putprintf(",0x%x", 1, (int) (*lp++));
  446.             }
  447.             putprintf("", 0);
  448.         }
  449.         putprintf("    .text", 0);
  450.         sprintf( labelname , PREFIXFORMAT , LABELPREFIX , (char *) label );
  451.         putleaf( PCC_ICON , 0 , 0 , PCCTM_PTR | PCCT_STRTY , labelname );
  452. #        endif PC
  453. #        ifdef OBJ
  454.         (void) put(2, O_CON, (int)(((set.uprbp >> LG2BITSLONG) + 1) *
  455.                  (BITSPERLONG >> LG2BITSBYTE)));
  456.         lp = &( tempset[0] );
  457.         limit = &tempset[ ( set.uprbp >> LG2BITSLONG ) + 1 ];
  458.         while ( lp < limit ) {
  459.             (void) put(2, O_CASE4, (int) (*lp ++));
  460.         }
  461. #        endif OBJ
  462. #else
  463.         panic("const cset");
  464. #endif CONSETS
  465.     } else {
  466. #        ifdef PC
  467.         putleaf( PCC_ICON , (int) csetp -> paircnt , 0 , PCCT_INT , (char *) 0 );
  468.         putop( PCC_CM , PCCT_INT );
  469.         putleaf( PCC_ICON , (int) csetp -> singcnt , 0 , PCCT_INT , (char *) 0 );
  470.         putop( PCC_CM , PCCT_INT );
  471.         for ( el = r->cset_node.el_list ; el != NIL ; el = el->list_node.next ) {
  472.             e = el->list_node.list;
  473.             if ( e->tag == T_RANG ) {
  474.             (void) rvalue( e->rang.expr2 , NLNIL , RREQ );
  475.             putop( PCC_CM , PCCT_INT );
  476.             (void) rvalue( e->rang.expr1 , NLNIL , RREQ );
  477.             putop( PCC_CM , PCCT_INT );
  478.             } else {
  479.             (void) rvalue( e , NLNIL , RREQ );
  480.             putop( PCC_CM , PCCT_INT );
  481.             }
  482.         }
  483. #        endif PC
  484. #        ifdef OBJ
  485.         for ( el = r->cset_node.el_list ; el != NIL ; el = el->list_node.next ) {
  486.             e = el->list_node.list;
  487.             if ( e->tag == T_RANG ) {
  488.             (void) stkrval( e->rang.expr1 , NLNIL , (long) RREQ );
  489.             (void) stkrval( e->rang.expr2 , NLNIL , (long) RREQ );
  490.             } else {
  491.             (void) stkrval( e , NLNIL , (long) RREQ );
  492.             }
  493.         }
  494.         (void) put(2 , O_CON24 , (int)csetp -> singcnt );
  495.         (void) put(2 , O_CON24 , (int)csetp -> paircnt );
  496. #        endif OBJ
  497.     }
  498. }
  499.