/* Copyright (c) 1979 Regents of the University of California */
static char sccsid
[] = "@(#)pcfunc.c 1.3 %G%";
* and to the end of the file
* Funccod generates code for
* built in function calls and calls
* call to generate calls to user
* defined functions and procedures.
* Verify that the given name
* is defined and the name of
if (p
->class != FUNC
&& p
->class != FFUNC
) {
error("%s is not a function", p
->symbol
);
* Call handles user defined
* procedures and functions
return (call(p
, argv
, FUNC
, bn
));
for (al
= argv
; al
!= NIL
; al
= al
[2])
* Built-in functions have
* their interpreter opcode
op
= p
->value
[0] &~ NSTAND
;
if (opt('s') && (p
->value
[0] & NSTAND
)) {
error("%s is a nonstandard function", p
->symbol
);
putleaf( P2NAME
, 0 , 0 , P2INT
, "__argc" );
* Parameterless functions
error("%s takes no arguments", p
->symbol
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putop( P2UNARY P2CALL
, P2INT
);
error("%s takes no arguments", p
->symbol
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putleaf( P2ICON
, 0 , 0 , P2INT
, 0 );
error("%s takes either zero or one argument", p
->symbol
);
* All other functions take
error("%s takes exactly one argument", p
->symbol
);
* find out the type of the argument
p1
= stkrval((int *) argv
[1], NLNIL
, RREQ
);
* figure out the return type and the funtion name
funcname
= opt('t') ? "_LN" : "_log";
funcname
= opt('t') ? "_SQRT" : "_sqrt";
error("%s's argument must be integer or real, not %s", p
->symbol
, nameof(p1
));
, ADDTYPE( P2FTN
| P2DOUBLE
, P2PTR
) , funcname
);
p1
= stkrval( (int *) argv
[1] , NLNIL
, RREQ
);
putop( P2SCONV
, P2DOUBLE
);
putop( P2CALL
, P2DOUBLE
);
if (isnta( p1
, "id" ) ) {
error("%s's argument must be integer or real, not %s", p
->symbol
, nameof(p1
));
, ADDTYPE( P2FTN
| P2INT
, P2PTR
) , "_EXPO" );
p1
= stkrval( (int *) argv
[1] , NLNIL
, RREQ
);
putop( P2SCONV
, P2DOUBLE
);
if ( isnta( p1
, "id" ) ) {
error("%s's argument must be integer or real, not %s", p
->symbol
, nameof(p1
));
p1
= stkrval( (int *) argv
[1] , NLNIL
, RREQ
);
putleaf( P2ICON
, 0 , 0 , P2INT
, 0 );
putop( P2COMOP
, P2INT
);
error("seed's argument must be an integer, not %s", nameof(p1
));
, ADDTYPE( P2FTN
| P2INT
, P2PTR
) , "_SEED" );
p1
= stkrval( (int *) argv
[1] , NLNIL
, RREQ
);
if ( isnta( p1
, "d" ) ) {
error("%s's argument must be a real, not %s", p
->symbol
, nameof(p1
));
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
, op
== O_ROUND
? "_ROUND" : "_TRUNC" );
p1
= stkrval( (int *) argv
[1] , NLNIL
, RREQ
);
, ADDTYPE( P2FTN
| P2DOUBLE
, P2PTR
)
p1
= stkrval( (int *) argv
[1] , NLNIL
, RREQ
);
putop( P2CALL
, P2DOUBLE
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
) , "_abs" );
p1
= stkrval( (int *) argv
[1] , NLNIL
, RREQ
);
error("%s's argument must be an integer or real, not %s", p
->symbol
, nameof(p1
));
sizes
[ cbn
].om_off
-= sizeof( double );
} else if ( isa( p1
, "i" ) ) {
sizes
[ cbn
].om_off
-= sizeof( long );
error("%s's argument must be an integer or real, not %s", p
->symbol
, nameof(p1
));
tempoff
= sizes
[ cbn
].om_off
;
if ( tempoff
< sizes
[ cbn
].om_max
) {
sizes
[ cbn
].om_max
= tempoff
;
putlbracket( ftnno
, -tempoff
);
putRV( 0 , cbn
, tempoff
, temptype
, 0 );
p1
= rvalue( (int *) argv
[1] , NLNIL
, RREQ
);
putop( P2ASSIGN
, temptype
);
putRV( 0 , cbn
, tempoff
, temptype
, 0 );
putRV( 0 , cbn
, tempoff
, temptype
, 0 );
putop( P2MUL
, temptype
);
putop( P2COMOP
, temptype
);
p1
= stkrval( (int *) argv
[1] , NLNIL
, RREQ
);
if (isa(p1
, "bcis") || classify(p1
) == TPTR
) {
error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1
));
error("%s is forbidden for reals", p
->symbol
);
if ( isnta( p1
, "bcsi" ) ) {
error("%s's argument must be of scalar type, not %s", p
->symbol
, nameof(p1
));
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
, op
== O_SUCC2
? "_SUCC" : "_PRED" );
p1
= stkrval( (int *) argv
[1] , NLNIL
, RREQ
);
putleaf( P2ICON
, p1
-> range
[0] , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, p1
-> range
[1] , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
p1
= rvalue( argv
[1] , NIL
, RREQ
);
putleaf( P2ICON
, 1 , 0 , P2INT
, 0 );
putop( op
== O_SUCC2
? P2PLUS
: P2MINUS
, P2INT
);
if ( isa( p1
, "bcs" ) ) {
error("odd's argument must be an integer, not %s", nameof(p1
));
p1
= rvalue( (int *) argv
[1] , NLNIL
, RREQ
);
putleaf( P2ICON
, 1 , 0 , P2INT
, 0 );
error("chr's argument must be an integer, not %s", nameof(p1
));
, ADDTYPE( P2FTN
| P2CHAR
, P2PTR
) , "_CHR" );
p1
= stkrval( (int *) argv
[1] , NLNIL
, RREQ
);
putop( P2CALL
, P2CHAR
);
p1
= stkrval( (int *) argv
[1] , NLNIL
, RREQ
);
error("Argument to card must be a set, not %s", nameof(p1
));
, ADDTYPE( P2FTN
| P2INT
, P2PTR
) , "_CARD" );
p1
= stkrval( (int *) argv
[1] , NLNIL
, LREQ
);
putleaf( P2ICON
, lwidth( p1
) , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
error("Argument to eoln must be a text file, not %s", nameof(p1
));
, ADDTYPE( P2FTN
| P2INT
, P2PTR
) , "_TEOLN" );
p1
= stklval( (int *) argv
[1] , NOFLAGS
);
if (p1
->class != FILET
) {
error("Argument to eof must be file, not %s", nameof(p1
));
, ADDTYPE( P2FTN
| P2INT
, P2PTR
) , "_TEOF" );
p1
= stklval( (int *) argv
[1] , NOFLAGS
);
error("%s is an unimplemented 6000-3.4 extension", p
->symbol
);