Implement formal functions and procedures

[unix-history] / usr / src / usr.bin / pascal / src / call.c

diff --git a/usr/src/usr.bin/pascal/src/call.c b/usr/src/usr.bin/pascal/src/call.c
index e2d7a24..e959d51 100644 (file)
--- a/usr/src/usr.bin/pascal/src/call.c
+++ b/usr/src/usr.bin/pascal/src/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.4 %G%";
+static char sccsid[] = "@(#)call.c 1.3 %G%";

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


@@ -12,6 +12,9 @@ static        char sccsid[] = "@(#)call.c 1.4 %G%";
 #   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


@@ -29,6 +32,9 @@ 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

 #      ifdef PC
            long        temp;
            int         firsttime;
 #      ifdef PC
            long        temp;
            int         firsttime;


@@ -36,6 +42,8 @@ call(p, argv, porf, psbn)
 #      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)
                    /*
                     * Push some space
            if (porf == FUNC)
                    /*
                     * Push some space


@@ -59,24 +67,45 @@ call(p, argv, porf, psbn)
                        putRV( 0 , cbn , temp , P2STRTY );
                }
            }
                        putRV( 0 , cbn , temp , P2STRTY );
                }
            }

-           {
-               char    extname[ BUFSIZ ];
-               char    *starthere;
-               int     funcbn;
-               int     i;
+           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 );
+                       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 );
+                   }
+                   break;
+               case FFUNC:
+               case FPROC:
+                           /*
+                            *  start one of these:
+                            *  FRTN( frtn , ( *FCALL( frtn ) )(...args...) )
+                            */
+                       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 ) );
+                       break;
+               default:
+                       panic("call class");

            }
            firsttime = TRUE;
 #      endif PC
            }
            firsttime = TRUE;
 #      endif PC


@@ -84,115 +113,224 @@ call(p, argv, porf, psbn)
         * Loop and process each of
         * arguments to the proc/func.
         */
         * Loop and process each of
         * arguments to the proc/func.
         */

-       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
-                        */
+       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
+                            */

 #                      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 );
+                                   /*
+                                    * 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)

                                    break;
                                    break;

-                                       /*
-                                        * and fall through
-                                        */
-                               default:
-                                   q = rvalue( argv[1] , p1 -> type , RREQ );
+                           if (incompat(q, p1->type, argv[1])) {
+                                   cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);

                                    break;
                            }
                                    break;
                            }

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

-                       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 );
+                           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;
+                           }
+                           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
 #          endif PC

-           argv = argv[2];
-       }
-       if (argv != NIL) {
-               error("Too many arguments to %s", p->symbol);
-               rvlist(argv);
-               return (NIL);
+               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
+                       /*
+                        * structure arguments require lvalues,
+                        * scalars use rvalue.
+                        */
+                   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 ) );
+                   }
+                       /*
+                        *      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
+           }
+       } else {
+           panic("call class");

        }
 #      ifdef OBJ
        }
 #      ifdef OBJ

-           put2(O_CALL | psbn << 8+INDX, p->entloc);
-           put2(O_POP, p->value[NL_OFFS]-DPOFF2);
+           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)));
+           } else {
+               put2(O_CALL | psbn << 8+INDX, p->entloc);
+           }

 #      endif OBJ
 #      ifdef PC
            if ( porf == FUNC ) {
 #      endif OBJ
 #      ifdef PC
            if ( porf == FUNC ) {


@@ -204,14 +342,18 @@ call(p, argv, porf, psbn)
                    case TSCAL:
                    case TDOUBLE:
                    case TPTR:
                    case TSCAL:
                    case TDOUBLE:
                    case TPTR:

-                       if ( p -> chain == NIL ) {
+                       if ( firsttime ) {

                                putop( P2UNARY P2CALL , rettype );
                        } else {
                                putop( P2CALL , rettype );
                        }
                                putop( P2UNARY P2CALL , rettype );
                        } else {
                                putop( P2CALL , rettype );
                        }

+                       if (p -> class == FFUNC || p -> class == FPROC ) {
+                           putop( P2LISTOP , P2INT );
+                           putop( P2CALL , rettype );
+                       }

                        break;
                    default:
                        break;
                    default:

-                       if ( p -> chain == NIL ) {
+                       if ( firsttime ) {

                                putstrop( P2UNARY P2STCALL
                                        , ADDTYPE( rettype , P2PTR )
                                        , lwidth( p -> type )
                                putstrop( P2UNARY P2STCALL
                                        , ADDTYPE( rettype , P2PTR )
                                        , lwidth( p -> type )


@@ -222,6 +364,10 @@ call(p, argv, porf, psbn)
                                        , lwidth( p -> type )
                                        , align( p -> type ) );
                        }
                                        , 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 )
                                , align( p -> type ) );
                        putLV( 0 , cbn , temp , rettype );
                        putstrop( P2STASG , rettype , lwidth( p -> type )
                                , align( p -> type ) );
                        putLV( 0 , cbn , temp , rettype );


@@ -229,11 +375,15 @@ call(p, argv, porf, psbn)
                        break;
                }
            } else {
                        break;
                }
            } else {

-               if ( p -> chain == NIL ) {
+               if ( firsttime ) {

                        putop( P2UNARY P2CALL , P2INT );
                } else {
                        putop( P2CALL , P2INT );
                }
                        putop( P2UNARY P2CALL , P2INT );
                } else {
                        putop( P2CALL , P2INT );
                }

+               if (p -> class == FFUNC || p -> class == FPROC ) {
+                   putop( P2LISTOP , P2INT );
+                   putop( P2CALL , P2INT );
+               }

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