BSD 4_1_snap release

[unix-history] / usr / src / cmd / pc0 / call.c

diff --git a/usr/src/cmd/pc0/call.c b/usr/src/cmd/pc0/call.c
index 8480cc1..f351584 100644 (file)
--- a/usr/src/cmd/pc0/call.c
+++ b/usr/src/cmd/pc0/call.c
@@ -1,6 +1,6 @@
 /* Copyright (c) 1979 Regents of the University of California */
 
 /* Copyright (c) 1979 Regents of the University of California */
 

-static char sccsid[] = "@(#)call.c 1.3 10/2/80";
+static char sccsid[] = "@(#)call.c 1.17 6/12/81";

 
 #include "whoami.h"
 #include "0.h"
 
 #include "whoami.h"
 #include "0.h"


@@ -12,9 +12,6 @@ static        char sccsid[] = "@(#)call.c 1.3 10/2/80";
 #   include "pcops.h"
 #endif PC
 
 #   include "pcops.h"
 #endif PC
 

-bool   slenflag = 0;
-bool   floatflag = 0;
-

 /*
  * Call generates code for calls to
  * user defined procedures and functions
 /*
  * Call generates code for calls to
  * user defined procedures and functions


@@ -23,6 +20,32 @@ bool floatflag = 0;
  * of the procedure/function symbol,
  * and porf is PROC or FUNC.
  * Psbn is the block number of p.
  * of the procedure/function symbol,
  * and porf is PROC or FUNC.
  * Psbn is the block number of p.

+ *
+ *     the idea here is that regular scalar functions are just called,
+ *     while structure functions and formal functions have their results
+ *     stored in a temporary after the call.
+ *     structure functions do this because they return pointers
+ *     to static results, so we copy the static
+ *     and return a pointer to the copy.
+ *     formal functions do this because we have to save the result
+ *     around a call to the runtime routine which restores the display,
+ *     so we can't just leave the result lying around in registers.
+ *     formal calls save the address of the descriptor in a local
+ *     temporary, so it can be addressed for the call which restores
+ *     the display (FRTN).
+ *     calls to formal parameters pass the formal as a hidden argument 
+ *     to a special entry point for the formal call.
+ *     [this is somewhat dependent on the way arguments are addressed.]
+ *     so PROCs and scalar FUNCs look like
+ *             p(...args...)
+ *     structure FUNCs look like
+ *             (temp = p(...args...),&temp)
+ *     formal FPROCs look like
+ *             ( t=p,( t -> entryaddr )(...args...,t),FRTN( t ))
+ *     formal scalar FFUNCs look like
+ *             ( t=p,temp=( t -> entryaddr )(...args...,t),FRTN( t ),temp)
+ *     formal structure FFUNCs look like
+ *             (t=p,temp = ( t -> entryaddr )(...args...,t),FRTN( t ),&temp)

  */
 struct nl *
 call(p, argv, porf, psbn)
  */
 struct nl *
 call(p, argv, porf, psbn)


