home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / pcfunc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  12.8 KB  |  419 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[] = "@(#)pcfunc.c    5.2 (Berkeley) 4/16/91";
  36. #endif /* not lint */
  37.  
  38. #include "whoami.h"
  39. #ifdef PC
  40.     /*
  41.      *    and to the end of the file
  42.      */
  43. #include "0.h"
  44. #include "tree.h"
  45. #include "objfmt.h"
  46. #include "opcode.h"
  47. #include "pc.h"
  48. #include <pcc.h>
  49. #include "tmps.h"
  50. #include "tree_ty.h"
  51.  
  52. /*
  53.  * Funccod generates code for
  54.  * built in function calls and calls
  55.  * call to generate calls to user
  56.  * defined functions and procedures.
  57.  */
  58. struct nl *
  59. pcfunccod( r )
  60.     struct tnode     *r; /* T_FCALL */
  61. {
  62.     struct nl *p;
  63.     register struct nl *p1;
  64.     register struct tnode *al;
  65.     register op;
  66.     int argc;
  67.     struct tnode *argv;
  68.     struct tnode tr, tr2;
  69.     char        *funcname;
  70.     struct nl    *tempnlp;
  71.     long        temptype;
  72.     struct nl    *rettype;
  73.  
  74.     /*
  75.      * Verify that the given name
  76.      * is defined and the name of
  77.      * a function.
  78.      */
  79.     p = lookup(r->pcall_node.proc_id);
  80.     if (p == NLNIL) {
  81.         rvlist(r->pcall_node.arg);
  82.         return (NLNIL);
  83.     }
  84.     if (p->class != FUNC && p->class != FFUNC) {
  85.         error("%s is not a function", p->symbol);
  86.         rvlist(r->pcall_node.arg);
  87.         return (NLNIL);
  88.     }
  89.     argv = r->pcall_node.arg;
  90.     /*
  91.      * Call handles user defined
  92.      * procedures and functions
  93.      */
  94.     if (bn != 0)
  95.         return (call(p, argv, FUNC, bn));
  96.     /*
  97.      * Count the arguments
  98.      */
  99.     argc = 0;
  100.     for (al = argv; al != TR_NIL; al = al->list_node.next)
  101.         argc++;
  102.     /*
  103.      * Built-in functions have
  104.      * their interpreter opcode
  105.      * associated with them.
  106.      */
  107.     op = p->value[0] &~ NSTAND;
  108.     if (opt('s') && (p->value[0] & NSTAND)) {
  109.         standard();
  110.         error("%s is a nonstandard function", p->symbol);
  111.     }
  112.     if ( op == O_ARGC ) {
  113.         putleaf( PCC_NAME , 0 , 0 , PCCT_INT , "__argc" );
  114.         return nl + T4INT;
  115.     }
  116.     switch (op) {
  117.         /*
  118.          * Parameterless functions
  119.          */
  120.         case O_CLCK:
  121.             funcname = "_CLCK";
  122.             goto noargs;
  123.         case O_SCLCK:
  124.             funcname = "_SCLCK";
  125.             goto noargs;
  126. noargs:
  127.             if (argc != 0) {
  128.                 error("%s takes no arguments", p->symbol);
  129.                 rvlist(argv);
  130.                 return (NLNIL);
  131.             }
  132.             putleaf( PCC_ICON , 0 , 0
  133.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
  134.                 , funcname );
  135.             putop( PCCOM_UNARY PCC_CALL , PCCT_INT );
  136.             return (nl+T4INT);
  137.         case O_WCLCK:
  138.             if (argc != 0) {
  139.                 error("%s takes no arguments", p->symbol);
  140.                 rvlist(argv);
  141.                 return (NLNIL);
  142.             }
  143.             putleaf( PCC_ICON , 0 , 0
  144.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
  145.                 , "_time" );
  146.             putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 );
  147.             putop( PCC_CALL , PCCT_INT );
  148.             return (nl+T4INT);
  149.         case O_EOF:
  150.         case O_EOLN:
  151.             if (argc == 0) {
  152.                 argv = &(tr);
  153.                 tr.list_node.list = &(tr2);
  154.                 tr2.tag = T_VAR;
  155.                 tr2.var_node.cptr = input->symbol;
  156.                 tr2.var_node.line_no = NIL;
  157.                 tr2.var_node.qual = TR_NIL;
  158.                 argc = 1;
  159.             } else if (argc != 1) {
  160.                 error("%s takes either zero or one argument", p->symbol);
  161.                 rvlist(argv);
  162.                 return (NLNIL);
  163.             }
  164.         }
  165.     /*
  166.      * All other functions take
  167.      * exactly one argument.
  168.      */
  169.     if (argc != 1) {
  170.         error("%s takes exactly one argument", p->symbol);
  171.         rvlist(argv);
  172.         return (NLNIL);
  173.     }
  174.     /*
  175.      * find out the type of the argument
  176.      */
  177.     codeoff();
  178.     p1 = stkrval( argv->list_node.list, NLNIL , (long) RREQ );
  179.     codeon();
  180.     if (p1 == NLNIL)
  181.         return (NLNIL);
  182.     /*
  183.      * figure out the return type and the funtion name
  184.      */
  185.     switch (op) {
  186.         case 0:
  187.             error("%s is an unimplemented 6000-3.4 extension", p->symbol);
  188.         default:
  189.             panic("func1");
  190.         case O_EXP:
  191.             funcname = opt('t') ? "_EXP" : "_exp";
  192.             goto mathfunc;
  193.         case O_SIN:
  194.             funcname = opt('t') ? "_SIN" : "_sin";
  195.             goto mathfunc;
  196.         case O_COS:
  197.             funcname = opt('t') ? "_COS" : "_cos";
  198.             goto mathfunc;
  199.         case O_ATAN:
  200.             funcname = opt('t') ? "_ATAN" : "_atan";
  201.             goto mathfunc;
  202.         case O_LN:
  203.             funcname = opt('t') ? "_LN" : "_log";
  204.             goto mathfunc;
  205.         case O_SQRT:
  206.             funcname = opt('t') ? "_SQRT" : "_sqrt";
  207.             goto mathfunc;
  208.         case O_RANDOM:
  209.             funcname = "_RANDOM";
  210.             goto mathfunc;
  211. mathfunc:
  212.             if (isnta(p1, "id")) {
  213.                 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
  214.                 return (NLNIL);
  215.             }
  216.             putleaf( PCC_ICON , 0 , 0
  217.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_DOUBLE , PCCTM_PTR ) , funcname );
  218.             p1 = stkrval(  argv->list_node.list , NLNIL , (long) RREQ );
  219.             sconv(p2type(p1), PCCT_DOUBLE);
  220.             putop( PCC_CALL , PCCT_DOUBLE );
  221.             return nl + TDOUBLE;
  222.         case O_EXPO:
  223.             if (isnta( p1 , "id" ) ) {
  224.                 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
  225.                 return NIL;
  226.             }
  227.             putleaf( PCC_ICON , 0 , 0
  228.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_EXPO" );
  229.             p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
  230.             sconv(p2type(p1), PCCT_DOUBLE);
  231.             putop( PCC_CALL , PCCT_INT );
  232.             return ( nl + T4INT );
  233.         case O_UNDEF:
  234.             if ( isnta( p1 , "id" ) ) {
  235.                 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
  236.                 return NLNIL;
  237.             }
  238.             p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
  239.             putleaf( PCC_ICON , 0 , 0 , PCCT_CHAR , (char *) 0 );
  240.             putop( PCC_COMOP , PCCT_CHAR );
  241.             return ( nl + TBOOL );
  242.         case O_SEED:
  243.             if (isnta(p1, "i")) {
  244.                 error("seed's argument must be an integer, not %s", nameof(p1));
  245.                 return (NLNIL);
  246.             }
  247.             putleaf( PCC_ICON , 0 , 0
  248.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_SEED" );
  249.             p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
  250.             putop( PCC_CALL , PCCT_INT );
  251.             return nl + T4INT;
  252.         case O_ROUND:
  253.         case O_TRUNC:
  254.             if ( isnta( p1 , "d" ) ) {
  255.                 error("%s's argument must be a real, not %s", p->symbol, nameof(p1));
  256.                 return (NLNIL);
  257.             }
  258.             putleaf( PCC_ICON , 0 , 0
  259.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
  260.                 , op == O_ROUND ? "_ROUND" : "_TRUNC" );
  261.             p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
  262.             putop( PCC_CALL , PCCT_INT );
  263.             return nl + T4INT;
  264.         case O_ABS2:
  265.             if ( isa( p1 , "d" ) ) {
  266.                 putleaf( PCC_ICON , 0 , 0
  267.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_DOUBLE , PCCTM_PTR )
  268.                 , "_fabs" );
  269.                 p1 = stkrval( argv->list_node.list , NLNIL ,(long) RREQ );
  270.                 putop( PCC_CALL , PCCT_DOUBLE );
  271.                 return nl + TDOUBLE;
  272.             }
  273.             if ( isa( p1 , "i" ) ) {
  274.                 putleaf( PCC_ICON , 0 , 0
  275.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_abs" );
  276.                 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
  277.                 putop( PCC_CALL , PCCT_INT );
  278.                 return nl + T4INT;
  279.             }
  280.             error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
  281.             return NLNIL;
  282.         case O_SQR2:
  283.             if ( isa( p1 , "d" ) ) {
  284.                 temptype = PCCT_DOUBLE;
  285.                 rettype = nl + TDOUBLE;
  286.                 tempnlp = tmpalloc((long) (sizeof(double)), rettype, REGOK);
  287.             } else if ( isa( p1 , "i" ) ) {
  288.                 temptype = PCCT_INT;
  289.                 rettype = nl + T4INT;
  290.                 tempnlp = tmpalloc((long) (sizeof(long)), rettype, REGOK);
  291.             } else {
  292.                 error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
  293.                 return NLNIL;
  294.             }
  295.             putRV( (char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
  296.                 tempnlp -> extra_flags , (char) temptype  );
  297.             p1 = rvalue( argv->list_node.list , NLNIL , RREQ );
  298.             sconv(p2type(p1), (int) temptype);
  299.             putop( PCC_ASSIGN , (int) temptype );
  300.             putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
  301.                 tempnlp -> extra_flags , (char) temptype );
  302.             putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
  303.                 tempnlp -> extra_flags , (char) temptype );
  304.             putop( PCC_MUL , (int) temptype );
  305.             putop( PCC_COMOP , (int) temptype );
  306.             return rettype;
  307.         case O_ORD2:
  308.             p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
  309.             if (isa(p1, "bcis")) {
  310.                 return (nl+T4INT);
  311.             }
  312.             if (classify(p1) == TPTR) {
  313.                 if (!opt('s')) {
  314.                 return (nl+T4INT);
  315.                 }
  316.                 standard();
  317.             }
  318.             error("ord's argument must be of scalar type, not %s",
  319.                 nameof(p1));
  320.             return (NLNIL);
  321.         case O_SUCC2:
  322.         case O_PRED2:
  323.             if (isa(p1, "d")) {
  324.                 error("%s is forbidden for reals", p->symbol);
  325.                 return (NLNIL);
  326.             }
  327.             if ( isnta( p1 , "bcsi" ) ) {
  328.                 error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
  329.                 return NLNIL;
  330.             }
  331.             if ( opt( 't' ) ) {
  332.                 putleaf( PCC_ICON , 0 , 0
  333.                     , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
  334.                     , op == O_SUCC2 ? "_SUCC" : "_PRED" );
  335.                 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
  336.                 tempnlp = p1 -> class == TYPE ? p1 -> type : p1;
  337.                 putleaf( PCC_ICON, (int) tempnlp -> range[0], 0, PCCT_INT, (char *) 0 );
  338.                 putop( PCC_CM , PCCT_INT );
  339.                 putleaf( PCC_ICON, (int) tempnlp -> range[1], 0, PCCT_INT, (char *) 0 );
  340.                 putop( PCC_CM , PCCT_INT );
  341.                 putop( PCC_CALL , PCCT_INT );
  342.                 sconv(PCCT_INT, p2type(p1));
  343.             } else {
  344.                 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
  345.                 putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 );
  346.                 putop( op == O_SUCC2 ? PCC_PLUS : PCC_MINUS , PCCT_INT );
  347.                 sconv(PCCT_INT, p2type(p1));
  348.             }
  349.             if ( isa( p1 , "bcs" ) ) {
  350.                 return p1;
  351.             } else {
  352.                 return nl + T4INT;
  353.             }
  354.         case O_ODD2:
  355.             if (isnta(p1, "i")) {
  356.                 error("odd's argument must be an integer, not %s", nameof(p1));
  357.                 return (NLNIL);
  358.             }
  359.             p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
  360.                 /*
  361.                  *    THIS IS MACHINE-DEPENDENT!!!
  362.                  */
  363.             putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 );
  364.             putop( PCC_AND , PCCT_INT );
  365.             sconv(PCCT_INT, PCCT_CHAR);
  366.             return nl + TBOOL;
  367.         case O_CHR2:
  368.             if (isnta(p1, "i")) {
  369.                 error("chr's argument must be an integer, not %s", nameof(p1));
  370.                 return (NLNIL);
  371.             }
  372.             if (opt('t')) {
  373.                 putleaf( PCC_ICON , 0 , 0
  374.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_CHAR , PCCTM_PTR ) , "_CHR" );
  375.                 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
  376.                 putop( PCC_CALL , PCCT_CHAR );
  377.             } else {
  378.                 p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ );
  379.                 sconv(PCCT_INT, PCCT_CHAR);
  380.             }
  381.             return nl + TCHAR;
  382.         case O_CARD:
  383.             if (isnta(p1, "t")) {
  384.                 error("Argument to card must be a set, not %s", nameof(p1));
  385.                 return (NLNIL);
  386.             }
  387.             putleaf( PCC_ICON , 0 , 0
  388.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_CARD" );
  389.             p1 = stkrval( argv->list_node.list , NLNIL , (long) LREQ );
  390.             putleaf( PCC_ICON , (int) lwidth( p1 ) , 0 , PCCT_INT , (char *) 0 );
  391.             putop( PCC_CM , PCCT_INT );
  392.             putop( PCC_CALL , PCCT_INT );
  393.             return nl + T4INT;
  394.         case O_EOLN:
  395.             if (!text(p1)) {
  396.                 error("Argument to eoln must be a text file, not %s", nameof(p1));
  397.                 return (NLNIL);
  398.             }
  399.             putleaf( PCC_ICON , 0 , 0
  400.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_TEOLN" );
  401.             p1 = stklval( argv->list_node.list , NOFLAGS );
  402.             putop( PCC_CALL , PCCT_INT );
  403.             sconv(PCCT_INT, PCCT_CHAR);
  404.             return nl + TBOOL;
  405.         case O_EOF:
  406.             if (p1->class != FILET) {
  407.                 error("Argument to eof must be file, not %s", nameof(p1));
  408.                 return (NLNIL);
  409.             }
  410.             putleaf( PCC_ICON , 0 , 0
  411.                 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_TEOF" );
  412.             p1 = stklval( argv->list_node.list , NOFLAGS );
  413.             putop( PCC_CALL , PCCT_INT );
  414.             sconv(PCCT_INT, PCCT_CHAR);
  415.             return nl + TBOOL;
  416.     }
  417. }
  418. #endif PC
  419.