# 2.11BSD#431 - /usr/src/ucb/pascal/pi/func.c

##### Functions

    funccod           X

##### Variables

    cardemptyline     X

       1: /*	@(#)func.c	2.4	SCCS id keyword	*/
       2: /* Copyright (c) 1979 Regents of the University of California */
       3: #
       4: /*
       5:  * pi - Pascal interpreter code translator
       6:  *
       7:  * Charles Haley, Bill Joy UCB
       8:  * Version 1.2 November 1978
       9:  */
      10:
      11: #include "whoami"
      12: #include "0.h"
      13: #include "tree.h"
      14: #include "opcode.h"
      15:
      16: short cardemptyline = 0;
      17:
      18: /*
      19:  * Funccod generates code for
      20:  * built in function calls and calls
      21:  * call to generate calls to user
      22:  * defined functions and procedures.
      23:  */
      24: funccod(r)
      25:     int *r;
      26: {
      27:     struct nl *p;
      28:     register struct nl *p1;
      29:     register int *al;
      30:     register op;
      31:     int argc, *argv;
      32:     int tr[2], tr2[4];
      33:
      34:     /*
      35: 	 * Verify that the given name
      36: 	 * is defined and the name of
      37: 	 * a function.
      38: 	 */
      39:     p = lookup(r[2]);
      40:     if (p == NIL) {
      41:         rvlist(r[3]);
      42:         return (NIL);
      43:     }
      44:     if (p->class != FUNC) {
      45:         error("%s is not a function", p->symbol);
      46:         rvlist(r[3]);
      47:         return (NIL);
      48:     }
      49:     argv = r[3];
      50:     /*
      51: 	 * Call handles user defined
      52: 	 * procedures and functions
      53: 	 */
      54:     if (bn != 0)
      55:         return (call(p, argv, FUNC, bn));
      56:     /*
      57: 	 * Count the arguments
      58: 	 */
      59:     argc = 0;
      60:     for (al = argv; al != NIL; al = al[2])
      61:         argc++;
      62:     /*
      63: 	 * Built-in functions have
      64: 	 * their interpreter opcode
      65: 	 * associated with them.
      66: 	 */
      67:     op = p->value[0] &~ NSTAND;
      68:     if (opt('s') && (p->value[0] & NSTAND)) {
      69:         standard();
      70:         error("%s is a nonstandard function", p->symbol);
      71:     }
      72:     switch (op) {
      73:         /*
      74: 		 * Parameterless functions
      75: 		 */
      76:         case O_CLCK:
      77:         case O_SCLCK:
      78:         case O_WCLCK:
      79:         case O_ARGC:
      80:             if (argc != 0) {
      81:                 error("%s takes no arguments", p->symbol);
      82:                 rvlist(argv);
      83:                 return (NIL);
      84:             }
      85:             put1(op);
      86:             return (nl+T4INT);
      87:         case O_EOF:
      88:         case O_EOLN:
      89:             if (argc == 0) {
      90:                 argv = tr;
      91:                 tr[1] = tr2;
      92:                 tr2[0] = T_VAR;
      93:                 tr2[2] = input->symbol;
      94:                 tr2[1] = tr2[3] = NIL;
      95:                 argc = 1;
      96:             } else if (argc != 1) {
      97:                 error("%s takes either zero or one argument", p->symbol);
      98:                 rvlist(argv);
      99:                 return (NIL);
     100:             }
     101:         }
     102:     /*
     103: 	 * All other functions take
     104: 	 * exactly one argument.
     105: 	 */
     106:     if (argc != 1) {
     107:         error("%s takes exactly one argument", p->symbol);
     108:         rvlist(argv);
     109:         return (NIL);
     110:     }
     111:     /*
     112: 	 * Evaluate the argmument
     113: 	 */
     114:     p1 = rvalue((int *) argv[1], NLNIL);
     115:     if (p1 == NIL)
     116:         return (NIL);
     117:     switch (op) {
     118:         case O_EXP:
     119:         case O_SIN:
     120:         case O_COS:
     121:         case O_ATAN:
     122:         case O_LN:
     123:         case O_SQRT:
     124:         case O_RANDOM:
     125:         case O_EXPO:
     126:         case O_UNDEF:
     127:             if (isa(p1, "i"))
     128:                 convert(p1, nl+TDOUBLE);
     129:             else if (isnta(p1, "d")) {
     130:                 error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
     131:                 return (NIL);
     132:             }
     133:             put1(op);
     134:             if (op == O_UNDEF)
     135:                 return (nl+TBOOL);
     136:             else if (op == O_EXPO)
     137:                 return (nl+T4INT);
     138:             else
     139:                 return (nl+TDOUBLE);
     140:         case O_SEED:
     141:             if (isnta(p1, "i")) {
     142:                 error("seed's argument must be an integer, not %s", nameof(p1));
     143:                 return (NIL);
     144:             }
     145:             convert(p1, nl+T4INT);
     146:             put1(op);
     147:             return (nl+T4INT);
     148:         case O_ROUND:
     149:         case O_TRUNC:
     150:             if (isnta(p1, "d"))  {
     151:                 error("%s's argument must be a real, not %s", p->symbol, nameof(p1));
     152:                 return (NIL);
     153:             }
     154:             put1(op);
     155:             return (nl+T4INT);
     156:         case O_ABS2:
     157:         case O_SQR2:
     158:             if (isa(p1, "d")) {
     159:                 put1(op + O_ABS8-O_ABS2);
     160:                 return (nl+TDOUBLE);
     161:             }
     162:             if (isa(p1, "i")) {
     163:                 put1(op + (width(p1) >> 2));
     164:                 return (nl+T4INT);
     165:             }
     166:             error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
     167:             return (NIL);
     168:         case O_ORD2:
     169:             if (isa(p1, "bcis") || classify(p1) == TPTR)
     170:                 switch (width(p1)) {
     171:                     case 1:
     172:                         return (nl+T1INT);
     173:                     case 2:
     174:                         return (nl+T2INT);
     175:                     case 4:
     176:                         return (nl+T4INT);
     177:                 }
     178:             error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1));
     179:             return (NIL);
     180:         case O_SUCC2:
     181:         case O_PRED2:
     182:             if (isa(p1, "bcs")) {
     183:                 put1(op);
     184:                 return (p1);
     185:             }
     186:             if (isa(p1, "i")) {
     187:                 if (width(p1) <= 2)
     188:                     op += O_PRED24-O_PRED2;
     189:                 else
     190:                     op++;
     191:                 put1(op);
     192:                 return (nl+T4INT);
     193:             }
     194:             if (isa(p1, "id")) {
     195:                 error("%s is forbidden for reals", p->symbol);
     196:                 return (NIL);
     197:             }
     198:             error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
     199:             return (NIL);
     200:         case O_ODD2:
     201:             if (isnta(p1, "i")) {
     202:                 error("odd's argument must be an integer, not %s", nameof(p1));
     203:                 return (NIL);
     204:             }
     205:             put1(op + (width(p1) >> 2));
     206:             return (nl+TBOOL);
     207:         case O_CHR2:
     208:             if (isnta(p1, "i")) {
     209:                 error("chr's argument must be an integer, not %s", nameof(p1));
     210:                 return (NIL);
     211:             }
     212:             put1(op + (width(p1) >> 2));
     213:             return (nl+TCHAR);
     214:         case O_CARD:
     215:             if ( ( p1 != nl + TSET ) && isnta(p1, "t")) {
     216:                 error("Argument to card must be a set, not %s", nameof(p1));
     217:                 return (NIL);
     218:             }
     219:             if ( p1 == nl + TSET ) {
     220:                 if ( line != cardemptyline ) {
     221:                     cardemptyline = line;
     222:                     warning();
     223:                     error("Cardinality of the empty set is always 0");
     224:                 }
     225:                 put2(O_CON1, 0);
     226:             } else {
     227:                 put2(O_CARD, width(p1));
     228:             }
     229:             return (nl+T2INT);
     230:         case O_EOLN:
     231:             if (!text(p1)) {
     232:                 error("Argument to eoln must be a text file, not %s", nameof(p1));
     233:                 return (NIL);
     234:             }
     235:             put1(op);
     236:             return (nl+TBOOL);
     237:         case O_EOF:
     238:             if (p1->class != FILET) {
     239:                 error("Argument to eof must be file, not %s", nameof(p1));
     240:                 return (NIL);
     241:             }
     242:             put1(op);
     243:             return (nl+TBOOL);
     244:         case 0:
     245:             error("%s is an unimplemented 6000-3.4 extension", p->symbol);
     246:         default:
     247:             panic("func1");
     248:     }
     249: }

#### Defined functions

funccod defined in line 24; used 2 times

- in /usr/src/ucb/pascal/pi/rval.c line 66, 203

#### Defined variables

cardemptyline defined in line 16; used 2 times

- in line 220-221(2)

Last modified: 1983-03-17 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 850 |