@@ -31,359 +54,338 @@ call(p, argv, porf, psbn)
 {
        register struct nl *p1, *q;
        int *r;
 {
        register struct nl *p1, *q;
        int *r;

-
-#      ifdef OBJ
-           int         cnt;
-#      endif OBJ
+       struct nl       *p_type_class = classify( p -> type );
+       bool chk = TRUE;

 #      ifdef PC
 #      ifdef PC

-           long        temp;
-           int         firsttime;
-           int         rettype;
+           long        p_p2type = p2type( p );
+           long        p_type_p2type = p2type( p -> type );
+           bool        noarguments;
+           long        calltype;       /* type of the call */
+               /*
+                *      these get used if temporaries and structures are used
+                */
+           struct nl   *tempnlp;
+           long        temptype;       /* type of the temporary */
+           long        p_type_width;
+           long        p_type_align;
+           char        extname[ BUFSIZ ];
+           struct nl   *tempdescrp;

 #      endif PC
 
 #      ifdef OBJ
 #      endif PC
 
 #      ifdef OBJ

-           if (p->class == FFUNC || p->class == FPROC)
-               put(2, PTR_RV | cbn << 8+INDX, p->value[NL_OFFS]);
-           if (porf == FUNC)
+           if (p->class == FFUNC || p->class == FPROC) {
+               put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
+           }
+           if (porf == FUNC) {

                    /*
                     * Push some space
                     * for the function return type
                     */
                    /*
                     * Push some space
                     * for the function return type
                     */

-                   put2(O_PUSH, even(-width(p->type)));
+                   put(2, O_PUSH, leven(-lwidth(p->type)));
+           }

 #      endif OBJ
 #      ifdef PC
 #      endif OBJ
 #      ifdef PC

+               /*
+                *      if this is a formal call,
+                *      stash the address of the descriptor
+                *      in a temporary so we can find it
+                *      after the FCALL for the call to FRTN
+                */
+           if ( p -> class == FFUNC || p -> class == FPROC ) {
+               tempdescrp = tmpalloc(sizeof( struct formalrtn *) , NIL ,
+                                       REGOK );
+               putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
+                       tempdescrp -> extra_flags , P2PTR|P2STRTY );
+               putRV( 0 , psbn , p -> value[ NL_OFFS ] ,
+                       p -> extra_flags , P2PTR|P2STRTY );
+               putop( P2ASSIGN , P2PTR | P2STRTY );
+           }
+               /*
+                *      if we have to store a temporary,
+                *      temptype will be its type,
+                *      otherwise, it's P2UNDEF.
+                */
+           temptype = P2UNDEF;
+           calltype = P2INT;

            if ( porf == FUNC ) {
            if ( porf == FUNC ) {

-               switch( classify( p -> type ) ) {
+               p_type_width = width( p -> type );
+               switch( p_type_class ) {

                    case TSTR:
                    case TSET:
                    case TREC:
                    case TFILE:
                    case TARY:
                    case TSTR:
                    case TSET:
                    case TREC:
                    case TFILE:
                    case TARY:

-                       temp = sizes[ cbn ].om_off -= width( p -> type );
-                       putlbracket( ftnno , -sizes[cbn].om_off );
-                       if (sizes[cbn].om_off < sizes[cbn].om_max) {
-                               sizes[cbn].om_max = sizes[cbn].om_off;
+                       calltype = temptype = P2STRTY;
+                       p_type_align = align( p -> type );
+                       break;
+                   default:
+                       if ( p -> class == FFUNC ) {
+                           calltype = temptype = p2type( p -> type );

                        }
                        }

-                       putRV( 0 , cbn , temp , P2STRTY );
+                       break;
+               }
+               if ( temptype != P2UNDEF ) {
+                   tempnlp = tmpalloc(p_type_width, p -> type, NOREG);
+                       /*
+                        *      temp
+                        *      for (temp = ...
+                        */
+                   putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
+                           tempnlp -> extra_flags , temptype );

                }
            }
            switch ( p -> class ) {
                case FUNC:
                case PROC:
                }
            }
            switch ( p -> class ) {
                case FUNC:
                case PROC:

-                   {
-                       char    extname[ BUFSIZ ];
-                       char    *starthere;
-                       int     funcbn;
-                       int     i;
-
-                       starthere = &extname[0];
-                       funcbn = p -> nl_block & 037;
-                       for ( i = 1 ; i < funcbn ; i++ ) {
-                           sprintf( starthere , EXTFORMAT , enclosing[ i ] );
-                           starthere += strlen( enclosing[ i ] ) + 1;
-                       }
-                       sprintf( starthere , EXTFORMAT , p -> symbol );
-                       starthere += strlen( p -> symbol ) + 1;
-                       if ( starthere >= &extname[ BUFSIZ ] ) {
-                           panic( "call namelength" );
-                       }
-                       putleaf( P2ICON , 0 , 0 , p2type( p ) , extname );
-                   }
+                       /*
+                        *      ... p( ...
+                        */
+                   sextname( extname , p -> symbol , BLOCKNO(p -> nl_block) );
+                   putleaf( P2ICON , 0 , 0 , p2type( p ) , extname );

                    break;
                case FFUNC:
                case FPROC:
                    break;
                case FFUNC:
                case FPROC:

+

                            /*
                            /*

-                            *  start one of these:
-                            *  FRTN( frtn , ( *FCALL( frtn ) )(...args...) )
+                            *  ... ( t -> entryaddr )( ...

                             */
                             */

-                       putleaf( P2ICON , 0 , 0 , p2type( p ) , "_FRTN" );
-                       putRV( 0 , cbn , p -> value[NL_OFFS] , P2PTR|P2STRTY );
-                       putleaf( P2ICON , 0 , 0
-                           , ADDTYPE( P2PTR , ADDTYPE( P2FTN , p2type( p ) ) )
-                           , "_FCALL" );
-                       putRV( 0 , cbn , p -> value[NL_OFFS] , P2PTR|P2STRTY );
-                       putop( P2CALL , p2type( p ) );
+                       putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
+                               tempdescrp -> extra_flags , P2PTR | P2STRTY );
+                       if ( FENTRYOFFSET != 0 ) {
+                           putleaf( P2ICON , FENTRYOFFSET , 0 , P2INT , 0 );
+                           putop( P2PLUS , 
+                               ADDTYPE(
+                                   ADDTYPE( ADDTYPE( p2type( p ) , P2FTN ) ,
+                                           P2PTR ) ,
+                                       P2PTR ) );
+                       }
+                       putop( P2UNARY P2MUL ,
+                           ADDTYPE( ADDTYPE( p2type( p ) , P2FTN ) , P2PTR ) );

                        break;
                default:
                        panic("call class");
            }
                        break;
                default:
                        panic("call class");
            }

