From: Peter B. Kessler Date: Fri, 3 Oct 1980 17:10:10 +0000 (-0800) Subject: Implement formal functions and procedures X-Git-Tag: BSD-4^3~512 X-Git-Url: https://git.subgeniuskitty.com/unix-history/.git/commitdiff_plain/c4e911b65db8d7bedb133fdd231b15c1915fcc60?hp=1b2f7152b4e8ef16b7ce4cb9d61e53439fbb09c1 Implement formal functions and procedures SCCS-vsn: usr.bin/pascal/src/0.h 1.3 SCCS-vsn: usr.bin/pascal/src/OPnames.h 1.2 SCCS-vsn: usr.bin/pascal/src/call.c 1.3 SCCS-vsn: usr.bin/pascal/src/fdec.c 1.4 SCCS-vsn: usr.bin/pascal/src/func.c 1.2 SCCS-vsn: usr.bin/pascal/src/nl.c 1.2 SCCS-vsn: usr.bin/pascal/src/p2put.c 1.2 SCCS-vsn: usr.bin/pascal/src/pcfunc.c 1.2 SCCS-vsn: usr.bin/pascal/src/pcproc.c 1.2 SCCS-vsn: usr.bin/pascal/src/proc.c 1.2 SCCS-vsn: usr.bin/pascal/src/put.c 1.3 SCCS-vsn: usr.bin/pascal/src/rval.c 1.2 SCCS-vsn: usr.bin/pascal/src/stkrval.c 1.3 SCCS-vsn: usr.bin/pascal/src/yyid.c 1.2 SCCS-vsn: usr.bin/pascal/pc0/Makefile 1.9 SCCS-vsn: usr.bin/pascal/src/pimakefile 1.9 SCCS-vsn: usr.bin/pascal/src/flvalue.c 1.2 --- diff --git a/usr/src/usr.bin/pascal/pc0/Makefile b/usr/src/usr.bin/pascal/pc0/Makefile index 7431107f3c..56ea01d8c9 100644 --- a/usr/src/usr.bin/pascal/pc0/Makefile +++ b/usr/src/usr.bin/pascal/pc0/Makefile @@ -1,22 +1,23 @@ -SCCSID = "@(#)Makefile 1.8 %G%" +SCCSID = "@(#)Makefile 1.9 %G%" MKSTR = /usr/ucb/mkstr EYACC = /usr/ucb/eyacc RM = -rm -f -GET = sccs get +GET = sccs -d${SRCDIR} get CFLAGS = -O -w LDFLAGS = -z -INSTALLDIR = /usr/lib +SRCDIR = /usr/src/cmd/pc0 +INSTALLDIR = /usr/ucb LIBDIR = /usr/lib TMPDIR = tmp -ERRORSTRINGS = pc2.0strings +ERRORSTRINGS = pi2.0strings SRCS = ato.c \ call.c case.c clas.c const.c conv.c cset.c \ - error.c fdec.c func.c gen.c hash.c \ + error.c fdec.c flvalue.c func.c gen.c hash.c \ lab.c lookup.c lval.c stklval.c \ main.c nl.c proc.c put.c \ rec.c rval.c stkrval.c\ @@ -25,17 +26,16 @@ SRCS = ato.c \ TRdata.c \ treen.c putn.c yycopy.c \ yycosts.c yyerror.c yyget.c yyid.c yylex.c yymain.c yyoptions.c \ - yypanic.c yyparse.c yyprint.c yyput.c yyrecover.c yyseman.c yytree.c \ - p2put.c pcforop.c stab.c pcproc.c pcfunc.c pccaseop.c pclval.c + yypanic.c yyparse.c yyprint.c yyput.c yyrecover.c yyseman.c yytree.c -HDRS = 0.h OPnames.h align.h iorec.h objfmt.h pstab.h pc.h pcops.h \ - send.h tree.h whoami.h yy.h +HDRS = 0.h OPnames.h align.h iorec.h objfmt.h send.h tree.h yy.h \ + pc.h pcops.h OTHERS = pas.y opc.c version.c gram pic.c OBJS = ato.o \ call.o case.o clas.o const.o conv.o cset.o \ - error.o fdec.o func.o gen.o hash.o \ + error.o fdec.o flvalue.o func.o gen.o hash.o \ lab.o lookup.o lval.o stklval.o \ main.o nl.o proc.o put.o \ rec.o rval.o stkrval.o\ @@ -45,14 +45,13 @@ OBJS = ato.o \ treen.o putn.o yycopy.o \ y.tab.o \ yycosts.o yyerror.o yyget.o yyid.o yylex.o yymain.o yyoptions.o \ - yypanic.o yyparse.o yyprint.o yyput.o yyrecover.o yyseman.o yytree.o \ - p2put.o pcforop.o stab.o pcproc.o pcfunc.o pccaseop.o pclval.o + yypanic.o yyparse.o yyprint.o yyput.o yyrecover.o yyseman.o yytree.o a.out: ${OBJS} version ./version > Version.c ${CC} ${CFLAGS} ${LDFLAGS} ${OBJS} Version.c -sources: ${SRCS} ${HDRS} ${OTHERS} +sources: whoami.h ${SRCS} ${HDRS} ${OTHERS} ${SRCS} ${HDRS} ${OTHERS}: ${GET} ${REL} $@ @@ -63,6 +62,10 @@ ${SRCS} ${HDRS} ${OTHERS}: cd ${TMPDIR} ; ${CC} ${CFLAGS} -I.. -c $*.c ; mv $*.o ../$*.o ${RM} ${TMPDIR}/$*.c +whoami.h: + ${GET} ${REL} piwhoami.h + mv piwhoami.h whoami.h + y.tab.h: pas.y gram ${EYACC} pas.y > /dev/null ex - y.tab.c class == FFUNC || p->class == FPROC) + put(2, PTR_RV | cbn << 8+INDX, p->value[NL_OFFS]); if (porf == FUNC) /* * Push some space @@ -59,24 +67,45 @@ call(p, argv, porf, psbn) 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 @@ -84,116 +113,224 @@ call(p, argv, porf, psbn) * 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 - q = rvalue(argv[1], p1->type , RREQ ); + q = rvalue(argv[1], p1->type , RREQ ); # 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; - default: - q = rvalue( argv[1] , p1 -> type , RREQ ); - if ( isa( p1 -> type , "d" ) - && isa( q , "i" ) ) { - putop( P2SCONV , P2DOUBLE ); - } + if (incompat(q, p1->type, argv[1])) { + cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol); 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 - 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 - 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 - 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 - 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 - 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 ) { @@ -205,14 +342,18 @@ call(p, argv, porf, psbn) case TSCAL: case TDOUBLE: case TPTR: - if ( p -> chain == NIL ) { + if ( firsttime ) { putop( P2UNARY P2CALL , rettype ); } else { putop( P2CALL , rettype ); } + if (p -> class == FFUNC || p -> class == FPROC ) { + putop( P2LISTOP , P2INT ); + putop( P2CALL , rettype ); + } break; default: - if ( p -> chain == NIL ) { + if ( firsttime ) { putstrop( P2UNARY P2STCALL , ADDTYPE( rettype , P2PTR ) , lwidth( p -> type ) @@ -223,6 +364,10 @@ call(p, argv, porf, psbn) , 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 ); @@ -230,11 +375,15 @@ call(p, argv, porf, psbn) break; } } else { - if ( p -> chain == NIL ) { + if ( firsttime ) { 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 diff --git a/usr/src/usr.bin/pascal/src/fdec.c b/usr/src/usr.bin/pascal/src/fdec.c index d9579e30c4..3ba3a1cd11 100644 --- a/usr/src/usr.bin/pascal/src/fdec.c +++ b/usr/src/usr.bin/pascal/src/fdec.c @@ -1,6 +1,6 @@ /* Copyright (c) 1979 Regents of the University of California */ -static char sccsid[] = "@(#)fdec.c 1.3 %G%"; +static char sccsid[] = "@(#)fdec.c 1.4 %G%"; #include "whoami.h" #include "0.h" @@ -138,10 +138,10 @@ funchdr(r) case TREC: case TSET: case TSTR: - warning(); - if (opt('s')) + if (opt('s')) { standard(); - error("Functions should not return %ss", clnames[o]); + error("Functions should not return %ss", clnames[o]); + } } # ifdef PC enclosing[ cbn ] = r[2]; @@ -256,9 +256,27 @@ funchdr(r) # endif PC break; case T_PFUNC: +# ifdef OBJ + dp = defnl(il[1], FFUNC, p, o -= sizeof ( int * ) ); +# endif OBJ +# ifdef PC + dp = defnl( il[1] , FFUNC , p + , o = roundup( o , A_STACK ) ); + o += sizeof(char *); +# endif PC + dp -> nl_flags |= NMOD; + break; case T_PPROC: - error("Procedure/function parameters not implemented"); - continue; +# ifdef OBJ + dp = defnl(il[1], FPROC, p, o -= sizeof ( int * ) ); +# endif OBJ +# ifdef PC + dp = defnl( il[1] , FPROC , p + , o = roundup( o , A_STACK ) ); + o += sizeof(char *); +# endif PC + dp -> nl_flags |= NMOD; + break; } if (dp != NIL) { cp->chain = dp; @@ -506,6 +524,11 @@ funcend(fp, bundle, endline) */ var = put(2, (lenstr(fp->symbol,0) << 8) | (cbn == 1 && opt('p') == 0 ? O_NODUMP: O_BEG), 0); + /* + * output the number of bytes of arguments + * this is only checked on formal calls. + */ + put(2, O_CASE4, cbn == 1 ? 0 : fp->value[NL_OFFS]-DPOFF2); put(2, O_CASE2, bundle[1]); putstr(fp->symbol, 0); #endif OBJ @@ -597,15 +620,30 @@ funcend(fp, bundle, endline) * and zero them if checking is on * by calling zframe( bytes of locals , highest local address ); */ - if ( opt( 't' ) && ( -sizes[ cbn ].om_max ) > DPOFF1 ) { - putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) - , "_ZFRAME" ); - putleaf( P2ICON , ( -sizes[ cbn ].om_max ) - DPOFF1 - , 0 , P2INT , 0 ); - putLV( 0 , cbn , sizes[ cbn ].om_max , P2CHAR ); - putop( P2LISTOP , P2INT ); - putop( P2CALL , P2INT ); - putdot( filename , line ); + if ( opt( 't' ) ) { + if ( ( -sizes[ cbn ].om_max ) > DPOFF1 ) { + putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) + , "_ZFRAME" ); + putleaf( P2ICON , ( -sizes[ cbn ].om_max ) - DPOFF1 + , 0 , P2INT , 0 ); + putLV( 0 , cbn , sizes[ cbn ].om_max , P2CHAR ); + putop( P2LISTOP , P2INT ); + putop( P2CALL , P2INT ); + putdot( filename , line ); + } + /* + * check number of longs of arguments + * this can only be wrong for formal calls. + */ + if ( fp -> class != PROG ) { + putleaf( P2ICON , 0 , 0 , ADDTYPE( P2PTR , P2FTN | P2INT ) , + "_NARGCHK" ); + putleaf( P2ICON , + (fp->value[NL_OFFS] - DPOFF2) / sizeof(long) , + 0 , P2INT , 0 ); + putop( P2CALL , P2INT ); + putdot( filename , line ); + } } #endif PC if ( monflg ) { @@ -857,6 +895,8 @@ funcend(fp, bundle, endline) if ( fp -> class == FUNC ) { struct nl *fvar = fp -> ptr[ NL_FVAR ]; long fvartype = p2type( fvar -> type ); + long label; + char labelname[ BUFSIZ ]; switch ( classify( fvar -> type ) ) { case TBOOL: @@ -869,8 +909,19 @@ funcend(fp, bundle, endline) , fvar -> value[ NL_OFFS ] , fvartype ); break; default: + label = getlab(); + sprintf( labelname , PREFIXFORMAT , + LABELPREFIX , label ); + putprintf( " .data" , 0 ); + putprintf( " .lcomm %s,%d" , 0 , + labelname , lwidth( fvar -> type ) ); + putprintf( " .text" , 0 ); + putRV( labelname , 0 , 0 , fvartype ); putLV( fvar -> symbol , ( fvar -> nl_block ) & 037 , fvar -> value[ NL_OFFS ] , fvartype ); + putstrop( P2STASG , fvartype , lwidth( fvar -> type ) , + align( fvar -> type ) ); + putLV( labelname , 0 , 0 , fvartype ); break; } putop( P2FORCE , fvartype ); diff --git a/usr/src/usr.bin/pascal/src/flvalue.c b/usr/src/usr.bin/pascal/src/flvalue.c index a2fcd746fa..2b1e49ad99 100644 --- a/usr/src/usr.bin/pascal/src/flvalue.c +++ b/usr/src/usr.bin/pascal/src/flvalue.c @@ -1,6 +1,6 @@ /* Copyright (c) 1980 Regents of the University of California */ -static char sccsid[] = "@(#)flvalue.c 1.1 %G%"; +static char sccsid[] = "@(#)flvalue.c 1.2 %G%"; #include "whoami.h" #include "0.h" @@ -11,6 +11,15 @@ static char sccsid[] = "@(#)flvalue.c 1.1 %G%"; # include "pc.h" # include "pcops.h" #endif PC +#ifdef OBJ +/* + * define the display structure for purposes of allocating + * a temporary + */ +struct dispsave { + char *ptr; +}; +#endif OBJ /* * flvalue generates the code to either pass on a formal routine, @@ -18,34 +27,35 @@ static char sccsid[] = "@(#)flvalue.c 1.1 %G%"; * it tells the difference by looking at the tree it's given. */ struct nl * -flvalue( r ) - int *r; +flvalue( r , formalp ) + int *r; + struct nl *formalp; { struct nl *p; long tempoff; + char *typename; if ( r == NIL ) { return NIL; } + typename = formalp -> class == FFUNC ? "function":"procedure"; + if ( r[0] != T_VAR ) { + error("Expression given, %s required for %s parameter %s" , + typename , typename , formalp -> symbol ); + return NIL; + } p = lookup(r[2]); if (p == NIL) { - return NIL; + return NIL; } - switch ( r[0] ) { - case T_FFUNC: - if ( r[3] != NIL ) { - error("Formal function %s cannot be qualified" , - p -> symbol ); - return NIL; - } - goto froutine; - case T_FPROC: + switch ( p -> class ) { + case FFUNC: + case FPROC: if ( r[3] != NIL ) { - error("Formal procedure %s cannot be qualified" , - p -> symbol ); + error("Formal %s %s cannot be qualified" , + typename , p -> symbol ); return NIL; } - froutine: # ifdef OBJ put( 2 , PTR_RV | bn << 8+INDX , p -> value[NL_OFFS] ); # endif OBJ @@ -54,18 +64,18 @@ flvalue( r ) p2type( p ) ); # endif PC return p -> type; - case T_FUNC: + case FUNC: + case PROC: if ( r[3] != NIL ) { - error("Function %s cannot be qualified" , p -> symbol ); + error("%s %s cannot be qualified" , typename , + p -> symbol ); return NIL; } - goto routine; - case T_PROC: - if ( r[3] != NIL ) { - error("Procedure %s cannot be qualified", p -> symbol ); + if (bn == 0) { + error("Built-in %s %s cannot be passed as a parameter" , + typename , p -> symbol ); return NIL; } - routine: /* * formal routine structure: * @@ -75,7 +85,7 @@ flvalue( r ) * struct dispsave disp[2*MAXLVL]; * }; */ - sizes[ cbn ].om_off -= sizeof (long (*())) + sizes[ cbn ].om_off -= sizeof (long (*)()) + sizeof (long) + 2*bn*sizeof (struct dispsave); tempoff = sizes[ cbn ].om_off; @@ -83,13 +93,13 @@ flvalue( r ) sizes[ cbn ].om_max = tempoff; } # ifdef OBJ - put( 2 , PTR_LV | cbn << 8 + INDX , tempoff ); + put( 2 , O_LV | cbn << 8 + INDX , tempoff ); put( 2 , O_FSAV | bn << 8 + INDX , p -> entloc ); # endif OBJ # ifdef PC putlbracket( ftnno , -tempoff ); putleaf( P2ICON , 0 , 0 , - ADDTYPE( P2PTR , ADDTYPE( P2FTN , P2PTR|P2STR ) ) , + ADDTYPE( P2PTR , ADDTYPE( P2FTN , P2PTR|P2STRTY ) ) , "_FSAV" ); { char extname[ BUFSIZ ]; @@ -110,12 +120,14 @@ flvalue( r ) } putleaf( P2ICON , bn , 0 , P2INT , 0 ); putop( P2LISTOP , P2INT ); - putLV( 0 , cbn , tempoff , P2STR ); + putLV( 0 , cbn , tempoff , P2STRTY ); putop( P2LISTOP , P2INT ); putop( P2CALL , P2PTR | P2STRTY ); # endif PC return p -> type; default: - panic("flvalue"); + error("Variable given, %s required for %s parameter %s" , + typename , typename , formalp -> symbol ); + return NIL; } } diff --git a/usr/src/usr.bin/pascal/src/func.c b/usr/src/usr.bin/pascal/src/func.c index 13db1a04a6..4366e5635d 100644 --- a/usr/src/usr.bin/pascal/src/func.c +++ b/usr/src/usr.bin/pascal/src/func.c @@ -1,6 +1,6 @@ /* Copyright (c) 1979 Regents of the University of California */ -static char sccsid[] = "@(#)func.c 1.1 %G%"; +static char sccsid[] = "@(#)func.c 1.2 %G%"; #include "whoami.h" #ifdef OBJ @@ -39,7 +39,7 @@ funccod(r) rvlist(r[3]); return (NIL); } - if (p->class != FUNC) { + if (p->class != FUNC && p->class != FFUNC) { error("%s is not a function", p->symbol); rvlist(r[3]); return (NIL); diff --git a/usr/src/usr.bin/pascal/src/nl.c b/usr/src/usr.bin/pascal/src/nl.c index bbe5a6bab4..380a92c9d4 100644 --- a/usr/src/usr.bin/pascal/src/nl.c +++ b/usr/src/usr.bin/pascal/src/nl.c @@ -1,6 +1,6 @@ /* Copyright (c) 1979 Regents of the University of California */ -static char sccsid[] = "@(#)nl.c 1.1 %G%"; +static char sccsid[] = "@(#)nl.c 1.2 %G%"; #include "whoami.h" #include "0.h" @@ -439,10 +439,10 @@ char *classes[ ] = { "scalar", "string", "program", - "improper" -#ifdef DEBUG - ,"variant" -#endif + "improper", + "variant", + "formal procedure", + "formal function" }; char *snark = "SNARK"; @@ -473,7 +473,9 @@ char *ctext[] = "STR", "PROG", "IMPROPER", - "VARNT" + "VARNT", + "FPROC", + "FFUNC" }; char *stars = "\t***"; @@ -564,6 +566,8 @@ con: case VAR: case REF: case WITHPTR: + case FFUNC: + case FPROC: printf("\t%d,%d", cbn, v); break; case SCAL: diff --git a/usr/src/usr.bin/pascal/src/p2put.c b/usr/src/usr.bin/pascal/src/p2put.c index 5eca62b251..bff16f4aac 100644 --- a/usr/src/usr.bin/pascal/src/p2put.c +++ b/usr/src/usr.bin/pascal/src/p2put.c @@ -1,6 +1,6 @@ /* Copyright (c) 1979 Regents of the University of California */ -static char sccsid[] = "@(#)p2put.c 1.1 %G%"; +static char sccsid[] = "@(#)p2put.c 1.2 %G%"; /* * functions to help pi put out @@ -452,6 +452,13 @@ p2type( np ) * which return integers (whether you look at them or not) */ return ADDTYPE( ADDTYPE( P2INT , P2FTN ) , P2PTR ); + case FFUNC : + case FPROC : + /* + * formal procedures and functions are pointers + * to structures which describe their environment. + */ + return ADDTYPE( P2PTR , P2STRTY ); default : fprintf( stderr , "[p2type] np -> class %d\n" , np -> class ); panic( "p2type" ); diff --git a/usr/src/usr.bin/pascal/src/pcfunc.c b/usr/src/usr.bin/pascal/src/pcfunc.c index c6423a9259..3f587326c7 100644 --- a/usr/src/usr.bin/pascal/src/pcfunc.c +++ b/usr/src/usr.bin/pascal/src/pcfunc.c @@ -1,6 +1,6 @@ /* Copyright (c) 1979 Regents of the University of California */ -static char sccsid[] = "@(#)pcfunc.c 1.1 %G%"; +static char sccsid[] = "@(#)pcfunc.c 1.2 %G%"; #include "whoami.h" #ifdef PC @@ -45,7 +45,7 @@ pcfunccod( r ) rvlist(r[3]); return (NIL); } - if (p->class != FUNC) { + if (p->class != FUNC && p->class != FFUNC) { error("%s is not a function", p->symbol); rvlist(r[3]); return (NIL); diff --git a/usr/src/usr.bin/pascal/src/pcproc.c b/usr/src/usr.bin/pascal/src/pcproc.c index b8d6c12772..43030198c6 100644 --- a/usr/src/usr.bin/pascal/src/pcproc.c +++ b/usr/src/usr.bin/pascal/src/pcproc.c @@ -1,6 +1,6 @@ /* Copyright (c) 1979 Regents of the University of California */ -static char sccsid[] = "@(#)pcproc.c 1.1 %G%"; +static char sccsid[] = "@(#)pcproc.c 1.2 %G%"; #include "whoami.h" #ifdef PC @@ -72,7 +72,7 @@ pcproc(r) rvlist(r[3]); return; } - if (p->class != PROC) { + if (p->class != PROC && p->class != FPROC) { error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]); rvlist(r[3]); return; diff --git a/usr/src/usr.bin/pascal/src/pimakefile b/usr/src/usr.bin/pascal/src/pimakefile index 9ce870d611..24ce638869 100644 --- a/usr/src/usr.bin/pascal/src/pimakefile +++ b/usr/src/usr.bin/pascal/src/pimakefile @@ -1,22 +1,23 @@ -SCCSID = "@(#)pimakefile 1.8 %G%" +SCCSID = "@(#)pimakefile 1.9 %G%" MKSTR = /usr/ucb/mkstr EYACC = /usr/ucb/eyacc RM = -rm -f -GET = sccs get +GET = sccs -d${SRCDIR} get CFLAGS = -O -w LDFLAGS = -z -INSTALLDIR = /usr/lib +SRCDIR = /usr/src/cmd/pc0 +INSTALLDIR = /usr/ucb LIBDIR = /usr/lib TMPDIR = tmp -ERRORSTRINGS = pc2.0strings +ERRORSTRINGS = pi2.0strings SRCS = ato.c \ call.c case.c clas.c const.c conv.c cset.c \ - error.c fdec.c func.c gen.c hash.c \ + error.c fdec.c flvalue.c func.c gen.c hash.c \ lab.c lookup.c lval.c stklval.c \ main.c nl.c proc.c put.c \ rec.c rval.c stkrval.c\ @@ -25,17 +26,16 @@ SRCS = ato.c \ TRdata.c \ treen.c putn.c yycopy.c \ yycosts.c yyerror.c yyget.c yyid.c yylex.c yymain.c yyoptions.c \ - yypanic.c yyparse.c yyprint.c yyput.c yyrecover.c yyseman.c yytree.c \ - p2put.c pcforop.c stab.c pcproc.c pcfunc.c pccaseop.c pclval.c + yypanic.c yyparse.c yyprint.c yyput.c yyrecover.c yyseman.c yytree.c -HDRS = 0.h OPnames.h align.h iorec.h objfmt.h pstab.h pc.h pcops.h \ - send.h tree.h whoami.h yy.h +HDRS = 0.h OPnames.h align.h iorec.h objfmt.h send.h tree.h yy.h \ + pc.h pcops.h OTHERS = pas.y opc.c version.c gram pic.c OBJS = ato.o \ call.o case.o clas.o const.o conv.o cset.o \ - error.o fdec.o func.o gen.o hash.o \ + error.o fdec.o flvalue.o func.o gen.o hash.o \ lab.o lookup.o lval.o stklval.o \ main.o nl.o proc.o put.o \ rec.o rval.o stkrval.o\ @@ -45,14 +45,13 @@ OBJS = ato.o \ treen.o putn.o yycopy.o \ y.tab.o \ yycosts.o yyerror.o yyget.o yyid.o yylex.o yymain.o yyoptions.o \ - yypanic.o yyparse.o yyprint.o yyput.o yyrecover.o yyseman.o yytree.o \ - p2put.o pcforop.o stab.o pcproc.o pcfunc.o pccaseop.o pclval.o + yypanic.o yyparse.o yyprint.o yyput.o yyrecover.o yyseman.o yytree.o a.out: ${OBJS} version ./version > Version.c ${CC} ${CFLAGS} ${LDFLAGS} ${OBJS} Version.c -sources: ${SRCS} ${HDRS} ${OTHERS} +sources: whoami.h ${SRCS} ${HDRS} ${OTHERS} ${SRCS} ${HDRS} ${OTHERS}: ${GET} ${REL} $@ @@ -63,6 +62,10 @@ ${SRCS} ${HDRS} ${OTHERS}: cd ${TMPDIR} ; ${CC} ${CFLAGS} -I.. -c $*.c ; mv $*.o ../$*.o ${RM} ${TMPDIR}/$*.c +whoami.h: + ${GET} ${REL} piwhoami.h + mv piwhoami.h whoami.h + y.tab.h: pas.y gram ${EYACC} pas.y > /dev/null ex - y.tab.c class != PROC) { + if (p->class != PROC && p->class != FPROC) { error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]); rvlist(r[3]); return; diff --git a/usr/src/usr.bin/pascal/src/put.c b/usr/src/usr.bin/pascal/src/put.c index 6075c76d55..f8d39fb323 100644 --- a/usr/src/usr.bin/pascal/src/put.c +++ b/usr/src/usr.bin/pascal/src/put.c @@ -1,6 +1,6 @@ /* Copyright (c) 1979 Regents of the University of California */ -static char sccsid[] = "@(#)put.c 1.2 %G%"; +static char sccsid[] = "@(#)put.c 1.3 %G%"; #include "whoami.h" #include "opcode.h" @@ -86,6 +86,7 @@ put(a) case O_CASE1OP: case O_CASE2OP: case O_CASE4OP: + case O_FRTN: case O_WRITES: case O_WRITEF: case O_MAX: @@ -241,7 +242,10 @@ around: #endif word( ( short ) *( ( long * ) &p[1] ) ); return (oldlc); - case O_POP: + case O_FCALL: + if (p[1] == 0) + goto longgen; + /* and fall through */ case O_PUSH: if (p[1] == 0) return (oldlc); @@ -254,8 +258,8 @@ around: goto longgen; case O_TRA4: case O_CALL: + case O_FSAV: case O_GOTO: - case O_TRACNT: case O_NAM: case O_READE: /* absolute long addressing */ diff --git a/usr/src/usr.bin/pascal/src/rval.c b/usr/src/usr.bin/pascal/src/rval.c index 8c46f6c80d..9f481ff3cd 100644 --- a/usr/src/usr.bin/pascal/src/rval.c +++ b/usr/src/usr.bin/pascal/src/rval.c @@ -1,6 +1,6 @@ /* Copyright (c) 1979 Regents of the University of California */ -static char sccsid[] = "@(#)rval.c 1.1 %G%"; +static char sccsid[] = "@(#)rval.c 1.2 %G%"; #include "whoami.h" #include "0.h" @@ -304,6 +304,7 @@ cstrng: return (q); case FUNC: + case FFUNC: /* * Function call with no arguments. */ @@ -323,6 +324,7 @@ cstrng: return (NIL); case PROC: + case FPROC: error("Procedure %s found where expression required", p->symbol); return (NIL); default: diff --git a/usr/src/usr.bin/pascal/src/stkrval.c b/usr/src/usr.bin/pascal/src/stkrval.c index 5617bf9dca..f6dc44d5cf 100644 --- a/usr/src/usr.bin/pascal/src/stkrval.c +++ b/usr/src/usr.bin/pascal/src/stkrval.c @@ -1,6 +1,6 @@ /* Copyright (c) 1979 Regents of the University of California */ -static char sccsid[] = "@(#)stkrval.c 1.2 %G%"; +static char sccsid[] = "@(#)stkrval.c 1.3 %G%"; #include "whoami.h" #include "0.h" @@ -232,6 +232,7 @@ cstrng: # endif PC case FUNC: + case FFUNC: /* * Function call */ @@ -271,6 +272,7 @@ cstrng: return (NIL); case PROC: + case FPROC: error("Procedure %s found where expression required", p->symbol); return (NIL); default: diff --git a/usr/src/usr.bin/pascal/src/yyid.c b/usr/src/usr.bin/pascal/src/yyid.c index 3a13ac7b59..efed35d809 100644 --- a/usr/src/usr.bin/pascal/src/yyid.c +++ b/usr/src/usr.bin/pascal/src/yyid.c @@ -1,6 +1,6 @@ /* Copyright (c) 1979 Regents of the University of California */ -static char sccsid[] = "@(#)yyid.c 1.1 %G%"; +static char sccsid[] = "@(#)yyid.c 1.2 %G%"; #include "whoami.h" #include "0.h" @@ -106,7 +106,9 @@ yybadref(p, line) p->chain = udp; } -#define varkinds ((1<class == FVAR) - return(1); + return ( p -> class == FUNC + || p -> class == FVAR + || p -> class == FFUNC ); + case PROC: + return ( p -> class == PROC || p -> class == FPROC ); case CONST: case TYPE: - case PROC: case FIELD: return (p->class == kind); case VAR: @@ -171,7 +175,11 @@ yyisvar(p, class) * parameterless functions only. */ case FUNC: + case FFUNC: return (class == NIL || (p->type != NIL && p->type->class == class)); + case PROC: + case FPROC: + return ( class == NIL ); } return (0); }