* Copyright (c) 1980 The Regents of the University of California.
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
static char sccsid
[] = "@(#)pcfunc.c 5.2 (Berkeley) 4/16/91";
* 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.
struct tnode
*r
; /* T_FCALL */
register struct tnode
*al
;
* Verify that the given name
* is defined and the name of
p
= lookup(r
->pcall_node
.proc_id
);
rvlist(r
->pcall_node
.arg
);
if (p
->class != FUNC
&& p
->class != FFUNC
) {
error("%s is not a function", p
->symbol
);
rvlist(r
->pcall_node
.arg
);
argv
= r
->pcall_node
.arg
;
* Call handles user defined
* procedures and functions
return (call(p
, argv
, FUNC
, bn
));
for (al
= argv
; al
!= TR_NIL
; al
= al
->list_node
.next
)
* 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( PCC_NAME
, 0 , 0 , PCCT_INT
, "__argc" );
* Parameterless functions
error("%s takes no arguments", p
->symbol
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putop( PCCOM_UNARY PCC_CALL
, PCCT_INT
);
error("%s takes no arguments", p
->symbol
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putleaf( PCC_ICON
, 0 , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CALL
, PCCT_INT
);
tr
.list_node
.list
= &(tr2
);
tr2
.var_node
.cptr
= input
->symbol
;
tr2
.var_node
.line_no
= NIL
;
tr2
.var_node
.qual
= TR_NIL
;
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( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
* figure out the return type and the funtion name
error("%s is an unimplemented 6000-3.4 extension", p
->symbol
);
funcname
= opt('t') ? "_EXP" : "_exp";
funcname
= opt('t') ? "_SIN" : "_sin";
funcname
= opt('t') ? "_COS" : "_cos";
funcname
= opt('t') ? "_ATAN" : "_atan";
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
));
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_DOUBLE
, PCCTM_PTR
) , funcname
);
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
sconv(p2type(p1
), PCCT_DOUBLE
);
putop( PCC_CALL
, PCCT_DOUBLE
);
if (isnta( p1
, "id" ) ) {
error("%s's argument must be integer or real, not %s", p
->symbol
, nameof(p1
));
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
) , "_EXPO" );
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
sconv(p2type(p1
), PCCT_DOUBLE
);
putop( PCC_CALL
, PCCT_INT
);
if ( isnta( p1
, "id" ) ) {
error("%s's argument must be integer or real, not %s", p
->symbol
, nameof(p1
));
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
putleaf( PCC_ICON
, 0 , 0 , PCCT_CHAR
, (char *) 0 );
putop( PCC_COMOP
, PCCT_CHAR
);
error("seed's argument must be an integer, not %s", nameof(p1
));
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
) , "_SEED" );
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
putop( PCC_CALL
, PCCT_INT
);
if ( isnta( p1
, "d" ) ) {
error("%s's argument must be a real, not %s", p
->symbol
, nameof(p1
));
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
, op
== O_ROUND
? "_ROUND" : "_TRUNC" );
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
putop( PCC_CALL
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_DOUBLE
, PCCTM_PTR
)
p1
= stkrval( argv
->list_node
.list
, NLNIL
,(long) RREQ
);
putop( PCC_CALL
, PCCT_DOUBLE
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
) , "_abs" );
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
putop( PCC_CALL
, PCCT_INT
);
error("%s's argument must be an integer or real, not %s", p
->symbol
, nameof(p1
));
tempnlp
= tmpalloc((long) (sizeof(double)), rettype
, REGOK
);
} else if ( isa( p1
, "i" ) ) {
tempnlp
= tmpalloc((long) (sizeof(long)), rettype
, REGOK
);
error("%s's argument must be an integer or real, not %s", p
->symbol
, nameof(p1
));
putRV( (char *) 0 , cbn
, tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, (char) temptype
);
p1
= rvalue( argv
->list_node
.list
, NLNIL
, RREQ
);
sconv(p2type(p1
), (int) temptype
);
putop( PCC_ASSIGN
, (int) temptype
);
putRV((char *) 0 , cbn
, tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, (char) temptype
);
putRV((char *) 0 , cbn
, tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, (char) temptype
);
putop( PCC_MUL
, (int) temptype
);
putop( PCC_COMOP
, (int) temptype
);
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
if (classify(p1
) == TPTR
) {
error("ord's argument must be of scalar type, not %s",
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
));
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
, op
== O_SUCC2
? "_SUCC" : "_PRED" );
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
tempnlp
= p1
-> class == TYPE
? p1
-> type
: p1
;
putleaf( PCC_ICON
, (int) tempnlp
-> range
[0], 0, PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, (int) tempnlp
-> range
[1], 0, PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
sconv(PCCT_INT
, p2type(p1
));
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
putleaf( PCC_ICON
, 1 , 0 , PCCT_INT
, (char *) 0 );
putop( op
== O_SUCC2
? PCC_PLUS
: PCC_MINUS
, PCCT_INT
);
sconv(PCCT_INT
, p2type(p1
));
if ( isa( p1
, "bcs" ) ) {
error("odd's argument must be an integer, not %s", nameof(p1
));
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
* THIS IS MACHINE-DEPENDENT!!!
putleaf( PCC_ICON
, 1 , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_AND
, PCCT_INT
);
sconv(PCCT_INT
, PCCT_CHAR
);
error("chr's argument must be an integer, not %s", nameof(p1
));
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_CHAR
, PCCTM_PTR
) , "_CHR" );
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
putop( PCC_CALL
, PCCT_CHAR
);
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) RREQ
);
sconv(PCCT_INT
, PCCT_CHAR
);
error("Argument to card must be a set, not %s", nameof(p1
));
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
) , "_CARD" );
p1
= stkrval( argv
->list_node
.list
, NLNIL
, (long) LREQ
);
putleaf( PCC_ICON
, (int) lwidth( p1
) , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
error("Argument to eoln must be a text file, not %s", nameof(p1
));
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
) , "_TEOLN" );
p1
= stklval( argv
->list_node
.list
, NOFLAGS
);
putop( PCC_CALL
, PCCT_INT
);
sconv(PCCT_INT
, PCCT_CHAR
);
if (p1
->class != FILET
) {
error("Argument to eof must be file, not %s", nameof(p1
));
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
) , "_TEOF" );
p1
= stklval( argv
->list_node
.list
, NOFLAGS
);
putop( PCC_CALL
, PCCT_INT
);
sconv(PCCT_INT
, PCCT_CHAR
);