-           firsttime = TRUE;
+           noarguments = TRUE;

 #      endif PC
        /*
         * Loop and process each of
         * arguments to the proc/func.
 #      endif PC
        /*
         * Loop and process each of
         * arguments to the proc/func.

+        *      ... ( ... args ... ) ...

         */
         */

-       if ( p -> class == FUNC || p -> class == PROC ) {
-           for (p1 = p->chain; p1 != NIL; p1 = p1->chain) {
-               if (argv == NIL) {
-                       error("Not enough arguments to %s", p->symbol);
-                       return (NIL);
-               }
-               switch (p1->class) {
-                   case REF:
-                           /*
-                            * Var parameter
-                            */
-                           r = argv[1];
-                           if (r != NIL && r[0] != T_VAR) {
-                                   error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol);
-                                   break;
-                           }
-                           q = lvalue( (int *) argv[1], MOD , LREQ );
-                           if (q == NIL)
-                                   break;
-                           if (q != p1->type) {
-                                   error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
-                                   break;
-                           }
-                           break;
-                   case VAR:
-                           /*
-                            * Value parameter
-                            */
+       for (p1 = plist(p); p1 != NIL; p1 = p1->chain) {
+           if (argv == NIL) {
+                   error("Not enough arguments to %s", p->symbol);
+                   return (NIL);
+           }
+           switch (p1->class) {
+               case REF:
+                       /*
+                        * Var parameter
+                        */
+                       r = argv[1];
+                       if (r != NIL && r[0] != T_VAR) {
+                               error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol);
+                               chk = FALSE;
+                               break;
+                       }
+                       q = lvalue( (int *) argv[1], MOD | ASGN , LREQ );
+                       if (q == NIL) {
+                               chk = FALSE;
+                               break;
+                       }
+                       if (q != p1->type) {
+                               error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
+                               chk = FALSE;
+                               break;
+                       }
+                       break;
+               case VAR:
+                       /*
+                        * Value parameter
+                        */

 #                      ifdef OBJ
 #                      ifdef OBJ

-                               q = rvalue(argv[1], p1->type , RREQ );
+                           q = rvalue(argv[1], p1->type , RREQ );

 #                      endif OBJ
 #                      ifdef PC
 #                      endif OBJ
 #                      ifdef PC

-                                   /*
-                                    * structure arguments require lvalues,
-                                    * scalars use rvalue.
-                                    */
-                               switch( classify( p1 -> type ) ) {
-                                   case TFILE:
-                                   case TARY:
-                                   case TREC:
-                                   case TSET:
-                                   case TSTR:
-                                       q = rvalue( argv[1] , p1 -> type , LREQ );
-                                       break;
-                                   case TINT:
-                                   case TSCAL:
-                                   case TBOOL:
-                                   case TCHAR:
-                                       precheck( p1 -> type , "_RANG4" , "_RSNG4" );
-                                       q = rvalue( argv[1] , p1 -> type , RREQ );
-                                       postcheck( p1 -> type );
-                                       break;
-                                   default:
-                                       q = rvalue( argv[1] , p1 -> type , RREQ );
-                                       if (  isa( p1 -> type  , "d" )
-                                          && isa( q , "i" ) ) {
-                                           putop( P2SCONV , P2DOUBLE );
-                                       }
-                                       break;
-                               }
-#                      endif PC
-                           if (q == NIL)
+                               /*
+                                * structure arguments require lvalues,
+                                * scalars use rvalue.
+                                */
+                           switch( classify( p1 -> type ) ) {
+                               case TFILE:
+                               case TARY:
+                               case TREC:
+                               case TSET:
+                               case TSTR:
+                                   q = rvalue( argv[1] , p1 -> type , LREQ );
+                                   break;
+                               case TINT:
+                               case TSCAL:
+                               case TBOOL:
+                               case TCHAR:
+                                   precheck( p1 -> type , "_RANG4" , "_RSNG4" );
+                                   q = rvalue( argv[1] , p1 -> type , RREQ );
+                                   postcheck( p1 -> type );

                                    break;
                                    break;

-                           if (incompat(q, p1->type, argv[1])) {
-                                   cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);
+                               default:
+                                   q = rvalue( argv[1] , p1 -> type , RREQ );
+                                   if (  isa( p1 -> type  , "d" )
+                                      && isa( q , "i" ) ) {
+                                       putop( P2SCONV , P2DOUBLE );
+                                   }

                                    break;
                            }
                                    break;
                            }

+#                      endif PC
+                       if (q == NIL) {
+                               chk = FALSE;
+                               break;
+                       }
+                       if (incompat(q, p1->type, argv[1])) {
+                               cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);
+                               chk = FALSE;
+                               break;
+                       }

 #                      ifdef OBJ
 #                      ifdef OBJ

-                               if (isa(p1->type, "bcsi"))
-                                       rangechk(p1->type, q);
-                               if (q->class != STR)
-                                       convert(q, p1->type);
+                           if (isa(p1->type, "bcsi"))
+                                   rangechk(p1->type, q);
+                           if (q->class != STR)
+                                   convert(q, p1->type);

 #                      endif OBJ
 #                      ifdef PC
 #                      endif OBJ
 #                      ifdef PC

-                               switch( classify( p1 -> type ) ) {
-                                   case TFILE:
-                                   case TARY:
-                                   case TREC:
-                                   case TSET:
-                                   case TSTR:
-                                           putstrop( P2STARG
-                                               , p2type( p1 -> type )
-                                               , lwidth( p1 -> type )
-                                               , align( p1 -> type ) );
-                               }
-#                      endif PC
-                           break;
-                   case FFUNC:
-                           /*
-                            * function parameter
-                            */
-                           q = flvalue( (int *) argv[1] , FFUNC );
-                           if (q == NIL)
-                                   break;
-                           if (q != p1->type) {
-                                   error("Function type not identical to type of function parameter %s of %s", p1->symbol, p->symbol);
-                                   break;
+                           switch( classify( p1 -> type ) ) {
+                               case TFILE:
+                               case TARY:
+                               case TREC:
+                               case TSET:
+                               case TSTR:
+                                       putstrop( P2STARG
+                                           , p2type( p1 -> type )
+                                           , lwidth( p1 -> type )
+                                           , align( p1 -> type ) );

                            }
                            }

-                           break;
-                   case FPROC:
-                           /*
-                            * procedure parameter
-                            */
-                           q = flvalue( (int *) argv[1] , FPROC );
-                           if (q != NIL) {
-                                   error("Procedure parameter %s of %s cannot have a type", p1->symbol, p->symbol);
-                           }
-                           break;
-                   default:
-                           panic("call");
-               }
-#          ifdef PC
-                       /*
-                        *      if this is the nth (>1) argument,
-                        *      hang it on the left linear list of arguments
-                        */
-                   if ( firsttime ) {
-                           firsttime = FALSE;
-                   } else {
-                           putop( P2LISTOP , P2INT );
-                   }
-#          endif PC
-               argv = argv[2];
-           }
-           if (argv != NIL) {
-                   error("Too many arguments to %s", p->symbol);
-                   rvlist(argv);
-                   return (NIL);
-           }
-       } else if ( p -> class == FFUNC || p -> class == FPROC ) {
-               /*
-                *      formal routines can only have by-value parameters.
-                *      this will lose for integer actuals passed to real
-                *      formals, and strings which people want blank padded.
-                */
-#          ifdef OBJ
-               cnt = 0;
-#          endif OBJ
-           for ( ; argv != NIL ; argv = argv[2] ) {
-#              ifdef OBJ
-                   q = rvalue(argv[1], NIL, RREQ );
-                   cnt += even(lwidth(q));
-#              endif OBJ
-#              ifdef PC
+#                      endif PC
+                       break;
+               case FFUNC:

                        /*
                        /*

-                        * structure arguments require lvalues,
-                        * scalars use rvalue.
+                        * function parameter

                         */
                         */

-                   codeoff();
-                   p1 = rvalue( argv[1] , NIL , RREQ );
-                   codeon();
-                   switch( classify( p1 ) ) {
-                       case TSTR:
-                           if ( p1 -> class == STR && slenflag == 0 ) {
-                               if ( opt( 's' ) ) {
-                                   standard();
-                               } else {
-                                   warning();
-                               }
-                               error("Implementation can't construct equal length strings");
-                               slenflag++;
-                           }
-                           /* and fall through */
-                       case TFILE:
-                       case TARY:
-                       case TREC:
-                       case TSET:
-                           q = rvalue( argv[1] , p1 , LREQ );
-                           break;
-                       case TINT:
-                           if ( floatflag == 0 ) {
-                               if ( opt( 's' ) ) {
-                                   standard();
-                               } else {
-                                   warning();
-                               }
-                               error("Implementation can't coerice integer to real");
-                               floatflag++;
-                           }
-                           /* and fall through */
-                       case TSCAL:
-                       case TBOOL:
-                       case TCHAR:
-                       default:
-                           q = rvalue( argv[1] , p1 , RREQ );
-                           break;
-                   }
-                   switch( classify( p1 ) ) {
-                       case TFILE:
-                       case TARY:
-                       case TREC:
-                       case TSET:
-                       case TSTR:
-                               putstrop( P2STARG , p2type( p1 ) ,
-                                   lwidth( p1 ) , align( p1 ) );
-                   }
+                       q = flvalue( (int *) argv[1] , p1 );
+                       chk = (chk && fcompat(q, p1));
+                       break;
+               case FPROC:

                        /*
                        /*

-                        *      if this is the nth (>1) argument,
-                        *      hang it on the left linear list of arguments
+                        * procedure parameter

                         */
                         */

-                   if ( firsttime ) {
-                           firsttime = FALSE;
-                   } else {
-                           putop( P2LISTOP , P2INT );
-                   }
-#              endif PC
+                       q = flvalue( (int *) argv[1] , p1 );
+                       chk = (chk && fcompat(q, p1));
+                       break;
+               default:
+                       panic("call");

            }
            }

