home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / func.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  7.3 KB  |  285 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[] = "@(#)func.c    5.2 (Berkeley) 4/16/91";
  36. #endif /* not lint */
  37.  
  38. #include "whoami.h"
  39. #ifdef OBJ
  40.     /*
  41.      *    the rest of the file
  42.      */
  43. #include "0.h"
  44. #include "tree.h"
  45. #include "opcode.h"
  46. #include "tree_ty.h"
  47.  
  48. /*
  49.  * Funccod generates code for
  50.  * built in function calls and calls
  51.  * call to generate calls to user
  52.  * defined functions and procedures.
  53.  */
  54. struct nl
  55. *funccod(r)
  56.     struct tnode *r;
  57. {
  58.     struct nl *p;
  59.     register struct nl *p1;
  60.     struct nl *tempnlp;
  61.     register struct tnode *al;
  62.     register op;
  63.     int argc;
  64.     struct tnode *argv, tr, tr2;
  65.  
  66.     /*
  67.      * Verify that the given name
  68.      * is defined and the name of
  69.      * a function.
  70.      */
  71.     p = lookup(r->pcall_node.proc_id);
  72.     if (p == NLNIL) {
  73.         rvlist(r->pcall_node.arg);
  74.         return (NLNIL);
  75.     }
  76.     if (p->class != FUNC && p->class != FFUNC) {
  77.         error("%s is not a function", p->symbol);
  78.         rvlist(r->pcall_node.arg);
  79.         return (NLNIL);
  80.     }
  81.     argv = r->pcall_node.arg;
  82.     /*
  83.      * Call handles user defined
  84.      * procedures and functions
  85.      */
  86.     if (bn != 0)
  87.         return (call(p, argv, FUNC, bn));
  88.     /*
  89.      * Count the arguments
  90.      */
  91.     argc = 0;
  92.     for (al = argv; al != TR_NIL; al = al->list_node.next)
  93.         argc++;
  94.     /*
  95.      * Built-in functions have
  96.      * their interpreter opcode
  97.      * associated with them.
  98.      */
  99.     op = p->value[0] &~ NSTAND;
  100.     if (opt('s') && (p->value[0] & NSTAND)) {
  101.         standard();
  102.         error("%s is a nonstandard function", p->symbol);
  103.     }
  104.     switch (op) {
  105.         /*
  106.          * Parameterless functions
  107.          */
  108.         case O_CLCK:
  109.         case O_SCLCK:
  110.         case O_WCLCK:
  111.         case O_ARGC:
  112.             if (argc != 0) {
  113.                 error("%s takes no arguments", p->symbol);
  114.                 rvlist(argv);
  115.                 return (NLNIL);
  116.             }
  117.             (void) put(1, op);
  118.             return (nl+T4INT);
  119.         case O_EOF:
  120.         case O_EOLN:
  121.             if (argc == 0) {
  122.                 argv = (&tr);
  123.                 tr.list_node.list = (&tr2);
  124.                 tr2.tag = T_VAR;
  125.                 tr2.var_node.cptr = input->symbol;
  126.                 tr2.var_node.line_no = NIL;
  127.                 tr2.var_node.qual = TR_NIL;
  128.                 argc = 1;
  129.             } else if (argc != 1) {
  130.                 error("%s takes either zero or one argument", p->symbol);
  131.                 rvlist(argv);
  132.                 return (NLNIL);
  133.             }
  134.         }
  135.     /*
  136.      * All other functions take
  137.      * exactly one argument.
  138.      */
  139.     if (argc != 1) {
  140.         error("%s takes exactly one argument", p->symbol);
  141.         rvlist(argv);
  142.         return (NLNIL);
  143.     }
  144.     /*
  145.      * Evaluate the argmument
  146.      */
  147.     if (op == O_EOF || op == O_EOLN)
  148.         p1 = stklval(argv->list_node.list, NIL );
  149.     else
  150.         p1 = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
  151.     if (p1 == NLNIL)
  152.         return (NLNIL);
  153.     switch (op) {
  154.         case 0:
  155.             error("%s is an unimplemented 6000-3.4 extension", p->symbol);
  156.         default:
  157.             panic("func1");
  158.         case O_EXP:
  159.         case O_SIN:
  160.         case O_COS:
  161.         case O_ATAN:
  162.         case O_LN:
  163.         case O_SQRT:
  164.         case O_RANDOM:
  165.         case O_EXPO:
  166.         case O_UNDEF:
  167.             if (isa(p1, "i"))
  168.                 convert( nl+T4INT , nl+TDOUBLE);
  169.             else if (isnta(p1, "d")) {
  170.                 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
  171.                 return (NLNIL);
  172.             }
  173.             (void) put(1, op);
  174.             if (op == O_UNDEF)
  175.                 return (nl+TBOOL);
  176.             else if (op == O_EXPO)
  177.                 return (nl+T4INT);
  178.             else
  179.                 return (nl+TDOUBLE);
  180.         case O_SEED:
  181.             if (isnta(p1, "i")) {
  182.                 error("seed's argument must be an integer, not %s", nameof(p1));
  183.                 return (NLNIL);
  184.             }
  185.             (void) put(1, op);
  186.             return (nl+T4INT);
  187.         case O_ROUND:
  188.         case O_TRUNC:
  189.             if (isnta(p1, "d"))  {
  190.                 error("%s's argument must be a real, not %s", p->symbol, nameof(p1));
  191.                 return (NLNIL);
  192.             }
  193.             (void) put(1, op);
  194.             return (nl+T4INT);
  195.         case O_ABS2:
  196.         case O_SQR2:
  197.             if (isa(p1, "d")) {
  198.                 (void) put(1, op + O_ABS8-O_ABS2);
  199.                 return (nl+TDOUBLE);
  200.             }
  201.             if (isa(p1, "i")) {
  202.                 (void) put(1, op + (width(p1) >> 2));
  203.                 return (nl+T4INT);
  204.             }
  205.             error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
  206.             return (NLNIL);
  207.         case O_ORD2:
  208.             if (isa(p1, "bcis")) {
  209.                 return (nl+T4INT);
  210.             }
  211.             if (classify(p1) == TPTR) {
  212.                 if (!opt('s')) {
  213.                 return (nl+T4INT);
  214.                 }
  215.                 standard();
  216.             }
  217.             error("ord's argument must be of scalar type, not %s",
  218.                 nameof(p1));
  219.             return (NLNIL);
  220.         case O_SUCC2:
  221.         case O_PRED2:
  222.             if (isa(p1, "d")) {
  223.                 error("%s is forbidden for reals", p->symbol);
  224.                 return (NLNIL);
  225.             }
  226.             if ( isnta( p1 , "bcsi" ) ) {
  227.                 error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
  228.                 return NIL;
  229.             }
  230.             tempnlp = p1 -> class == TYPE ? p1 -> type : p1;
  231.             if (isa(p1, "i")) {
  232.                 if (width(p1) <= 2) {
  233.                     op += O_PRED24 - O_PRED2;
  234.                     (void) put(3, op, (int)tempnlp->range[0],
  235.                         (int)tempnlp->range[1]);
  236.                 } else {
  237.                     op++;
  238.                     (void) put(3, op, tempnlp->range[0],
  239.                         tempnlp->range[1]);
  240.                 }
  241.                 return nl + T4INT;
  242.             } else {
  243.                 (void) put(3, op, (int)tempnlp->range[0],
  244.                     (int)tempnlp->range[1]);
  245.                 return p1;
  246.             }
  247.         case O_ODD2:
  248.             if (isnta(p1, "i")) {
  249.                 error("odd's argument must be an integer, not %s", nameof(p1));
  250.                 return (NLNIL);
  251.             }
  252.             (void) put(1, op + (width(p1) >> 2));
  253.             return (nl+TBOOL);
  254.         case O_CHR2:
  255.             if (isnta(p1, "i")) {
  256.                 error("chr's argument must be an integer, not %s", nameof(p1));
  257.                 return (NLNIL);
  258.             }
  259.             (void) put(1, op + (width(p1) >> 2));
  260.             return (nl+TCHAR);
  261.         case O_CARD:
  262.             if (isnta(p1, "t")) {
  263.                 error("Argument to card must be a set, not %s", nameof(p1));
  264.                 return (NLNIL);
  265.             }
  266.             (void) put(2, O_CARD, width(p1));
  267.             return (nl+T2INT);
  268.         case O_EOLN:
  269.             if (!text(p1)) {
  270.                 error("Argument to eoln must be a text file, not %s", nameof(p1));
  271.                 return (NLNIL);
  272.             }
  273.             (void) put(1, op);
  274.             return (nl+TBOOL);
  275.         case O_EOF:
  276.             if (p1->class != FILET) {
  277.                 error("Argument to eof must be file, not %s", nameof(p1));
  278.                 return (NLNIL);
  279.             }
  280.             (void) put(1, op);
  281.             return (nl+TBOOL);
  282.     }
  283. }
  284. #endif OBJ
  285.