home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / conv.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  9.4 KB  |  400 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[] = "@(#)conv.c    5.2 (Berkeley) 4/16/91";
  36. #endif /* not lint */
  37.  
  38. #include "whoami.h"
  39. #ifdef PI
  40. #include "0.h"
  41. #include "opcode.h"
  42. #ifdef PC
  43. #   include    <pcc.h>
  44. #endif PC
  45. #include "tree_ty.h"
  46.  
  47. #ifndef PC
  48. #ifndef PI0
  49. /*
  50.  * Convert a p1 into a p2.
  51.  * Mostly used for different
  52.  * length integers and "to real" conversions.
  53.  */
  54. convert(p1, p2)
  55.     struct nl *p1, *p2;
  56. {
  57.     if (p1 == NLNIL || p2 == NLNIL)
  58.         return;
  59.     switch (width(p1) - width(p2)) {
  60.         case -7:
  61.         case -6:
  62.             (void) put(1, O_STOD);
  63.             return;
  64.         case -4:
  65.             (void) put(1, O_ITOD);
  66.             return;
  67.         case -3:
  68.         case -2:
  69.             (void) put(1, O_STOI);
  70.             return;
  71.         case -1:
  72.         case 0:
  73.         case 1:
  74.             return;
  75.         case 2:
  76.         case 3:
  77.             (void) put(1, O_ITOS);
  78.             return;
  79.         default:
  80.             panic("convert");
  81.     }
  82. }
  83. #endif 
  84. #endif PC
  85.  
  86. /*
  87.  * Compat tells whether
  88.  * p1 and p2 are compatible
  89.  * types for an assignment like
  90.  * context, i.e. value parameters,
  91.  * indicies for 'in', etc.
  92.  */
  93. compat(p1, p2, t)
  94.     struct nl *p1, *p2;
  95.     struct tnode *t;
  96. {
  97.     register c1, c2;
  98.  
  99.     c1 = classify(p1);
  100.     if (c1 == NIL)
  101.         return (NIL);
  102.     c2 = classify(p2);
  103.     if (c2 == NIL)
  104.         return (NIL);
  105.     switch (c1) {
  106.         case TBOOL:
  107.         case TCHAR:
  108.             if (c1 == c2)
  109.                 return (1);
  110.             break;
  111.         case TINT:
  112.             if (c2 == TINT)
  113.                 return (1);
  114.         case TDOUBLE:
  115.             if (c2 == TDOUBLE)
  116.                 return (1);
  117. #ifndef PI0
  118.             if (c2 == TINT && divflg == FALSE && t != TR_NIL ) {
  119.                 divchk= TRUE;
  120.                 c1 = classify(rvalue(t, NLNIL , RREQ ));
  121.                 divchk = FALSE;
  122.                 if (c1 == TINT) {
  123.                     error("Type clash: real is incompatible with integer");
  124.                     cerror("This resulted because you used '/' which always returns real rather");
  125.                     cerror("than 'div' which divides integers and returns integers");
  126.                     divflg = TRUE;
  127.                     return (NIL);
  128.                 }
  129.             }
  130. #endif
  131.             break;
  132.         case TSCAL:
  133.             if (c2 != TSCAL)
  134.                 break;
  135.             if (scalar(p1) != scalar(p2)) {
  136.                 derror("Type clash: non-identical scalar types");
  137.                 return (NIL);
  138.             }
  139.             return (1);
  140.         case TSTR:
  141.             if (c2 != TSTR)
  142.                 break;
  143.             if (width(p1) != width(p2)) {
  144.                 derror("Type clash: unequal length strings");
  145.                 return (NIL);
  146.             }
  147.             return (1);
  148.         case TNIL:
  149.             if (c2 != TPTR)
  150.                 break;
  151.             return (1);
  152.         case TFILE:
  153.             if (c1 != c2)
  154.                 break;
  155.             derror("Type clash: files not allowed in this context");
  156.             return (NIL);
  157.         default:
  158.             if (c1 != c2)
  159.                 break;
  160.             if (p1 != p2) {
  161.                 derror("Type clash: non-identical %s types", clnames[c1]);
  162.                 return (NIL);
  163.             }
  164.             if (p1->nl_flags & NFILES) {
  165.                 derror("Type clash: %ss with file components not allowed in this context", clnames[c1]);
  166.                 return (NIL);
  167.             }
  168.             return (1);
  169.     }
  170.     derror("Type clash: %s is incompatible with %s", clnames[c1], clnames[c2]);
  171.     return (NIL);
  172. }
  173.  
  174. #ifndef PI0
  175. #ifndef PC
  176. /*
  177.  * Rangechk generates code to
  178.  * check if the type p on top
  179.  * of the stack is in range for
  180.  * assignment to a variable
  181.  * of type q.
  182.  */
  183. rangechk(p, q)
  184.     struct nl *p, *q;
  185. {
  186.     register struct nl *rp;
  187. #ifdef OBJ
  188.     register op;
  189.     int wq, wrp;
  190. #endif
  191.  
  192.     if (opt('t') == 0)
  193.         return;
  194.     rp = p;
  195.     if (rp == NIL)
  196.         return;
  197.     if (q == NIL)
  198.         return;
  199. #    ifdef OBJ
  200.         /*
  201.          * When op is 1 we are checking length
  202.          * 4 numbers against length 2 bounds,
  203.          * and adding it to the opcode forces
  204.          * generation of appropriate tests.
  205.          */
  206.         op = 0;
  207.         wq = width(q);
  208.         wrp = width(rp);
  209.         op = wq != wrp && (wq == 4 || wrp == 4);
  210.         if (rp->class == TYPE || rp->class == CRANGE)
  211.             rp = rp->type;
  212.         switch (rp->class) {
  213.         case RANGE:
  214.             if (rp->range[0] != 0) {
  215. #                ifndef DEBUG
  216.                 if (wrp <= 2)
  217.                     (void) put(3, O_RANG2+op, ( short ) rp->range[0],
  218.                              ( short ) rp->range[1]);
  219.                 else if (rp != nl+T4INT)
  220.                     (void) put(3, O_RANG4+op, rp->range[0], rp->range[1] );
  221. #                else
  222.                 if (!hp21mx) {
  223.                     if (wrp <= 2)
  224.                         (void) put(3, O_RANG2+op,( short ) rp->range[0],
  225.                                 ( short ) rp->range[1]);
  226.                     else if (rp != nl+T4INT)
  227.                         (void) put(3, O_RANG4+op,rp->range[0],
  228.                                  rp->range[1]);
  229.                 } else
  230.                     if (rp != nl+T2INT && rp != nl+T4INT)
  231.                         (void) put(3, O_RANG2+op,( short ) rp->range[0],
  232.                                 ( short ) rp->range[1]);
  233. #                endif
  234.             break;
  235.             }
  236.             /*
  237.              * Range whose lower bounds are
  238.              * zero can be treated as scalars.
  239.              */
  240.         case SCAL:
  241.             if (wrp <= 2)
  242.                 (void) put(2, O_RSNG2+op, ( short ) rp->range[1]);
  243.             else
  244.                 (void) put( 2 , O_RSNG4+op, rp->range[1]);
  245.             break;
  246.         default:
  247.             panic("rangechk");
  248.         }
  249. #    endif OBJ
  250. #    ifdef PC
  251.         /*
  252.          *    pc uses precheck() and postcheck().
  253.          */
  254.         panic("rangechk()");
  255. #    endif PC
  256. }
  257. #endif
  258. #endif
  259. #endif
  260.  
  261. #ifdef PC
  262.     /*
  263.      *    if type p requires a range check,
  264.      *        then put out the name of the checking function
  265.      *    for the beginning of a function call which is completed by postcheck.
  266.      *  (name1 is for a full check; name2 assumes a lower bound of zero)
  267.      */
  268. precheck( p , name1 , name2 )
  269.     struct nl    *p;
  270.     char    *name1 , *name2;
  271.     {
  272.  
  273.     if ( opt( 't' ) == 0 ) {
  274.         return;
  275.     }
  276.     if ( p == NIL ) {
  277.         return;
  278.     }
  279.     if ( p -> class == TYPE ) {
  280.         p = p -> type;
  281.     }
  282.     switch ( p -> class ) {
  283.         case CRANGE:
  284.         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
  285.                 , name1);
  286.         break;
  287.         case RANGE:
  288.         if ( p != nl + T4INT ) {
  289.             putleaf( PCC_ICON , 0 , 0 ,
  290.                 PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ),
  291.                 p -> range[0] != 0 ? name1 : name2 );
  292.         }
  293.         break;
  294.         case SCAL:
  295.             /*
  296.              *    how could a scalar ever be out of range?
  297.              */
  298.         break;
  299.         default:
  300.         panic( "precheck" );
  301.         break;
  302.     }
  303.     }
  304.  
  305.     /*
  306.      *    if type p requires a range check,
  307.      *        then put out the rest of the arguments of to the checking function
  308.      *    a call to which was started by precheck.
  309.      *    the first argument is what is being rangechecked (put out by rvalue),
  310.      *    the second argument is the lower bound of the range,
  311.      *    the third argument is the upper bound of the range.
  312.      */
  313. postcheck(need, have)
  314.     struct nl    *need;
  315.     struct nl    *have;
  316. {
  317.     struct nl    *p;
  318.  
  319.     if ( opt( 't' ) == 0 ) {
  320.     return;
  321.     }
  322.     if ( need == NIL ) {
  323.     return;
  324.     }
  325.     if ( need -> class == TYPE ) {
  326.     need = need -> type;
  327.     }
  328.     switch ( need -> class ) {
  329.     case RANGE:
  330.         if ( need != nl + T4INT ) {
  331.         sconv(p2type(have), PCCT_INT);
  332.         if (need -> range[0] != 0 ) {
  333.             putleaf( PCC_ICON , (int) need -> range[0] , 0 , PCCT_INT ,
  334.                             (char *) 0 );
  335.             putop( PCC_CM , PCCT_INT );
  336.         }
  337.         putleaf( PCC_ICON , (int) need -> range[1] , 0 , PCCT_INT ,
  338.                 (char *) 0 );
  339.         putop( PCC_CM , PCCT_INT );
  340.         putop( PCC_CALL , PCCT_INT );
  341.         sconv(PCCT_INT, p2type(have));
  342.         }
  343.         break;
  344.     case CRANGE:
  345.         sconv(p2type(have), PCCT_INT);
  346.         p = need->nptr[0];
  347.         putRV(p->symbol, (p->nl_block & 037), p->value[0],
  348.             p->extra_flags, p2type( p ) );
  349.         putop( PCC_CM , PCCT_INT );
  350.         p = need->nptr[1];
  351.         putRV(p->symbol, (p->nl_block & 037), p->value[0],
  352.             p->extra_flags, p2type( p ) );
  353.         putop( PCC_CM , PCCT_INT );
  354.         putop( PCC_CALL , PCCT_INT );
  355.         sconv(PCCT_INT, p2type(have));
  356.         break;
  357.     case SCAL:
  358.         break;
  359.     default:
  360.         panic( "postcheck" );
  361.         break;
  362.     }
  363. }
  364. #endif PC
  365.  
  366. #ifdef DEBUG
  367. conv(dub)
  368.     int *dub;
  369. {
  370.     int newfp[2];
  371.     double *dp = ((double *) dub);
  372.     long *lp = ((long *) dub);
  373.     register int exp;
  374.     long mant;
  375.  
  376.     newfp[0] = dub[0] & 0100000;
  377.     newfp[1] = 0;
  378.     if (*dp == 0.0)
  379.         goto ret;
  380.     exp = ((dub[0] >> 7) & 0377) - 0200;
  381.     if (exp < 0) {
  382.         newfp[1] = 1;
  383.         exp = -exp;
  384.     }
  385.     if (exp > 63)
  386.         exp = 63;
  387.     dub[0] &= ~0177600;
  388.     dub[0] |= 0200;
  389.     mant = *lp;
  390.     mant <<= 8;
  391.     if (newfp[0])
  392.         mant = -mant;
  393.     newfp[0] |= (mant >> 17) & 077777;
  394.     newfp[1] |= (((int) (mant >> 1)) & 0177400) | (exp << 1);
  395. ret:
  396.     dub[0] = newfp[0];
  397.     dub[1] = newfp[1];
  398. }
  399. #endif
  400.