-       } else {
-           panic("call class");
+#          ifdef PC
+                   /*
+                    *  if this is the nth (>1) argument,
+                    *  hang it on the left linear list of arguments
+                    */
+               if ( noarguments ) {
+                       noarguments = FALSE;
+               } else {
+                       putop( P2LISTOP , P2INT );
+               }
+#          endif PC
+           argv = argv[2];

        }
        }

+       if (argv != NIL) {
+               error("Too many arguments to %s", p->symbol);
+               rvlist(argv);
+               return (NIL);
+       }
+       if (chk == FALSE)
+               return NIL;

 #      ifdef OBJ
            if ( p -> class == FFUNC || p -> class == FPROC ) {
 #      ifdef OBJ
            if ( p -> class == FFUNC || p -> class == FPROC ) {

-               put(2, PTR_RV | cbn << 8+INDX, p->value[NL_OFFS]);
-               put(2, O_FCALL, cnt);
-               put(2, O_FRTN, even(lwidth(p->type)));
+               put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
+               put(1, O_FCALL);
+               put(2, O_FRTN, even(width(p->type)));

            } else {
            } else {

-               put2(O_CALL | psbn << 8+INDX, p->entloc);
+               put(2, O_CALL | psbn << 8, (long)p->entloc);

            }
 #      endif OBJ
 #      ifdef PC
            }
 #      endif OBJ
 #      ifdef PC

