home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / call.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  19.6 KB  |  691 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[] = "@(#)call.c    5.4 (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 "align.h"
  44. #ifdef PC
  45. #   include "pc.h"
  46. #   include <pcc.h>
  47. #endif PC
  48. #include "tmps.h"
  49. #include "tree_ty.h"
  50.  
  51. /*
  52.  * Call generates code for calls to
  53.  * user defined procedures and functions
  54.  * and is called by proc and funccod.
  55.  * P is the result of the lookup
  56.  * of the procedure/function symbol,
  57.  * and porf is PROC or FUNC.
  58.  * Psbn is the block number of p.
  59.  *
  60.  *    the idea here is that regular scalar functions are just called,
  61.  *    while structure functions and formal functions have their results
  62.  *    stored in a temporary after the call.
  63.  *    structure functions do this because they return pointers
  64.  *    to static results, so we copy the static
  65.  *    and return a pointer to the copy.
  66.  *    formal functions do this because we have to save the result
  67.  *    around a call to the runtime routine which restores the display,
  68.  *    so we can't just leave the result lying around in registers.
  69.  *    formal calls save the address of the descriptor in a local
  70.  *    temporary, so it can be addressed for the call which restores
  71.  *    the display (FRTN).
  72.  *    calls to formal parameters pass the formal as a hidden argument 
  73.  *    to a special entry point for the formal call.
  74.  *    [this is somewhat dependent on the way arguments are addressed.]
  75.  *    so PROCs and scalar FUNCs look like
  76.  *        p(...args...)
  77.  *    structure FUNCs look like
  78.  *        (temp = p(...args...),&temp)
  79.  *    formal FPROCs look like
  80.  *        ( t=p,( t -> entryaddr )(...args...,t,s),FRTN(t,s))
  81.  *    formal scalar FFUNCs look like
  82.  *        ( t=p,temp=( t -> entryaddr )(...args...,t,s),FRTN(t,s),temp)
  83.  *    formal structure FFUNCs look like
  84.  *        (t=p,temp = ( t -> entryaddr )(...args...,t,s),FRTN(t,s),&temp)
  85.  */
  86. struct nl *
  87. call(p, argv_node, porf, psbn)
  88.     struct nl *p;
  89.     struct tnode    *argv_node;    /* list node */
  90.     int porf, psbn;
  91. {
  92.     register struct nl *p1, *q, *p2;
  93.     register struct nl *ptype, *ctype;
  94.     struct tnode *rnode;
  95.     int i, j, d;
  96.     bool chk = TRUE;
  97.      struct nl    *savedispnp;    /* temporary to hold saved display */
  98. #    ifdef PC
  99.         int        p_type_class = classify( p -> type );
  100.         long    p_type_p2type = p2type( p -> type );
  101.         bool    noarguments;
  102.         /*
  103.          *    these get used if temporaries and structures are used
  104.          */
  105.         struct nl    *tempnlp;
  106.         long    temptype;    /* type of the temporary */
  107.         long    p_type_width;
  108.         long    p_type_align;
  109.         char    extname[ BUFSIZ ];
  110.         struct nl    *tempdescrp;
  111. #    endif PC
  112.  
  113.          if (p->class == FFUNC || p->class == FPROC) {
  114.          /*
  115.           * allocate space to save the display for formal calls
  116.           */
  117.         savedispnp = tmpalloc( (long) sizeof display , NLNIL , NOREG );
  118.      }
  119. #    ifdef OBJ
  120.         if (p->class == FFUNC || p->class == FPROC) {
  121.          (void) put(2, O_LV | cbn << 8 + INDX ,
  122.              (int) savedispnp -> value[ NL_OFFS ] );
  123.         (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
  124.         }
  125.         if (porf == FUNC) {
  126.             /*
  127.              * Push some space
  128.              * for the function return type
  129.              */
  130.             (void) put(2, O_PUSH,
  131.             -roundup(lwidth(p->type), (long) A_STACK));
  132.         }
  133. #    endif OBJ
  134. #    ifdef PC
  135.         /*
  136.          *    if this is a formal call,
  137.          *    stash the address of the descriptor
  138.          *    in a temporary so we can find it
  139.          *    after the FCALL for the call to FRTN
  140.          */
  141.         if ( p -> class == FFUNC || p -> class == FPROC ) {
  142.         tempdescrp = tmpalloc((long) (sizeof( struct formalrtn *)),
  143.                     NLNIL, REGOK );
  144.         putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
  145.             tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
  146.         putRV((char *) 0 , psbn , p -> value[ NL_OFFS ] ,
  147.             p -> extra_flags , PCCTM_PTR|PCCT_STRTY );
  148.         putop( PCC_ASSIGN , PCCTM_PTR | PCCT_STRTY );
  149.         }
  150.         /*
  151.          *    if we have to store a temporary,
  152.          *    temptype will be its type,
  153.          *    otherwise, it's PCCT_UNDEF.
  154.          */
  155.         temptype = PCCT_UNDEF;
  156.         if ( porf == FUNC ) {
  157.         p_type_width = width( p -> type );
  158.         switch( p_type_class ) {
  159.             case TSTR:
  160.             case TSET:
  161.             case TREC:
  162.             case TFILE:
  163.             case TARY:
  164.             temptype = PCCT_STRTY;
  165.             p_type_align = align( p -> type );
  166.             break;
  167.             default:
  168.             if ( p -> class == FFUNC ) {
  169.                 temptype = p2type( p -> type );
  170.             }
  171.             break;
  172.         }
  173.         if ( temptype != PCCT_UNDEF ) {
  174.             tempnlp = tmpalloc(p_type_width, p -> type, NOREG);
  175.             /*
  176.              *    temp
  177.              *    for (temp = ...
  178.              */
  179.             putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
  180.                 tempnlp -> extra_flags , (int) temptype );
  181.         }
  182.         }
  183.         switch ( p -> class ) {
  184.         case FUNC:
  185.         case PROC:
  186.             /*
  187.              *    ... p( ...
  188.              */
  189.             sextname( extname , p -> symbol , BLOCKNO(p -> nl_block) );
  190.             putleaf( PCC_ICON , 0 , 0 , p2type( p ) , extname );
  191.             break;
  192.         case FFUNC:
  193.         case FPROC:
  194.  
  195.                 /*
  196.                  *    ... ( t -> entryaddr )( ...
  197.                  */
  198.                 /*     the descriptor */
  199.             putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
  200.                 tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
  201.                 /*    the entry address within the descriptor */
  202.             if ( FENTRYOFFSET != 0 ) {
  203.                 putleaf( PCC_ICON , FENTRYOFFSET , 0 , PCCT_INT , 
  204.                         (char *) 0 );
  205.                 putop( PCC_PLUS , 
  206.                 PCCM_ADDTYPE(
  207.                     PCCM_ADDTYPE( PCCM_ADDTYPE( p2type( p ) , PCCTM_FTN ) ,
  208.                         PCCTM_PTR ) ,
  209.                     PCCTM_PTR ) );
  210.             }
  211.                 /*
  212.                  *    indirect to fetch the formal entry address
  213.                  *    with the result type of the routine.
  214.                  */
  215.             if (p -> class == FFUNC) {
  216.                 putop( PCCOM_UNARY PCC_MUL ,
  217.                 PCCM_ADDTYPE(PCCM_ADDTYPE(p2type(p -> type), PCCTM_FTN),
  218.                     PCCTM_PTR));
  219.             } else {
  220.                 /* procedures are int returning functions */
  221.                 putop( PCCOM_UNARY PCC_MUL ,
  222.                 PCCM_ADDTYPE(PCCM_ADDTYPE(PCCT_INT, PCCTM_FTN), PCCTM_PTR));
  223.             }
  224.             break;
  225.         default:
  226.             panic("call class");
  227.         }
  228.         noarguments = TRUE;
  229. #    endif PC
  230.     /*
  231.      * Loop and process each of
  232.      * arguments to the proc/func.
  233.      *    ... ( ... args ... ) ...
  234.      */
  235.     ptype = NIL;
  236.     for (p1 = plist(p); p1 != NLNIL; p1 = p1->chain) {
  237.         if (argv_node == TR_NIL) {
  238.             error("Not enough arguments to %s", p->symbol);
  239.             return (NLNIL);
  240.         }
  241.         switch (p1->class) {
  242.         case REF:
  243.             /*
  244.              * Var parameter
  245.              */
  246.             rnode = argv_node->list_node.list;
  247.             if (rnode != TR_NIL && rnode->tag != T_VAR) {
  248.                 error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol);
  249.                 chk = FALSE;
  250.                 break;
  251.             }
  252.             q = lvalue( argv_node->list_node.list,
  253.                     MOD | ASGN , LREQ );
  254.             if (q == NIL) {
  255.                 chk = FALSE;
  256.                 break;
  257.             }
  258.             p2 = p1->type;
  259.             if (p2 == NLNIL || p2->chain == NLNIL || p2->chain->class != CRANGE) {
  260.                 if (q != p2) {
  261.                 error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
  262.                 chk = FALSE;
  263.                 }
  264.                 break;
  265.             } else {
  266.                 /* conformant array */
  267.                 if (p1 == ptype) {
  268.                 if (q != ctype) {
  269.                     error("Conformant array parameters in the same specification must be the same type.");
  270.                     goto conf_err;
  271.                 }
  272.                 } else {
  273.                 if (classify(q) != TARY && classify(q) != TSTR) {
  274.                     error("Array type required for var parameter %s of %s",p1->symbol,p->symbol);
  275.                     goto conf_err;
  276.                 }
  277.                 /* check base type of array */
  278.                 if (p2->type != q->type) {
  279.                     error("Base type of array not identical to that of conformant array parameter %s of %s", p1->symbol, p->symbol);
  280.                     goto conf_err;
  281.                 }
  282.                 if (p2->value[0] != q->value[0]) {
  283.                     error("Subscript number mismatch on conformant array parameter %s of %s", p1->symbol, p->symbol);
  284.                     /* Don't process array bounds & width */
  285. conf_err:                if (p1->chain->type->class == CRANGE) {
  286.                     d = p1->value[0];
  287.                     for (i = 1; i <= d; i++) {
  288.                         /* for each subscript, pass by
  289.                          * bounds and width
  290.                          */
  291.                         p1 = p1->chain->chain->chain;
  292.                     }
  293.                     }
  294.                     ptype = ctype = NLNIL;
  295.                     chk = FALSE;
  296.                     break;
  297.                 }
  298.                 /*
  299.                  * Save array type for all parameters with same
  300.                  * specification.
  301.                  */
  302.                 ctype = q;
  303.                 ptype = p2;
  304.                 /*
  305.                  * If at end of conformant array list,
  306.                  * get bounds.
  307.                  */
  308.                 if (p1->chain->type->class == CRANGE) {
  309.                     /* check each subscript, put on stack */
  310.                     d = ptype->value[0];
  311.                     q = ctype;
  312.                     for (i = 1; i <= d; i++) {
  313.                     p1 = p1->chain;
  314.                     q = q->chain;
  315.                     if (incompat(q, p1->type, TR_NIL)){
  316.                         error("Subscript type not conformable with parameter %s of %s", p1->symbol, p->symbol);
  317.                         chk = FALSE;
  318.                         break;
  319.                     }
  320.                     /* Put lower and upper bound & width */
  321. #                    ifdef OBJ
  322.                     if (q->type->class == CRANGE) {
  323.                         putcbnds(q->type);
  324.                     } else {
  325.                         put(2, width(p1->type) <= 2 ? O_CON2
  326.                         : O_CON4, q->range[0]);
  327.                         put(2, width(p1->type) <= 2 ? O_CON2
  328.                         : O_CON4, q->range[1]);
  329.                         put(2, width(p1->type) <= 2 ? O_CON2
  330.                         : O_CON4, aryconst(ctype,i));
  331.                     }
  332. #                    endif OBJ
  333. #                    ifdef PC
  334.                     if (q->type->class == CRANGE) {
  335.                         for (j = 1; j <= 3; j++) {
  336.                         p2 = p->nptr[j];
  337.                         putRV(p2->symbol, (p2->nl_block
  338.                             & 037), p2->value[0],
  339.                             p2->extra_flags,p2type(p2));
  340.                         putop(PCC_CM, PCCT_INT);
  341.                         }
  342.                     } else {
  343.                         putleaf(PCC_ICON, q->range[0], 0,PCCT_INT,0);
  344.                         putop( PCC_CM , PCCT_INT );
  345.                         putleaf(PCC_ICON, q->range[1], 0,PCCT_INT,0);
  346.                         putop( PCC_CM , PCCT_INT );
  347.                         putleaf(PCC_ICON,aryconst(ctype,i),0,PCCT_INT,0);
  348.                         putop( PCC_CM , PCCT_INT );
  349.                     }
  350. #                    endif PC
  351.                     p1 = p1->chain->chain;
  352.                     }
  353.                 }
  354.                 }
  355.             }
  356.             break;
  357.         case VAR:
  358.             /*
  359.              * Value parameter
  360.              */
  361. #            ifdef OBJ
  362.                 q = rvalue(argv_node->list_node.list,
  363.                     p1->type , RREQ );
  364. #            endif OBJ
  365. #            ifdef PC
  366.                 /*
  367.                  * structure arguments require lvalues,
  368.                  * scalars use rvalue.
  369.                  */
  370.                 switch( classify( p1 -> type ) ) {
  371.                 case TFILE:
  372.                 case TARY:
  373.                 case TREC:
  374.                 case TSET:
  375.                 case TSTR:
  376.                 q = stkrval(argv_node->list_node.list,
  377.                         p1 -> type , (long) LREQ );
  378.                     break;
  379.                 case TINT:
  380.                 case TSCAL:
  381.                 case TBOOL:
  382.                 case TCHAR:
  383.                     precheck( p1 -> type , "_RANG4" , "_RSNG4" );
  384.                 q = stkrval(argv_node->list_node.list,
  385.                         p1 -> type , (long) RREQ );
  386.                     postcheck(p1 -> type, nl+T4INT);
  387.                     break;
  388.                 case TDOUBLE:
  389.                 q = stkrval(argv_node->list_node.list,
  390.                         p1 -> type , (long) RREQ );
  391.                     sconv(p2type(q), PCCT_DOUBLE);
  392.                     break;
  393.                 default:
  394.                     q = rvalue(argv_node->list_node.list,
  395.                         p1 -> type , RREQ );
  396.                     break;
  397.                 }
  398. #            endif PC
  399.             if (q == NIL) {
  400.                 chk = FALSE;
  401.                 break;
  402.             }
  403.             if (incompat(q, p1->type,
  404.                 argv_node->list_node.list)) {
  405.                 cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);
  406.                 chk = FALSE;
  407.                 break;
  408.             }
  409. #            ifdef OBJ
  410.                 if (isa(p1->type, "bcsi"))
  411.                     rangechk(p1->type, q);
  412.                 if (q->class != STR)
  413.                     convert(q, p1->type);
  414. #            endif OBJ
  415. #            ifdef PC
  416.                 switch( classify( p1 -> type ) ) {
  417.                 case TFILE:
  418.                 case TARY:
  419.                 case TREC:
  420.                 case TSET:
  421.                 case TSTR:
  422.                     putstrop( PCC_STARG
  423.                         , p2type( p1 -> type )
  424.                         , (int) lwidth( p1 -> type )
  425.                         , align( p1 -> type ) );
  426.                 }
  427. #            endif PC
  428.             break;
  429.         case FFUNC:
  430.             /*
  431.              * function parameter
  432.              */
  433.             q = flvalue(argv_node->list_node.list, p1 );
  434.             /*chk = (chk && fcompat(q, p1));*/
  435.             if ((chk) && (fcompat(q, p1)))
  436.                 chk = TRUE;
  437.             else
  438.                 chk = FALSE;
  439.             break;
  440.         case FPROC:
  441.             /*
  442.              * procedure parameter
  443.              */
  444.             q = flvalue(argv_node->list_node.list, p1 );
  445.             /* chk = (chk && fcompat(q, p1)); */
  446.             if ((chk) && (fcompat(q, p1)))
  447.                 chk = TRUE;
  448.             else chk = FALSE;
  449.             break;
  450.         default:
  451.             panic("call");
  452.         }
  453. #        ifdef PC
  454.             /*
  455.              *    if this is the nth (>1) argument,
  456.              *    hang it on the left linear list of arguments
  457.              */
  458.         if ( noarguments ) {
  459.             noarguments = FALSE;
  460.         } else {
  461.             putop( PCC_CM , PCCT_INT );
  462.         }
  463. #        endif PC
  464.         argv_node = argv_node->list_node.next;
  465.     }
  466.     if (argv_node != TR_NIL) {
  467.         error("Too many arguments to %s", p->symbol);
  468.         rvlist(argv_node);
  469.         return (NLNIL);
  470.     }
  471.     if (chk == FALSE)
  472.         return NLNIL;
  473. #    ifdef OBJ
  474.         if ( p -> class == FFUNC || p -> class == FPROC ) {
  475.         (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
  476.          (void) put(2, O_LV | cbn << 8 + INDX ,
  477.              (int) savedispnp -> value[ NL_OFFS ] );
  478.         (void) put(1, O_FCALL);
  479.         (void) put(2, O_FRTN, roundup(width(p->type), (long) A_STACK));
  480.         } else {
  481.         (void) put(2, O_CALL | psbn << 8, (long)p->value[NL_ENTLOC]);
  482.         }
  483. #    endif OBJ
  484. #    ifdef PC
  485.         /*
  486.          *    for formal calls: add the hidden argument
  487.          *    which is the formal struct describing the
  488.          *    environment of the routine.
  489.          *    and the argument which is the address of the
  490.          *    space into which to save the display.
  491.          */
  492.         if ( p -> class == FFUNC || p -> class == FPROC ) {
  493.         putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
  494.             tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
  495.         if ( !noarguments ) {
  496.             putop( PCC_CM , PCCT_INT );
  497.         }
  498.         noarguments = FALSE;
  499.          putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
  500.              savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
  501.          putop( PCC_CM , PCCT_INT );
  502.         }
  503.         /*
  504.          *    do the actual call:
  505.          *        either    ... p( ... ) ...
  506.          *        or        ... ( t -> entryaddr )( ... ) ...
  507.          *    and maybe an assignment.
  508.          */
  509.         if ( porf == FUNC ) {
  510.         switch ( p_type_class ) {
  511.             case TBOOL:
  512.             case TCHAR:
  513.             case TINT:
  514.             case TSCAL:
  515.             case TDOUBLE:
  516.             case TPTR:
  517.             putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) ,
  518.                 (int) p_type_p2type );
  519.             if ( p -> class == FFUNC ) {
  520.                 putop( PCC_ASSIGN , (int) p_type_p2type );
  521.             }
  522.             break;
  523.             default:
  524.             putstrop( ( noarguments ? PCCOM_UNARY PCC_STCALL : PCC_STCALL ),
  525.                 (int) PCCM_ADDTYPE( p_type_p2type , PCCTM_PTR ) ,
  526.                 (int) p_type_width ,(int) p_type_align );
  527.             putstrop(PCC_STASG, (int) PCCM_ADDTYPE(p_type_p2type, PCCTM_PTR),
  528.                 (int) lwidth(p -> type), align(p -> type));
  529.             break;
  530.         }
  531.         } else {
  532.         putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) , PCCT_INT );
  533.         }
  534.         /*
  535.          *    ( t=p , ... , FRTN( t ) ...
  536.          */
  537.         if ( p -> class == FFUNC || p -> class == FPROC ) {
  538.         putop( PCC_COMOP , PCCT_INT );
  539.         putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) ,
  540.             "_FRTN" );
  541.         putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
  542.             tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
  543.          putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
  544.              savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
  545.          putop( PCC_CM , PCCT_INT );
  546.         putop( PCC_CALL , PCCT_INT );
  547.         putop( PCC_COMOP , PCCT_INT );
  548.         }
  549.         /*
  550.          *    if required:
  551.          *    either    ... , temp )
  552.          *    or    ... , &temp )
  553.          */
  554.         if ( porf == FUNC && temptype != PCCT_UNDEF ) {
  555.         if ( temptype != PCCT_STRTY ) {
  556.             putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
  557.                 tempnlp -> extra_flags , (int) p_type_p2type );
  558.         } else {
  559.             putLV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
  560.                 tempnlp -> extra_flags , (int) p_type_p2type );
  561.         }
  562.         putop( PCC_COMOP , PCCT_INT );
  563.         }
  564.         if ( porf == PROC ) {
  565.         putdot( filename , line );
  566.         }
  567. #    endif PC
  568.     return (p->type);
  569. }
  570.  
  571. rvlist(al)
  572.     register struct tnode *al;
  573. {
  574.  
  575.     for (; al != TR_NIL; al = al->list_node.next)
  576.         (void) rvalue( al->list_node.list, NLNIL , RREQ );
  577. }
  578.  
  579.     /*
  580.      *    check that two function/procedure namelist entries are compatible
  581.      */
  582. bool
  583. fcompat( formal , actual )
  584.     struct nl    *formal;
  585.     struct nl    *actual;
  586. {
  587.     register struct nl    *f_chain;
  588.     register struct nl    *a_chain;
  589.     extern struct nl    *plist();
  590.     bool compat = TRUE;
  591.  
  592.     if ( formal == NLNIL || actual == NLNIL ) {
  593.     return FALSE;
  594.     }
  595.     for (a_chain = plist(actual), f_chain = plist(formal);
  596.          f_chain != NLNIL;
  597.      f_chain = f_chain->chain, a_chain = a_chain->chain) {
  598.     if (a_chain == NIL) {
  599.         error("%s %s declared on line %d has more arguments than",
  600.         parnam(formal->class), formal->symbol,
  601.         (char *) linenum(formal));
  602.         cerror("%s %s declared on line %d",
  603.         parnam(actual->class), actual->symbol,
  604.         (char *) linenum(actual));
  605.         return FALSE;
  606.     }
  607.     if ( a_chain -> class != f_chain -> class ) {
  608.         error("%s parameter %s of %s declared on line %d is not identical",
  609.         parnam(f_chain->class), f_chain->symbol,
  610.         formal->symbol, (char *) linenum(formal));
  611.         cerror("with %s parameter %s of %s declared on line %d",
  612.         parnam(a_chain->class), a_chain->symbol,
  613.         actual->symbol, (char *) linenum(actual));
  614.         compat = FALSE;
  615.     } else if (a_chain->class == FFUNC || a_chain->class == FPROC) {
  616.         /*compat = (compat && fcompat(f_chain, a_chain));*/
  617.         if ((compat) && (fcompat(f_chain, a_chain)))
  618.         compat = TRUE;
  619.         else compat = FALSE;
  620.     }
  621.     if ((a_chain->class != FPROC && f_chain->class != FPROC) &&
  622.         (a_chain->type != f_chain->type)) {
  623.         error("Type of %s parameter %s of %s declared on line %d is not identical",
  624.         parnam(f_chain->class), f_chain->symbol,
  625.         formal->symbol, (char *) linenum(formal));
  626.         cerror("to type of %s parameter %s of %s declared on line %d",
  627.         parnam(a_chain->class), a_chain->symbol,
  628.         actual->symbol, (char *) linenum(actual));
  629.         compat = FALSE;
  630.     }
  631.     }
  632.     if (a_chain != NIL) {
  633.     error("%s %s declared on line %d has fewer arguments than",
  634.         parnam(formal->class), formal->symbol,
  635.         (char *) linenum(formal));
  636.     cerror("%s %s declared on line %d",
  637.         parnam(actual->class), actual->symbol,
  638.         (char *) linenum(actual));
  639.     return FALSE;
  640.     }
  641.     return compat;
  642. }
  643.  
  644. char *
  645. parnam(nltype)
  646.     int nltype;
  647. {
  648.     switch(nltype) {
  649.     case REF:
  650.         return "var";
  651.     case VAR:
  652.         return "value";
  653.     case FUNC:
  654.     case FFUNC:
  655.         return "function";
  656.     case PROC:
  657.     case FPROC:
  658.         return "procedure";
  659.     default:
  660.         return "SNARK";
  661.     }
  662. }
  663.  
  664. struct nl *plist(p)
  665.     struct nl *p;
  666. {
  667.     switch (p->class) {
  668.     case FFUNC:
  669.     case FPROC:
  670.         return p->ptr[ NL_FCHAIN ];
  671.     case PROC:
  672.     case FUNC:
  673.         return p->chain;
  674.     default:
  675.         {
  676.         panic("plist");
  677.         return(NLNIL); /* this is here only so lint won't complain
  678.                   panic actually aborts */
  679.         }
  680.  
  681.     }
  682. }
  683.  
  684. linenum(p)
  685.     struct nl *p;
  686. {
  687.     if (p->class == FUNC)
  688.     return p->ptr[NL_FVAR]->value[NL_LINENO];
  689.     return p->value[NL_LINENO];
  690. }
  691.