1*48116Sbostic /*- 2*48116Sbostic * Copyright (c) 1980 The Regents of the University of California. 3*48116Sbostic * All rights reserved. 4*48116Sbostic * 5*48116Sbostic * %sccs.include.redist.c% 622183Sdist */ 7764Speter 814738Sthien #ifndef lint 9*48116Sbostic static char sccsid[] = "@(#)pcfunc.c 5.2 (Berkeley) 04/16/91"; 10*48116Sbostic #endif /* not lint */ 11764Speter 12764Speter #include "whoami.h" 13764Speter #ifdef PC 14764Speter /* 15764Speter * and to the end of the file 16764Speter */ 17764Speter #include "0.h" 18764Speter #include "tree.h" 1910375Speter #include "objfmt.h" 20764Speter #include "opcode.h" 2110375Speter #include "pc.h" 2218464Sralph #include <pcc.h> 2311328Speter #include "tmps.h" 2414738Sthien #include "tree_ty.h" 25764Speter 26764Speter /* 27764Speter * Funccod generates code for 28764Speter * built in function calls and calls 29764Speter * call to generate calls to user 30764Speter * defined functions and procedures. 31764Speter */ 3214738Sthien struct nl * 33764Speter pcfunccod( r ) 3414738Sthien struct tnode *r; /* T_FCALL */ 35764Speter { 36764Speter struct nl *p; 37764Speter register struct nl *p1; 3814738Sthien register struct tnode *al; 39764Speter register op; 4014738Sthien int argc; 4114738Sthien struct tnode *argv; 4214738Sthien struct tnode tr, tr2; 43764Speter char *funcname; 443831Speter struct nl *tempnlp; 45764Speter long temptype; 46764Speter struct nl *rettype; 47764Speter 48764Speter /* 49764Speter * Verify that the given name 50764Speter * is defined and the name of 51764Speter * a function. 52764Speter */ 5314738Sthien p = lookup(r->pcall_node.proc_id); 5414738Sthien if (p == NLNIL) { 5514738Sthien rvlist(r->pcall_node.arg); 5614738Sthien return (NLNIL); 57764Speter } 581197Speter if (p->class != FUNC && p->class != FFUNC) { 59764Speter error("%s is not a function", p->symbol); 6014738Sthien rvlist(r->pcall_node.arg); 6114738Sthien return (NLNIL); 62764Speter } 6314738Sthien argv = r->pcall_node.arg; 64764Speter /* 65764Speter * Call handles user defined 66764Speter * procedures and functions 67764Speter */ 68764Speter if (bn != 0) 69764Speter return (call(p, argv, FUNC, bn)); 70764Speter /* 71764Speter * Count the arguments 72764Speter */ 73764Speter argc = 0; 7414738Sthien for (al = argv; al != TR_NIL; al = al->list_node.next) 75764Speter argc++; 76764Speter /* 77764Speter * Built-in functions have 78764Speter * their interpreter opcode 79764Speter * associated with them. 80764Speter */ 81764Speter op = p->value[0] &~ NSTAND; 82764Speter if (opt('s') && (p->value[0] & NSTAND)) { 83764Speter standard(); 84764Speter error("%s is a nonstandard function", p->symbol); 85764Speter } 86764Speter if ( op == O_ARGC ) { 8718464Sralph putleaf( PCC_NAME , 0 , 0 , PCCT_INT , "__argc" ); 88764Speter return nl + T4INT; 89764Speter } 90764Speter switch (op) { 91764Speter /* 92764Speter * Parameterless functions 93764Speter */ 94764Speter case O_CLCK: 95764Speter funcname = "_CLCK"; 96764Speter goto noargs; 97764Speter case O_SCLCK: 98764Speter funcname = "_SCLCK"; 99764Speter goto noargs; 100764Speter noargs: 101764Speter if (argc != 0) { 102764Speter error("%s takes no arguments", p->symbol); 103764Speter rvlist(argv); 10414738Sthien return (NLNIL); 105764Speter } 10618464Sralph putleaf( PCC_ICON , 0 , 0 10718464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 108764Speter , funcname ); 10918464Sralph putop( PCCOM_UNARY PCC_CALL , PCCT_INT ); 110764Speter return (nl+T4INT); 111764Speter case O_WCLCK: 112764Speter if (argc != 0) { 113764Speter error("%s takes no arguments", p->symbol); 114764Speter rvlist(argv); 11514738Sthien return (NLNIL); 116764Speter } 11718464Sralph putleaf( PCC_ICON , 0 , 0 11818464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 119764Speter , "_time" ); 12018464Sralph putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 ); 12118464Sralph putop( PCC_CALL , PCCT_INT ); 122764Speter return (nl+T4INT); 123764Speter case O_EOF: 124764Speter case O_EOLN: 125764Speter if (argc == 0) { 12614738Sthien argv = &(tr); 12714738Sthien tr.list_node.list = &(tr2); 12814738Sthien tr2.tag = T_VAR; 12914738Sthien tr2.var_node.cptr = input->symbol; 13014738Sthien tr2.var_node.line_no = NIL; 13114738Sthien tr2.var_node.qual = TR_NIL; 132764Speter argc = 1; 133764Speter } else if (argc != 1) { 134764Speter error("%s takes either zero or one argument", p->symbol); 135764Speter rvlist(argv); 13614738Sthien return (NLNIL); 137764Speter } 138764Speter } 139764Speter /* 140764Speter * All other functions take 141764Speter * exactly one argument. 142764Speter */ 143764Speter if (argc != 1) { 144764Speter error("%s takes exactly one argument", p->symbol); 145764Speter rvlist(argv); 14614738Sthien return (NLNIL); 147764Speter } 148764Speter /* 149764Speter * find out the type of the argument 150764Speter */ 151764Speter codeoff(); 15214738Sthien p1 = stkrval( argv->list_node.list, NLNIL , (long) RREQ ); 153764Speter codeon(); 15414738Sthien if (p1 == NLNIL) 15514738Sthien return (NLNIL); 156764Speter /* 157764Speter * figure out the return type and the funtion name 158764Speter */ 159764Speter switch (op) { 16014738Sthien case 0: 16114738Sthien error("%s is an unimplemented 6000-3.4 extension", p->symbol); 16214738Sthien default: 16314738Sthien panic("func1"); 164764Speter case O_EXP: 1655715Smckusic funcname = opt('t') ? "_EXP" : "_exp"; 166764Speter goto mathfunc; 167764Speter case O_SIN: 1685715Smckusic funcname = opt('t') ? "_SIN" : "_sin"; 169764Speter goto mathfunc; 170764Speter case O_COS: 1715715Smckusic funcname = opt('t') ? "_COS" : "_cos"; 172764Speter goto mathfunc; 173764Speter case O_ATAN: 1745715Smckusic funcname = opt('t') ? "_ATAN" : "_atan"; 175764Speter goto mathfunc; 176764Speter case O_LN: 177764Speter funcname = opt('t') ? "_LN" : "_log"; 178764Speter goto mathfunc; 179764Speter case O_SQRT: 180764Speter funcname = opt('t') ? "_SQRT" : "_sqrt"; 181764Speter goto mathfunc; 182764Speter case O_RANDOM: 183764Speter funcname = "_RANDOM"; 184764Speter goto mathfunc; 185764Speter mathfunc: 186764Speter if (isnta(p1, "id")) { 187764Speter error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); 18814738Sthien return (NLNIL); 189764Speter } 19018464Sralph putleaf( PCC_ICON , 0 , 0 19118464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_DOUBLE , PCCTM_PTR ) , funcname ); 19214738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 19318464Sralph sconv(p2type(p1), PCCT_DOUBLE); 19418464Sralph putop( PCC_CALL , PCCT_DOUBLE ); 195764Speter return nl + TDOUBLE; 196764Speter case O_EXPO: 197764Speter if (isnta( p1 , "id" ) ) { 198764Speter error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); 199764Speter return NIL; 200764Speter } 20118464Sralph putleaf( PCC_ICON , 0 , 0 20218464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_EXPO" ); 20314738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 20418464Sralph sconv(p2type(p1), PCCT_DOUBLE); 20518464Sralph putop( PCC_CALL , PCCT_INT ); 206764Speter return ( nl + T4INT ); 207764Speter case O_UNDEF: 208764Speter if ( isnta( p1 , "id" ) ) { 209764Speter error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1)); 21014738Sthien return NLNIL; 211764Speter } 21214738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 21318464Sralph putleaf( PCC_ICON , 0 , 0 , PCCT_CHAR , (char *) 0 ); 21418464Sralph putop( PCC_COMOP , PCCT_CHAR ); 215764Speter return ( nl + TBOOL ); 216764Speter case O_SEED: 217764Speter if (isnta(p1, "i")) { 218764Speter error("seed's argument must be an integer, not %s", nameof(p1)); 21914738Sthien return (NLNIL); 220764Speter } 22118464Sralph putleaf( PCC_ICON , 0 , 0 22218464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_SEED" ); 22314738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 22418464Sralph putop( PCC_CALL , PCCT_INT ); 225764Speter return nl + T4INT; 226764Speter case O_ROUND: 227764Speter case O_TRUNC: 228764Speter if ( isnta( p1 , "d" ) ) { 229764Speter error("%s's argument must be a real, not %s", p->symbol, nameof(p1)); 23014738Sthien return (NLNIL); 231764Speter } 23218464Sralph putleaf( PCC_ICON , 0 , 0 23318464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 234764Speter , op == O_ROUND ? "_ROUND" : "_TRUNC" ); 23514738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 23618464Sralph putop( PCC_CALL , PCCT_INT ); 237764Speter return nl + T4INT; 238764Speter case O_ABS2: 239764Speter if ( isa( p1 , "d" ) ) { 24018464Sralph putleaf( PCC_ICON , 0 , 0 24118464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_DOUBLE , PCCTM_PTR ) 242764Speter , "_fabs" ); 24314738Sthien p1 = stkrval( argv->list_node.list , NLNIL ,(long) RREQ ); 24418464Sralph putop( PCC_CALL , PCCT_DOUBLE ); 245764Speter return nl + TDOUBLE; 246764Speter } 247764Speter if ( isa( p1 , "i" ) ) { 24818464Sralph putleaf( PCC_ICON , 0 , 0 24918464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_abs" ); 25014738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 25118464Sralph putop( PCC_CALL , PCCT_INT ); 252764Speter return nl + T4INT; 253764Speter } 254764Speter error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); 25514738Sthien return NLNIL; 256764Speter case O_SQR2: 257764Speter if ( isa( p1 , "d" ) ) { 25818464Sralph temptype = PCCT_DOUBLE; 259764Speter rettype = nl + TDOUBLE; 26014738Sthien tempnlp = tmpalloc((long) (sizeof(double)), rettype, REGOK); 261764Speter } else if ( isa( p1 , "i" ) ) { 26218464Sralph temptype = PCCT_INT; 263764Speter rettype = nl + T4INT; 26414738Sthien tempnlp = tmpalloc((long) (sizeof(long)), rettype, REGOK); 265764Speter } else { 266764Speter error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1)); 26714738Sthien return NLNIL; 268764Speter } 26914738Sthien putRV( (char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 27014738Sthien tempnlp -> extra_flags , (char) temptype ); 27114738Sthien p1 = rvalue( argv->list_node.list , NLNIL , RREQ ); 27214738Sthien sconv(p2type(p1), (int) temptype); 27318464Sralph putop( PCC_ASSIGN , (int) temptype ); 27414738Sthien putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 27514738Sthien tempnlp -> extra_flags , (char) temptype ); 27614738Sthien putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] , 27714738Sthien tempnlp -> extra_flags , (char) temptype ); 27818464Sralph putop( PCC_MUL , (int) temptype ); 27918464Sralph putop( PCC_COMOP , (int) temptype ); 280764Speter return rettype; 281764Speter case O_ORD2: 28214738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 2839573Speter if (isa(p1, "bcis")) { 284764Speter return (nl+T4INT); 285764Speter } 2869573Speter if (classify(p1) == TPTR) { 2879573Speter if (!opt('s')) { 2889573Speter return (nl+T4INT); 2899573Speter } 2909573Speter standard(); 2919573Speter } 2929573Speter error("ord's argument must be of scalar type, not %s", 2939573Speter nameof(p1)); 29414738Sthien return (NLNIL); 295764Speter case O_SUCC2: 296764Speter case O_PRED2: 297764Speter if (isa(p1, "d")) { 298764Speter error("%s is forbidden for reals", p->symbol); 29914738Sthien return (NLNIL); 300764Speter } 301764Speter if ( isnta( p1 , "bcsi" ) ) { 302764Speter error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1)); 30314738Sthien return NLNIL; 304764Speter } 305764Speter if ( opt( 't' ) ) { 30618464Sralph putleaf( PCC_ICON , 0 , 0 30718464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) 308764Speter , op == O_SUCC2 ? "_SUCC" : "_PRED" ); 30914738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 3106596Smckusick tempnlp = p1 -> class == TYPE ? p1 -> type : p1; 31118464Sralph putleaf( PCC_ICON, (int) tempnlp -> range[0], 0, PCCT_INT, (char *) 0 ); 31218464Sralph putop( PCC_CM , PCCT_INT ); 31318464Sralph putleaf( PCC_ICON, (int) tempnlp -> range[1], 0, PCCT_INT, (char *) 0 ); 31418464Sralph putop( PCC_CM , PCCT_INT ); 31518464Sralph putop( PCC_CALL , PCCT_INT ); 31618464Sralph sconv(PCCT_INT, p2type(p1)); 317764Speter } else { 31814738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 31918464Sralph putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 ); 32018464Sralph putop( op == O_SUCC2 ? PCC_PLUS : PCC_MINUS , PCCT_INT ); 32118464Sralph sconv(PCCT_INT, p2type(p1)); 322764Speter } 323764Speter if ( isa( p1 , "bcs" ) ) { 324764Speter return p1; 325764Speter } else { 326764Speter return nl + T4INT; 327764Speter } 328764Speter case O_ODD2: 329764Speter if (isnta(p1, "i")) { 330764Speter error("odd's argument must be an integer, not %s", nameof(p1)); 33114738Sthien return (NLNIL); 332764Speter } 33314738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 33410669Speter /* 33510669Speter * THIS IS MACHINE-DEPENDENT!!! 33610669Speter */ 33718464Sralph putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 ); 33818464Sralph putop( PCC_AND , PCCT_INT ); 33918464Sralph sconv(PCCT_INT, PCCT_CHAR); 340764Speter return nl + TBOOL; 341764Speter case O_CHR2: 342764Speter if (isnta(p1, "i")) { 343764Speter error("chr's argument must be an integer, not %s", nameof(p1)); 34414738Sthien return (NLNIL); 345764Speter } 346764Speter if (opt('t')) { 34718464Sralph putleaf( PCC_ICON , 0 , 0 34818464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_CHAR , PCCTM_PTR ) , "_CHR" ); 34914738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 35018464Sralph putop( PCC_CALL , PCCT_CHAR ); 351764Speter } else { 35214738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) RREQ ); 35318464Sralph sconv(PCCT_INT, PCCT_CHAR); 354764Speter } 355764Speter return nl + TCHAR; 356764Speter case O_CARD: 3571554Speter if (isnta(p1, "t")) { 3581554Speter error("Argument to card must be a set, not %s", nameof(p1)); 35914738Sthien return (NLNIL); 360764Speter } 36118464Sralph putleaf( PCC_ICON , 0 , 0 36218464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_CARD" ); 36314738Sthien p1 = stkrval( argv->list_node.list , NLNIL , (long) LREQ ); 36418464Sralph putleaf( PCC_ICON , (int) lwidth( p1 ) , 0 , PCCT_INT , (char *) 0 ); 36518464Sralph putop( PCC_CM , PCCT_INT ); 36618464Sralph putop( PCC_CALL , PCCT_INT ); 36710669Speter return nl + T4INT; 368764Speter case O_EOLN: 369764Speter if (!text(p1)) { 370764Speter error("Argument to eoln must be a text file, not %s", nameof(p1)); 37114738Sthien return (NLNIL); 372764Speter } 37318464Sralph putleaf( PCC_ICON , 0 , 0 37418464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_TEOLN" ); 37514738Sthien p1 = stklval( argv->list_node.list , NOFLAGS ); 37618464Sralph putop( PCC_CALL , PCCT_INT ); 37718464Sralph sconv(PCCT_INT, PCCT_CHAR); 378764Speter return nl + TBOOL; 379764Speter case O_EOF: 380764Speter if (p1->class != FILET) { 381764Speter error("Argument to eof must be file, not %s", nameof(p1)); 38214738Sthien return (NLNIL); 383764Speter } 38418464Sralph putleaf( PCC_ICON , 0 , 0 38518464Sralph , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , "_TEOF" ); 38614738Sthien p1 = stklval( argv->list_node.list , NOFLAGS ); 38718464Sralph putop( PCC_CALL , PCCT_INT ); 38818464Sralph sconv(PCCT_INT, PCCT_CHAR); 389764Speter return nl + TBOOL; 390764Speter } 391764Speter } 392764Speter #endif PC 393