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