+               /*
+                *      for formal calls: add the hidden argument
+                *      which is the formal struct describing the
+                *      environment of the routine.
+                *      and the argument which is the address of the
+                *      space into which to save the display.
+                */
+           if ( p -> class == FFUNC || p -> class == FPROC ) {
+               putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
+                       tempdescrp -> extra_flags , P2PTR|P2STRTY );
+               if ( !noarguments ) {
+                   putop( P2LISTOP , P2INT );
+               }
+               noarguments = FALSE;
+           }
+               /*
+                *      do the actual call:
+                *          either      ... p( ... ) ...
+                *          or          ... ( t -> entryaddr )( ... ) ...
+                *      and maybe an assignment.
+                */

            if ( porf == FUNC ) {
            if ( porf == FUNC ) {

-               rettype = p2type( p -> type );
-               switch ( classify( p -> type ) ) {
+               switch ( p_type_class ) {

                    case TBOOL:
                    case TCHAR:
                    case TINT:
                    case TSCAL:
                    case TDOUBLE:
                    case TPTR:
                    case TBOOL:
                    case TCHAR:
                    case TINT:
                    case TSCAL:
                    case TDOUBLE:
                    case TPTR:

-                       if ( firsttime ) {
-                               putop( P2UNARY P2CALL , rettype );
-                       } else {
-                               putop( P2CALL , rettype );
-                       }
-                       if (p -> class == FFUNC || p -> class == FPROC ) {
-                           putop( P2LISTOP , P2INT );
-                           putop( P2CALL , rettype );
+                       putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) ,
+                               p_type_p2type );
+                       if ( p -> class == FFUNC ) {
+                           putop( P2ASSIGN , p_type_p2type );

                        }
                        break;
                    default:
                        }
                        break;
                    default:

-                       if ( firsttime ) {
-                               putstrop( P2UNARY P2STCALL
-                                       , ADDTYPE( rettype , P2PTR )
-                                       , lwidth( p -> type )
-                                       , align( p -> type ) );
-                       } else {
-                               putstrop( P2STCALL
-                                       , ADDTYPE( rettype , P2PTR )
-                                       , lwidth( p -> type )
-                                       , align( p -> type ) );
-                       }
-                       if (p -> class == FFUNC || p -> class == FPROC ) {
-                           putop( P2LISTOP , P2INT );
-                           putop( P2CALL , ADDTYPE( rettype , P2PTR ) );
-                       }
-                       putstrop( P2STASG , rettype , lwidth( p -> type )
+                       putstrop( ( noarguments ? P2UNARY P2STCALL : P2STCALL ),
+                               ADDTYPE( p_type_p2type , P2PTR ) ,
+                               p_type_width , p_type_align );
+                       putstrop( P2STASG , p_type_p2type , lwidth( p -> type )

                                , align( p -> type ) );
                                , align( p -> type ) );

-                       putLV( 0 , cbn , temp , rettype );
-                       putop( P2COMOP , P2INT );

                        break;
                }
            } else {
                        break;
                }
            } else {

-               if ( firsttime ) {
-                       putop( P2UNARY P2CALL , P2INT );
+               putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , P2INT );
+           }
+               /*
+                *      ( t=p , ... , FRTN( t ) ...
+                */
+           if ( p -> class == FFUNC || p -> class == FPROC ) {
+               putop( P2COMOP , P2INT );
+               putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) ,
+                       "_FRTN" );
+               putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
+                       tempdescrp -> extra_flags , P2PTR | P2STRTY );
+               putop( P2CALL , P2INT );
+               putop( P2COMOP , P2INT );
+           }
+               /*
+                *      if required:
+                *      either  ... , temp )
+                *      or      ... , &temp )
+                */
+           if ( porf == FUNC && temptype != P2UNDEF ) {
+               if ( temptype != P2STRTY ) {
+                   putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
+                           tempnlp -> extra_flags , p_type_p2type );

                } else {
                } else {

-                       putop( P2CALL , P2INT );
-               }
-               if (p -> class == FFUNC || p -> class == FPROC ) {
-                   putop( P2LISTOP , P2INT );
-                   putop( P2CALL , P2INT );
+                   putLV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
+                           tempnlp -> extra_flags , p_type_p2type );

                }
                }

+               putop( P2COMOP , P2INT );
+           }
+           if ( porf == PROC ) {

                putdot( filename , line );
            }
 #      endif PC
                putdot( filename , line );
            }
 #      endif PC


@@ -397,3 +399,107 @@ rvlist(al)
        for (; al != NIL; al = al[2])
                rvalue( (int *) al[1], NLNIL , RREQ );
 }
        for (; al != NIL; al = al[2])
                rvalue( (int *) al[1], NLNIL , RREQ );
 }

+
+    /*
+     * check that two function/procedure namelist entries are compatible
+     */
+bool
+fcompat( formal , actual )
+    struct nl  *formal;
+    struct nl  *actual;
+{
+    register struct nl *f_chain;
+    register struct nl *a_chain;
+    bool compat = TRUE;
+
+    if ( formal == NIL || actual == NIL ) {
+       return FALSE;
+    }
+    for (a_chain = plist(actual), f_chain = plist(formal);
+         f_chain != NIL;
+        f_chain = f_chain->chain, a_chain = a_chain->chain) {
+       if (a_chain == NIL) {
+           error("%s %s declared on line %d has more arguments than",
+               parnam(formal->class), formal->symbol,
+               linenum(formal));
+           cerror("%s %s declared on line %d",
+               parnam(actual->class), actual->symbol,
+               linenum(actual));
+           return FALSE;
+       }
+       if ( a_chain -> class != f_chain -> class ) {
+           error("%s parameter %s of %s declared on line %d is not identical",
+               parnam(f_chain->class), f_chain->symbol,
+               formal->symbol, linenum(formal));
+           cerror("with %s parameter %s of %s declared on line %d",
+               parnam(a_chain->class), a_chain->symbol,
+               actual->symbol, linenum(actual));
+           compat = FALSE;
+       } else if (a_chain->class == FFUNC || a_chain->class == FPROC) {
+           compat = (compat && fcompat(f_chain, a_chain));
+       }
+       if ((a_chain->class != FPROC && f_chain->class != FPROC) &&
+           (a_chain->type != f_chain->type)) {
+           error("Type of %s parameter %s of %s declared on line %d is not identical",
+               parnam(f_chain->class), f_chain->symbol,
+               formal->symbol, linenum(formal));
+           cerror("to type of %s parameter %s of %s declared on line %d",
+               parnam(a_chain->class), a_chain->symbol,
+               actual->symbol, linenum(actual));
+           compat = FALSE;
+       }
+    }
+    if (a_chain != NIL) {
+       error("%s %s declared on line %d has fewer arguments than",
+           parnam(formal->class), formal->symbol,
+           linenum(formal));
+       cerror("%s %s declared on line %d",
+           parnam(actual->class), actual->symbol,
+           linenum(actual));
+       return FALSE;
+    }
+    return compat;
+}
+
+char *
+parnam(nltype)
+    int nltype;
+{
+    switch(nltype) {
+       case REF:
+           return "var";
+       case VAR:
+           return "value";
+       case FUNC:
+       case FFUNC:
+           return "function";
+       case PROC:
+       case FPROC:
+           return "procedure";
+       default:
+           return "SNARK";
+    }
+}
+
+plist(p)
+    struct nl *p;
+{
+    switch (p->class) {
+       case FFUNC:
+       case FPROC:
+           return p->ptr[ NL_FCHAIN ];
+       case PROC:
+       case FUNC:
+           return p->chain;
+       default:
+           panic("plist");
+    }
+}
+
+linenum(p)
+    struct nl *p;
+{
+    if (p->class == FUNC)
+       return p->ptr[NL_FVAR]->value[NL_LINENO];
+    return p->value[NL_LINENO];
+}