home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / pd3.lzh / SBPROLOG2.2 / SIM / main.c < prev    next >
C/C++ Source or Header  |  1991-08-10  |  30KB  |  1,326 lines

  1. /************************************************************************
  2. *                                    *
  3. *    The SB-Prolog System                        *
  4. *    Copyright SUNY at Stony Brook, 1986                *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24.  
  25. /* main.c */
  26.  
  27. #include "simdef.h"
  28. #include "aux.h"
  29. #include "inst.h"
  30.  
  31. #define system_up 1
  32.  
  33. #define pad lpcreg++
  34. #define opregno (*lpcreg++)
  35. #define regc(regno) (follow(rreg+regno))
  36. #define opregc (regc(opregno))
  37. #define opreg ((word)(rreg+opregno))
  38. #define opvarno (*lpcreg++)
  39. #define varc(varno) follow(le_reg+(-(long)varno))
  40. #define opvarc varc(opvarno)
  41. #define opvar ((word)(le_reg+(-(long)opvarno)))
  42.  
  43. #define opbyte *lpcreg++
  44. #define op2word op2 = *(pw)lpcreg; lpcreg+=4
  45. #define op3word op3 = *(pw)lpcreg; lpcreg+=4
  46. #define nparse_opPVRv pad; op1 = opvarc; op2 = opregc
  47. #define nparse_opPRRv pad; op1 = opregc; op2 = opregc
  48. #define nparse_opVWv op1 = opvarc; op2word
  49. #define nparse_opRWv op1 = opregc; op2word
  50. #define nparse_opRv op1 = opregc
  51. #define nparse_opVv op1 = opvarc
  52. #define nparse_opPW pad; op2word /* note op2! */
  53. #define nparse_opBW op1 = opbyte; op2word
  54. #define nparse_opB op1 = opbyte
  55.  
  56. extern byte *set_intercode();
  57. extern double floatval();
  58. extern word makefloat();
  59. extern prettymuch_equal();
  60.  
  61. int current_opcode;
  62.  
  63. main(argc, argv)
  64. int argc;
  65. char *argv[];
  66.  
  67. { /* start main */
  68. struct psc_rec *psc;
  69. pw opr;
  70. register byte *lpcreg;
  71. register word *le_reg;
  72. register word *rreg; /* for SUN */
  73. register word *sreg;
  74.  
  75. /* */
  76. register pw top;
  77. register word op1, op2;
  78. word op3;
  79.  
  80. short int i, arity;  /* to unify subfields of op1 and op2 */
  81.  
  82.    arm_intercept();
  83.    init_sim(argc, argv);
  84.    init_jump_table();
  85.    init_parse_routine();
  86.    init_load_routine();
  87.    init_builtin();
  88.    init_loading(argc, argv);
  89.    if (disassem) {
  90.     dis( );
  91.     printf("The byte code file is dumped in the file dump.pil\n");
  92.     exit(0);
  93.    }
  94.    lpcreg = inst_begin;
  95.    le_reg = (pw)ereg;
  96.    rreg = (pw)®[0]; /* for SUN */
  97.  
  98.    while ( system_up ) {        /* the main loop */
  99.  
  100. contcase:
  101.  
  102.     switch ( *lpcreg++ ) {
  103.  
  104.  case getpvar00:  /* PVR */
  105.     pad;
  106.     op1 = opvarno;
  107.     varc(op1) = opregc;
  108.     goto contcase;
  109.  
  110.  case getpval00: /* PVR */
  111.     nparse_opPVRv; 
  112.     goto nunify;
  113.  
  114.  case getstrv00: /* VW */
  115.     nparse_opVWv;
  116.     goto nunify_with_str;
  117.  
  118.  case gettval00: /* PRR */
  119.     nparse_opPRRv;
  120.     goto nunify;
  121.  
  122.  case getcon00: /* RW */
  123.     nparse_opRWv;
  124.     goto nunify_with_con;
  125.  
  126.  case getnil00: /* R */
  127.     nparse_opRv;
  128.     goto nunify_with_nil;
  129.  
  130.  case getstr00: /* RW */
  131.     nparse_opRWv;
  132.     goto nunify_with_str;
  133.  
  134.  case getlist00: /* R */
  135.     nparse_opRv;
  136.     goto nunify_with_list_sym;
  137.  
  138.  case unipvar00: /* V */
  139.     if (flag == WRITEFLAG) {
  140.     opvarc = (word)hreg;
  141.     new_heap_free;
  142.     }
  143.     else opvarc = *sreg++;
  144.     goto contcase;
  145.  
  146.  case unipval00: /* V */
  147.     nparse_opVv;
  148.     if ( flag == WRITEFLAG ) goto nbldval;
  149.     else {  op2 = *sreg++;
  150.         goto nunify;
  151.      } 
  152.  
  153.  case unitvar00: /* R */
  154.     if ( flag == WRITEFLAG ) 
  155.     {opregc = (word)hreg;
  156.      new_heap_free;}
  157.     else opregc = *sreg++;
  158.     goto contcase;
  159.  
  160.  case unitval00: /* R */
  161.     nparse_opRv;
  162.     if ( flag == WRITEFLAG ) goto nbldval;
  163.     else 
  164.     { op2 = *sreg++;
  165.       goto nunify;
  166.     } 
  167.  
  168.  case unicon00: /* PW */
  169.     nparse_opPW; /* note goes to op2! */
  170.     if ( flag == WRITEFLAG ) new_heap_con(op2);
  171.     else {  /* op2 already set */
  172.         op1 = *sreg++;
  173.         goto nunify_with_con;}
  174.     goto contcase;
  175.  
  176.  case uninil00: /* P */
  177.     pad;
  178.     if ( flag == WRITEFLAG ) new_heap_node(nil_sym);
  179.     else {  op1 = *sreg++;
  180.         goto nunify_with_nil;}
  181.     goto contcase;
  182.  
  183.  case getnumcon: /* RW */
  184.     nparse_opRWv;
  185.     goto nunify_with_int;
  186.  
  187.  case getival: /* RW */
  188.     nparse_opRWv;
  189.     goto nunify;
  190.  
  191.  case putnumcon: /* RW */
  192.     op1 = opregno;
  193.     regc(op1) = makeint(*(pw)lpcreg); lpcreg+=4;
  194.     goto contcase;
  195.  
  196.  case putpvar00: /* PVR */
  197.     pad;
  198.     op1 = opvar;
  199.     follow(op1) = op1;
  200.     opregc = op1;
  201.     goto contcase;
  202.  
  203.  case putpval00: /* PVR */
  204.     pad;
  205.     op1 = opvarno;
  206.     opregc = varc(op1);
  207.     goto contcase;
  208.  
  209.  case puttvar00: /* PRR */
  210.     pad;
  211.     opregc = (word)hreg;
  212.     opregc = (word)hreg;
  213.     new_heap_free; 
  214.     goto contcase;
  215.  
  216.  case putstrv00: /*  VW */
  217.     opvarc = (word)hreg | CS_TAG;
  218.     new_heap_node(*(pw)lpcreg); lpcreg+=4;
  219.     goto contcase;
  220.  
  221.  case putcon00: /* RW */
  222.     op1 = opregno;
  223.     regc(op1) = (*(pw)lpcreg) | CS_TAG; lpcreg+=4;
  224.     goto contcase;
  225.  
  226.  case putnil00: /* R */
  227.     opregc = nil_sym;
  228.     goto contcase;
  229.  
  230.  case putstr00: /* RW */
  231.     opregc = (word)hreg | CS_TAG;
  232.     new_heap_node(*(pw)lpcreg); lpcreg+=4;
  233.     goto contcase;
  234.  
  235.  case putlist00: /* R */
  236.     opregc = (word)hreg | LIST_TAG;
  237.     goto contcase;
  238.  
  239.  case bldpvar00: /* V */
  240.     opvarc = (word)hreg;
  241.     new_heap_free;
  242.     goto contcase;
  243.  
  244.  case bldpval00: /* V */
  245.     nparse_opVv;
  246.     goto nbldval;
  247.  
  248.  case bldtvar00: /* R */
  249.     opregc = (word)hreg;
  250.     new_heap_free;
  251.     goto contcase;
  252.  
  253.  case bldtval00: /* R */
  254.     nparse_opRv;
  255.     goto nbldval;
  256.  
  257.  case bldcon00: /* PW */
  258.     pad;
  259.     new_heap_con(*(pw)lpcreg);
  260.     lpcreg+=4;
  261.     goto contcase;
  262.  
  263.  case bldnil00: /* P */
  264.     pad;
  265.     new_heap_node(nil_sym);
  266.     goto contcase;
  267.  
  268.  case getlist_tvar_tvar: /* BBB */
  269.     op1 = opregc;
  270.     glrr: switch ((int)(op1 & 3)) {
  271.     case FREE:
  272.         nderef(op1, glrr);
  273.         follow(op1) = (word)hreg | LIST_TAG;
  274.         pushtrail(op1);
  275.         opregc = (word)hreg;
  276.         new_heap_free;
  277.         opregc = (word)hreg;
  278.         new_heap_free;
  279.         break;
  280.     case CS:
  281.     case NUM:
  282.         Fail1;
  283.         break;
  284.     case LIST:
  285.         sreg = (pw)(untagged(op1));
  286.         opregc = *sreg++;
  287.         opregc = *sreg;
  288.         break;
  289.     }   /* end getlist_tvar_tvar */
  290.     goto contcase;
  291.  
  292.  case getcomma: /* R */
  293.     nparse_opRv;
  294.     op2 = (word)comma_psc;
  295.     goto nunify_with_str;
  296.  
  297.  case getcomma_tvar_tvar: /* BBB */
  298.     op1 = opregc;
  299.     gcrr: switch ((int) (op1 & 3)) {
  300.     case FREE:
  301.         nderef(op1, gcrr);
  302.         follow(op1) = (word)hreg | CS_TAG;
  303.         pushtrail(op1);
  304.         new_heap_node(((word)comma_psc));
  305.         pushtrail(op1);
  306.         opregc = (word)hreg;
  307.         new_heap_free;
  308.         opregc = (word)hreg;
  309.         new_heap_free;
  310.         break;
  311.     case CS:
  312.         untag(op1);
  313.         if (follow(op1) == (word)comma_psc) {
  314.         sreg = (pw)(op1+4);
  315.         opregc = *sreg++;
  316.         opregc = *sreg;
  317.         break;
  318.         }
  319.     case NUM:
  320.     case LIST:
  321.         Fail1;
  322.         break;
  323.     }   /* end getcomma_tvar_tvar */
  324.     goto contcase;
  325.  
  326.  case uninumcon: /* PL */
  327.     nparse_opPW; /* num in op2 */
  328.     if ( flag == WRITEFLAG ) new_heap_int(op2);
  329.     else {  /* op2 set */
  330.         op1 = *sreg++;
  331.         goto nunify_with_int;} 
  332.     goto contcase;
  333.  
  334.  case bldnumcon: /* PL */
  335.     nparse_opPW; /* num to op2 */
  336.     new_heap_int(op2);
  337.     goto contcase;
  338.  
  339.  case getfloatcon: /* RW */
  340.     nparse_opRWv;
  341.     goto nunify_with_float;
  342.  
  343.  case putfloatcon: /* RW */
  344.     op1 = opregno;
  345.     regc(op1) = (*(pw)lpcreg); lpcreg+=4;  /* float already tagged */
  346.     goto contcase;
  347.  
  348.  case unifloatcon: /* PL */
  349.     nparse_opPW; /* float in op2 */
  350.     if ( flag == WRITEFLAG ) new_heap_float(op2);
  351.     else {  /* op2 set */
  352.         op1 = *sreg++;
  353.         goto nunify_with_float;} 
  354.     goto contcase;
  355.  
  356.  case bldfloatcon: /* PL */
  357.     nparse_opPW; /* float to op2 */
  358.     new_heap_float(op2);
  359.     goto contcase;
  360.  
  361.  case trymeelse: /* BA */
  362.     nparse_opBW;
  363.     goto subtryme;
  364.  
  365.  case retrymeelse: /* BA */
  366.     op1 = *lpcreg++;
  367.     *(breg+1) = *(pw)lpcreg;
  368.     lpcreg+=4;
  369.     goto rerestore;
  370.  
  371.  case trustmeelsefail: /* B */
  372.     nparse_opB;
  373.     goto trrestore;
  374.  
  375.  case try: /* BA */
  376.     op1 = *lpcreg++;
  377.     op2 = (word)lpcreg + 4;
  378.     lpcreg = *(pb *)lpcreg;
  379.     goto subtryme;
  380.  
  381.  case retry: /* BA */
  382.     op1 = *lpcreg++;
  383.     *(breg+1) = (word)lpcreg+4;
  384.     lpcreg = *(pb *)lpcreg;
  385.     goto rerestore;
  386.  
  387.  case trust: /* BA */
  388.     op1 = *lpcreg++;
  389.     lpcreg = *(pb *)lpcreg;
  390.     goto trrestore;
  391.  
  392.  case getpbreg: /* V */
  393.     opvarc = (word)breg | NUM_TAG;
  394.     goto contcase;
  395.  
  396.  case gettbreg: /* R */
  397.     opregc = (word)breg | NUM_TAG;
  398.     goto contcase;
  399.  
  400.  case putpbreg: /* V */
  401.     nparse_opVv;
  402.     deref(op1);
  403.     breg = (pw)(untagged(op1));
  404.     hbreg = (pw)*(breg + 3);
  405.     goto contcase;
  406.  
  407.  case puttbreg: /* R */
  408.     nparse_opRv;
  409.     deref(op1);
  410.     breg = (pw)(untagged(op1));
  411.     hbreg = (pw)*(breg + 3);
  412.     goto contcase;
  413.  
  414.  case jumptbreg: /* RW */
  415.     opregc = (word)breg | NUM_TAG;
  416.     lpcreg = *(byte **)lpcreg;
  417.     goto contcase;
  418.  
  419.  case switchonterm: /* RWW */
  420.     op1 = opregc;
  421.     sotd: switch((int) (op1&3)) {
  422.     case FREE: nderef(op1, sotd);
  423.         lpcreg += 8; break;
  424.     case NUM:
  425.         lpcreg = *(pb *)lpcreg;        
  426.         break;
  427.     case CS:
  428.         if (get_str_arity(op1) == 0) {
  429.         lpcreg = *(pb *)lpcreg;
  430.         break;
  431.         }
  432.     case LIST:      /* include structure case here */
  433.         lpcreg += 4; lpcreg = *(pb *)lpcreg; 
  434.         break;
  435.     }
  436.     goto contcase;
  437.  
  438.  case switchonbound: /* RWW */
  439.     op1 = opregc;
  440.     sotd1: switch((int) (op1&3)) {
  441.     case FREE:  nderef(op1, sotd1); 
  442.         lpcreg += 8; goto sotd2;
  443.     case NUM: 
  444.         op1 = numval(op1);
  445.         break;
  446.     case LIST:
  447.         op1 = *((pw)untagged(list_str)); 
  448.         /* op1 = untagged(list_str); */
  449.         break;
  450.     case CS:
  451.         op1 = (word)get_str_psc(op1);
  452.             /* if (get_str_arity(op1) != 0) 
  453.                     op1 = (word)get_str_psc(op1);
  454.                 else op1 = untagged(op1); 
  455.                 op1 = untagged(op1); */
  456.             break;
  457.     }
  458.     op2 = *(pw)(lpcreg); lpcreg += 4;
  459.     op3 = *(pw)(lpcreg); 
  460.     lpcreg = *(pb *)(ihash(op1, op3) * 4 + op2);
  461.     sotd2: goto contcase;
  462.  
  463.  case switchoncon: nparse_opPW;
  464.    printf("Switchoncon not implemented\n");
  465.     goto contcase;
  466.  
  467.  case switchonstr: nparse_opPW;
  468.    printf("Switchonstr not implemented\n");
  469.     goto contcase;
  470.  
  471.  case movreg: /* PRR */
  472.     pad;
  473.     op1 = opregno;
  474.     opregc = regc(op1);
  475.     goto contcase;
  476.  
  477.  case addreg: /* PRR */
  478.     pad;
  479.     op1 = opregc;
  480.     op3 = opreg;
  481.     op2 = follow(op3);
  482.     deref(op1); 
  483.     deref(op2);
  484.     if (!isnum(op1) || !isnum(op2)) 
  485.     {printf("add: number required\n"); Fail1;}
  486.     else {
  487. #ifndef OS9
  488.     reset_floatflag;
  489.     set_psw_if_float(op1);
  490.     set_psw_if_float(op2);
  491.     follow(op3) = makenum(numval(op2) + numval(op1));
  492. #else
  493.     if (isinteger(op1))
  494.     {
  495.         if (isinteger(op2))
  496.             follow(op3) = makeint(intval(op1)+intval(op2));
  497.         else follow(op3) = makefloat((double)intval(op1)+floatval(op2));
  498.     } else
  499.     if (isinteger(op2))
  500.         follow(op3) = makefloat(floatval(op1)+(double)intval(op2));
  501.     else follow(op3) = makefloat(floatval(op1)+floatval(op2));
  502. #endif
  503.     };
  504.     goto contcase; 
  505.  
  506.  case subreg: /* PRR */
  507.     pad;
  508.     op1 = opregc;
  509.     op3 = opreg;
  510.     op2 = follow(op3);
  511.     deref(op1); 
  512.     deref(op2);
  513.     if (!isnum(op1) || !isnum(op2)) 
  514.     {printf("sub: number required\n"); Fail1;}
  515.     else {
  516. #ifndef OS9
  517.     reset_floatflag;
  518.     set_psw_if_float(op1);
  519.     set_psw_if_float(op2);
  520.     follow(op3) = makenum(numval(op2) - numval(op1));
  521. #else
  522.     if (isinteger(op1))
  523.     {
  524.         if (isinteger(op2))
  525.             follow(op3) = makeint(intval(op2)-intval(op1));
  526.         else follow(op3) = makefloat(floatval(op2)-(double)intval(op1));
  527.     } else
  528.     if (isinteger(op2))
  529.         follow(op3) = makefloat((double)intval(op2)-floatval(op1));
  530.     else follow(op3) = makefloat(floatval(op2)-floatval(op1));
  531. #endif
  532.     };
  533.     goto contcase; 
  534.  
  535.  case mulreg: /* PRR */
  536.     pad;
  537.     op1 = opregc;
  538.     op3 = opreg;
  539.     op2 = follow(op3);
  540.     deref(op1); 
  541.     deref(op2);
  542.     if (!isnum(op1) || !isnum(op2)) 
  543.     {printf("mul: number required\n"); Fail1;}
  544.     else {
  545. #ifndef OS9
  546.     reset_floatflag;
  547.     set_psw_if_float(op1);
  548.     set_psw_if_float(op2);
  549.     follow(op3) = makenum(numval(op2) * numval(op1));
  550. #else
  551.     if (isinteger(op1))
  552.     {
  553.         if (isinteger(op2))
  554.             follow(op3) = makeint(intval(op1)*intval(op2));
  555.         else follow(op3) = makefloat((double)intval(op1)*floatval(op2));
  556.     } else
  557.     if (isinteger(op2))
  558.         follow(op3) = makefloat(floatval(op1)*(double)intval(op2));
  559.     else follow(op3) = makefloat(floatval(op1)*floatval(op2));
  560. #endif
  561.     };
  562.     goto contcase; 
  563.  
  564.  case divreg: /* PRR */
  565.     pad;
  566.     op1 = opregc;
  567.     op3 = opreg;
  568.     op2 = follow(op3);
  569.     deref(op1); 
  570.     deref(op2);
  571.     if (!isnum(op1) || !isnum(op2)) 
  572.     {printf("div: number required\n"); Fail1;}
  573.     else {
  574. #ifndef OS9
  575.     reset_floatflag;
  576.     set_psw_if_float(op1);
  577.     set_psw_if_float(op2);
  578.     follow(op3) = makenum(numval(op2) / numval(op1));
  579. #else
  580.     if (isinteger(op1))
  581.     {
  582.         if (isinteger(op2))
  583.             follow(op3) = makeint(intval(op2)/intval(op1));
  584.         else follow(op3) = makefloat(floatval(op2)/(double)intval(op1));
  585.     } else
  586.     if (isinteger(op2))
  587.         follow(op3) = makefloat((double)intval(op2)/floatval(op1));
  588.     else follow(op3) = makefloat(floatval(op2)/floatval(op1));
  589. #endif
  590.     };
  591.     goto contcase; 
  592.  
  593.  case putdval00: /* PVR */
  594.     pad;
  595.     op1 = opvarc;
  596.     deref(op1);
  597.     opregc = op1;
  598.     goto contcase;
  599.  
  600.  case putuval00: /* PVR */
  601.     pad;
  602.     op1 = opvarc;
  603.     deref(op1);
  604.     if (((op1&3) != 0) || (op1 < (word)hreg) || (op1 >= (word)le_reg))
  605.     opregc = op1;
  606.     else {follow(op1) = opregc = (word)hreg;
  607.     pushtrail(op1);
  608.     new_heap_free;
  609.     } 
  610.     goto contcase;
  611.  
  612.  case call: /* PW */
  613.     nparse_opPW;
  614.     cpreg = lpcreg;
  615.     psc = (struct psc_rec *)op2;
  616.     goto call_sub;
  617.  
  618.  case allocate: pad; 
  619.     if ((pw)breg < le_reg) op1 = (word)breg;
  620.     else op1 = (word)(le_reg - *(cpreg-5));
  621.     follow(op1) = (word)le_reg;
  622.     follow(op1-4) = (word)cpreg;
  623.     le_reg = (pw)op1; 
  624.     if (le_reg < hreg+100) if (!overflow_f) 
  625.         {overflow_f = 1; lpcreg = set_intercode(2); goto contcase;}
  626.     goto contcase;
  627.  
  628.  case deallocate: pad; 
  629.     cpreg = (byte *)*(pw)(le_reg-1);
  630.     le_reg = *(pw *)le_reg;
  631.     goto contcase;
  632.  
  633.  case proceed: pad; 
  634.     lpcreg = cpreg;
  635.     goto contcase;
  636.  
  637.  case execute: 
  638.     nparse_opPW;
  639.     psc = (struct psc_rec *)op2;
  640.     goto call_sub;
  641.  
  642.  case unexec: /* PWW, builds str on heap, and executes 2nd arg 
  643.         simulates exec(op2(op1(A1,A2,..,An)) 
  644.         for intercepting calls */
  645.     pad; op2word;
  646.     op3 = (word)hreg;    /* save addr of new structure rec */
  647.     new_heap_node(op2); /* set str psc ptr */
  648.     for ( i=1; i<=get_arity((struct psc_rec *)op2); i++) {
  649.     op1 = regc(i);
  650.     unebld: if ((op1 & 3) == 0) {
  651.         nderef(op1, unebld);
  652.         follow(op1) = (word)hreg;
  653.         pushtrail(op1);
  654.         new_heap_free;
  655.         }
  656.     else new_heap_node(op1);
  657.     }
  658.     regc(1) = op3 | CS_TAG; /* ptr to new structure on heap */
  659.     op2word;
  660.     psc = (struct psc_rec *)op2;
  661.     goto call_sub;
  662.  
  663.  case unexeci: /* PWW, builds str on heap with last arg a var, 
  664.         and executes 2nd arg; for interpreting;
  665.         simulates exec(op2(op1(A1,A2,..,An-1,B),B) */
  666.     pad; op2word;
  667.     op3 = (word)hreg;    /* save addr of new structure rec */
  668.     new_heap_node(op2); /* set str psc ptr */
  669.     for ( i=1; i<get_arity((struct psc_rec *)op2); i++) {
  670.     op1 = regc(i);
  671.     unibld: if ((op1 & 3) == 0) {
  672.         nderef(op1, unibld);
  673.         follow(op1) = (word)hreg;
  674.         pushtrail(op1);
  675.         new_heap_free;
  676.         }
  677.     else new_heap_node(op1);
  678.     }
  679.     regc(1) = op3 | CS_TAG; /* ptr to new structure on heap */
  680.     regc(2) = (word)hreg;
  681.     new_heap_free; /* add last field to rec */
  682.     op2word;
  683.     psc = (struct psc_rec *)op2;
  684.     goto call_sub;
  685.  
  686.  case executev: 
  687.     nparse_opPW;
  688.     exun: switch ((int)(op2&3)) {
  689.     case FREE: nderef(op2,exun);
  690.     case NUM: printf("Error: Illegal call\n"); Fail1; goto contcase;
  691.     case CS: psc = get_str_psc(op2); goto call_sub;
  692.     case LIST: psc = list_psc; goto call_sub;
  693.     }
  694.  
  695.     /* pad; pcreg=lpcreg; 
  696.     callv_sub();
  697.     lpcreg=pcreg; break; */
  698.  
  699.  case jump: 
  700.     pad;
  701.     lpcreg = *(byte **)lpcreg;
  702.     goto contcase;
  703.  
  704.  case jumpz:
  705.     op3 = opregc;
  706. #ifndef OS9
  707.     if (numval(op3) == 0)
  708. #else
  709.     if ((isinteger(op3) && intval(op3) == 0) ||
  710.         (isfloat(op3) && floatval(op3) == 0.0))
  711. #endif
  712.     lpcreg = *(byte **)lpcreg;
  713.     else lpcreg+=4;
  714.     goto contcase;
  715.  
  716.  case jumpnz: 
  717.     op3 = opregc;
  718. #ifndef OS9
  719.     if (numval(op3) != 0)
  720. #else
  721.     if ((isinteger(op3) && intval(op3) != 0) ||
  722.         (isfloat(op3) && floatval(op3) != 0.0))
  723. #endif
  724.     lpcreg = *(byte **)lpcreg;
  725.     else lpcreg+=4;
  726.     goto contcase;
  727.  
  728.  case jumplt:
  729.     op3 = opregc;
  730. #ifndef OS9
  731.     if (numval(op3) < 0)
  732. #else
  733.     if ((isinteger(op3) && intval(op3) < 0) ||
  734.         (isfloat(op3) && floatval(op3) < 0.0))
  735. #endif
  736.     lpcreg = *(byte **)lpcreg;
  737.     else lpcreg+=4;
  738.     goto contcase; 
  739.  
  740.  case jumple:
  741.     op3 = opregc;
  742. #ifndef OS9
  743.     if (numval(op3) <= 0)
  744. #else
  745.     if ((isinteger(op3) && intval(op3) <= 0) ||
  746.         (isfloat(op3) && floatval(op3) <= 0.0))
  747. #endif
  748.     lpcreg = *(byte **)lpcreg;
  749.     else lpcreg+=4;
  750.     goto contcase; 
  751.  
  752.  case jumpgt:
  753.     op3 = opregc;
  754. #ifndef OS9
  755.     if (numval(op3) > 0)
  756. #else
  757.     if ((isinteger(op3) && intval(op3) > 0) ||
  758.         (isfloat(op3) && floatval(op3) > 0.0))
  759. #endif
  760.     lpcreg = *(byte **)lpcreg;
  761.     else lpcreg+=4;
  762.     goto contcase;
  763.  
  764.  case jumpge:
  765.     op3 = opregc;
  766. #ifndef OS9
  767.     if (numval(op3) >= 0)
  768. #else
  769.     if ((isinteger(op3) && intval(op3) >= 0) ||
  770.         (isfloat(op3) && floatval(op3) >= 0.0))
  771. #endif
  772.     lpcreg = *(byte **)lpcreg;
  773.     else lpcreg+=4;
  774.     goto contcase; 
  775.  
  776.  case fail: pad;
  777.     Fail1; 
  778.     goto contcase;
  779.  
  780.  case noop: nparse_opB;
  781.     lpcreg += op1;
  782.     lpcreg += op1;
  783.     goto contcase;
  784.  
  785.  case halt: pad;
  786.     printf("\nHalt. Program terminated normally\n");
  787.     exit(0); 
  788.     goto contcase;
  789.  
  790.  case builtin: nparse_opB; pcreg=lpcreg; ereg = le_reg;
  791. /* printf("Builtin# %d\n", (byte)op1); */
  792.     Builtin((byte)op1);
  793.     lpcreg=pcreg; goto contcase;
  794.  
  795.  case calld: 
  796.     pad;
  797.     cpreg = lpcreg+4; 
  798.     lpcreg = *(pb *)lpcreg;
  799.     if (hitrace == 1) 
  800.     printf(" call direct: address %x\n", lpcreg) ;
  801.     goto contcase;
  802.  
  803.  case lshiftr: 
  804.     pad;
  805.     op1 = opregc;
  806.     op3 = opreg;
  807.     op2 = follow(op3);
  808.     deref(op1); 
  809.     deref(op2);
  810.     if (!isinteger(op1) ||!isinteger(op2)) 
  811.     {printf("lshiftr: integer required\n"); Fail1;}
  812.     else follow(op3) = makeint((intval(op2)) >> intval(op1));
  813.     goto contcase; 
  814.  
  815.  case lshiftl: 
  816.     pad;
  817.     op1 = opregc;
  818.     op3 = opreg;
  819.     op2 = follow(op3);
  820.     deref(op1); 
  821.     deref(op2);
  822.     if (!isinteger(op1) || !isinteger(op2)) 
  823.     {printf("lshiftl: integer required\n"); Fail1;}
  824.     else follow(op3) = makeint((intval(op2)) << intval(op1));
  825.     goto contcase; 
  826.  
  827.  case or: 
  828.     pad;
  829.     op1 = opregc;
  830.     op3 = opreg;
  831.     op2 = follow(op3);
  832.     deref(op1); 
  833.     deref(op2);
  834.     if (!isinteger(op1) || !isinteger(op2)) 
  835.     {printf("or: integer required\n"); Fail1;}
  836.     else follow(op3) = makeint(intval(op2) | intval(op1));
  837.     goto contcase; 
  838.  
  839.  case and: 
  840.     pad;
  841.     op1 = opregc;
  842.     op3 = opreg;
  843.     op2 = follow(op3);
  844.     deref(op1); 
  845.     deref(op2);
  846.     if (!isinteger(op1) || !isinteger(op2)) 
  847.     {printf("and: integer required\n"); Fail1;}
  848.     else follow(op3) = makeint(intval(op2) & intval(op1));
  849.     goto contcase; 
  850.  
  851.  case negate: 
  852.     op1 = opregno;
  853.     op2 = regc(op1);
  854.     deref(op2);
  855.     if (!isinteger(op2)) 
  856.     {printf("negate: integer required\n"); Fail1;}
  857.     else regc(op1) = makeint(~intval(op2));
  858.     goto contcase; 
  859.  
  860.  case endfile: nparse_opPW; 
  861.     goto contcase;
  862.  
  863.  case getcon01 :
  864.  case getnil01 :
  865.  case getstr01 :
  866.  case getlist01 :
  867.  case unipvar01 :
  868.  case unipval01 :
  869.  case unitvar01 :
  870.  case unitval01 :
  871.  case unicon01 :
  872.  case uninil01 :
  873.  case putpvar01 :
  874.  case putpval01 :
  875.  case puttvar01 :
  876.  case putcon01 :
  877.  case putnil01 :
  878.  case putstr01 :
  879.  case putlist01 :
  880.  case bldpvar01 :
  881.  case bldpval01 :
  882.  case bldtvar01 :
  883.  case bldtval01 :
  884.  case bldcon01 :
  885.  case bldnil01 :
  886.  case getpvar10 :
  887.  case getpval10 :
  888.  case gettval10 :
  889.  case getcon10 :
  890.  case getnil10 :
  891.  case getstr10 :
  892.  case getlist10 :
  893.  case unicon10 :
  894.  case uninil10 :
  895.  case putpvar10 :
  896.  case putpval10 :
  897.  case puttvar10 :
  898.  case putcon10 :
  899.  case putnil10 :
  900.  case putstr10 :
  901.  case putlist10 :
  902.  case bldpvar10 :
  903.  case bldpval10 :
  904.  case bldtvar10 :
  905.  case bldtval10 :
  906.  case bldcon10 :
  907.  case bldnil10 :
  908.  case getpvar11 :
  909.  case getpval11 :
  910.  case gettval11 :
  911.  case getcon11 :
  912.  case getnil11 :
  913.  case getstr11 :
  914.  case getlist11 :
  915.  case unipvar11 :
  916.  case unipval11 :
  917.  case unitvar11 :
  918.  case unitval11 :
  919.  case unicon11 :
  920.  case uninil11 :
  921.  case putpvar11 :
  922.  case putpval11 :
  923.  case puttvar11 :
  924.  case putcon11 :
  925.  case putnil11 :
  926.  case putstr11 :
  927.  case putlist11 :
  928.  case bldpvar11 :
  929.  case bldpval11 :
  930.  case bldtvar11 :
  931.  case bldtval11 :
  932.  case bldcon11 :
  933.  case bldnil11 :
  934.  
  935.  default: 
  936.     printf("\nIllegal opcode hex %x at %x\n", *--lpcreg, lpcreg); 
  937.     exit(1);
  938.  
  939.  
  940.   } /* end switch */
  941.  }  /*  end main instruction loop */
  942.  
  943.  
  944. nunify: /* ( op1, op2 ) */
  945. /* word op1, op2 */
  946.   switch ((int) (op1 & 3)) {
  947.   case FREE: /* op1 */
  948.     nderef(op1, nunify);
  949.     nunify_with_free: /* op1 is a dereffed free node */
  950.         switch ((int) (op2 & 3)) {
  951.         case FREE:  /* op1 = free var, op2 = free var */
  952.         nderef(op2,  nunify_with_free);
  953.         if ( op1 != op2 ) {
  954.             if ( op1 < op2 ) {
  955.             if ( op1 < (word)hreg )  /* op1 not in loc stack */
  956.                 {follow(op2) = op1;
  957.                  pushtrail(op2);}
  958.             else  /* op1 points to op2 */
  959.                 {follow(op1) = op2;
  960.                  pushtrail(op1);}
  961.             }
  962.             else { /* op1 > op2 */
  963.             if ( op2 < (word)hreg ) 
  964.                 {follow(op1) = op2;
  965.                  pushtrail(op1);}
  966.             else
  967.                 {follow(op2) = op1;
  968.                  pushtrail(op2);}
  969.             }
  970.         }
  971.         break; /* op1=free, op2=free */
  972.         case CS:      /* op1=free, op2=con/str */
  973.         case LIST:      /* op1=free, op2=list */
  974.         case NUM:     /* op1=free, op2=num */
  975.         follow(op1) = op2;
  976.         pushtrail(op1);
  977.         break;    /* op1=free, op2=c/s,list,num */
  978.         }
  979.     break; /* op1=free */
  980.  
  981.   case CS: /* op1=c/s */
  982.     nu2: switch ((int)(op2 & 3)) {
  983.     case FREE:  /* op1=con/str, op2=free */
  984.     nderef(op2, nu2);
  985.     follow(op2) = op1;
  986.     pushtrail(op2);
  987.         break; /* op1=con/str, op2=free */
  988.     case CS:   /* op1=con/str, op2=con/str */
  989.         if (op1 != op2) {    /* a != b */
  990.         untag(op1);
  991.         untag(op2);
  992.         if (follow(op1) != follow(op2)) { /* 0(a) != 0(b) */
  993.         Fail1;
  994.         break; /* op1=c/s, op2=c/s */
  995.         }
  996.         else {
  997.                arity = get_str_arity(op1);
  998.                for ( i=1; i <= arity;  i++ ) 
  999.                  if(!unify(*((pw)op1+i), *((pw)op2+i)))
  1000.             {Fail1; 
  1001.             goto nbreakconcon;} /* break out of BOTH for and case */
  1002.         }
  1003.     }
  1004.         nbreakconcon: break; /* out of con/str, con/str */
  1005.     case LIST:    /* op1 = con/str, op2 = list */
  1006.     case NUM:
  1007.       Fail1;
  1008.       break;
  1009.        /* op1=c/s, op2=list, */
  1010.     } /* end case op1=c/s */
  1011.     break;
  1012.  
  1013.   case LIST:    /* op1=list */
  1014.     nu3: switch ((int)(op2 & 3)) {
  1015.     case FREE:  /* op1=list, op2=free */
  1016.       nderef(op2, nu3);
  1017.       follow(op2) = op1;
  1018.       pushtrail(op2);
  1019.       break; /* op1-list, op2=free */
  1020.     case CS:    /* op1=list, op2=con/str */
  1021.     case NUM:    /* op1=list, op2=num */
  1022.       Fail1;
  1023.       break;    /* op1=list, op2=c/s,num */
  1024.     case LIST:   /* op1=list, op2=list */
  1025.       if (op1 != op2) {
  1026.          untag(op1);
  1027.          untag(op2);
  1028.          if ( !unify(*(pw)op1, *(pw)op2)
  1029.              || !unify( *(((pw)op1)+1), *(((pw)op2)+1) ) )
  1030.         {Fail1; break;}
  1031.      }
  1032.       break; /* op1=list, op2=list */
  1033.     }
  1034.     break; /* op1=list */
  1035.   case NUM:    /* op1=num */
  1036.     nwn: switch ((int)(op2 & 3)) {
  1037.     case FREE:  /* op1=num, op2=free */
  1038.         nderef(op2, nwn);
  1039.         follow(op2) = op1;
  1040.         pushtrail(op2);
  1041.         break; /* op1=num, op2=free */
  1042.         case NUM:   /*op1=num, op2=num */
  1043.         if (op1 == op2) break;        /* op1=num, op2=num */
  1044.         else
  1045. #ifndef OS9
  1046.         if ((isfloat(op1) || isfloat(op2)) &&
  1047.             prettymuch_equal((double)numval(op2), (double)numval(op1))) break;
  1048. #else
  1049.         if ((isfloat(op1) && isinteger(op2) &&
  1050.             prettymuch_equal((double)intval(op2), (double)floatval(op1))) ||
  1051.             (isinteger(op1) && isfloat(op2) &&
  1052.             prettymuch_equal((double)floatval(op2), (double)intval(op1))) ||
  1053.             (isfloat(op1) && isfloat(op2) &&
  1054.             prettymuch_equal((double)floatval(op2), (double)floatval(op1))))
  1055.         break;
  1056. #endif
  1057.     case CS:
  1058.     case LIST:
  1059.         Fail1;
  1060.         break; /* op1=num, op2=c/s,list */
  1061.     }    /* disp on op2 */
  1062.   break; /* disp on op1 */
  1063.   }    /* end of disp on op1 */
  1064.   goto contcase;  /* end of nunify */
  1065.  
  1066.  
  1067. nunify_with_con: /* op1,  op2=(untagged)con */
  1068.     switch((int) (op1 & 3)) {
  1069.     case FREE:  /* op2=(untagged)con, op1=free */
  1070.     nderef(op1, nunify_with_con);
  1071.     follow(op1) = op2 | CS_TAG;
  1072.     pushtrail(op1);
  1073.         break; /* op1=free */
  1074.     case CS:   /* op2=(untagged)con, op1=con/str */
  1075.     untag(op1);
  1076.         if (op1 != op2) {    /* a != b */
  1077.         if (follow(op2) != follow(op1))  /* 0(a) != 0(b) */
  1078.         {Fail1;}
  1079.         /* else must be converted temp const and are same */
  1080.     }
  1081.         break; /* out of con/str, con/str */
  1082.     case LIST:    /* op2 = con/str, op1 = list */
  1083.     case NUM:
  1084.       Fail1;
  1085.       break;
  1086.     } /* end case nunify_with_con */
  1087.     goto contcase;
  1088.  
  1089. nunify_with_int: /* op1 is general, op2 has integer (untagged) */
  1090.      switch ((int) (op1 & 3)) {
  1091.     case FREE:  /* op1=free */
  1092.         nderef(op1, nunify_with_int);
  1093.         follow(op1) = makeint(op2);
  1094.         pushtrail(op1);
  1095.         break; /* op2=num, op1=free */
  1096.         case NUM:   /*op2=num, op1=num */
  1097.         if (isinteger(op1) && (intval(op1) == op2)) break;
  1098.         else if (isfloat(op1) &&
  1099. #ifndef OS9
  1100.                 prettymuch_equal((double)numval(op1), (double)op2))
  1101. #else
  1102.                 prettymuch_equal((double)floatval(op1), (double)op2))
  1103. #endif
  1104.         break;
  1105.     case CS:
  1106.     case LIST:
  1107.         Fail1;
  1108.         break;
  1109.     }    /* disp on op1 */
  1110.   goto contcase; /* end of nunify_with_int */
  1111.  
  1112. nunify_with_float:  /* op1 is general, op2 is tagged float in WAM format */
  1113.     switch ((int) (op1 & 3)) {
  1114.     case FREE:  /* op1=free */
  1115.         nderef(op1, nunify_with_float);
  1116.         follow(op1) = op2;
  1117.         pushtrail(op1);
  1118.         break;  /* op2 = float, op1 = free */
  1119.     case NUM:
  1120. #ifndef OS9
  1121.         if (prettymuch_equal(numval(op1), numval(op2))) break;
  1122. #else
  1123.         if ((isfloat(op1) &&
  1124.             prettymuch_equal((double)floatval(op1), (double)floatval(op2))) ||
  1125.             (isinteger(op1) &&
  1126.             prettymuch_equal((double)intval(op1), (double)floatval(op2))))
  1127.         break;
  1128. #endif
  1129.     case CS:
  1130.     case LIST:
  1131.         Fail1;
  1132.         break;
  1133.     }   /* disp on op1 */
  1134.     goto contcase;  /* end of nunify_with_float */
  1135.  
  1136. nunify_with_nil: /* op1, nil_sym(tagged) */
  1137.   switch((int) (op1 & 3)) {
  1138.     case FREE:  /* op1=free */
  1139.     nderef(op1, nunify_with_nil);
  1140.     follow(op1) = nil_sym;
  1141.     pushtrail(op1);
  1142.         break; /* op1=free */
  1143.     case CS:   /* op1=con/str */
  1144.         if (op1 == nil_sym) break;    /* a == [] */
  1145.     case LIST:
  1146.     case NUM:
  1147.       Fail1;
  1148.       break;
  1149.     } /* end case nunify_with_nil */
  1150.     goto contcase;
  1151.  
  1152.  
  1153. nunify_with_str: /* (op1, op2 as psc_ptr) */
  1154.     /* struct psc_rec *str_ptr; using op2 */
  1155.     switch ((int) (op1 & 3)) {
  1156.     case FREE:
  1157.         nderef(op1, nunify_with_str);
  1158.         follow(op1) = (word)hreg | CS_TAG;
  1159.         pushtrail(op1); /**/
  1160.         new_heap_node(op2);
  1161.         flag = WRITEFLAG;
  1162.         break;
  1163.     case CS:
  1164.         untag(op1);
  1165.         if (follow(op1) == op2) {
  1166.         flag = READFLAG;
  1167.         sreg = ((pw) op1) + 1; /**/
  1168.         break;
  1169.         }
  1170.     case LIST:
  1171.     case NUM:
  1172.         Fail1;
  1173.         break;
  1174.     } /* case for nunify_with_str */
  1175.  
  1176.     goto contcase;
  1177.  
  1178.     
  1179. nunify_with_list_sym: /* (op1) */
  1180.     switch ((int) (op1 & 3)) {
  1181.     case FREE:
  1182.         nderef(op1, nunify_with_list_sym);
  1183.         follow(op1) = (word)hreg | LIST_TAG;
  1184.         pushtrail(op1);
  1185.         flag = WRITEFLAG;
  1186.         break;
  1187.     case CS:
  1188.     case NUM:
  1189.         Fail1;
  1190.         break;
  1191.     case LIST:
  1192.         sreg = (pw)(untagged(op1));
  1193.         flag = READFLAG;
  1194.         break;
  1195.     }   /* end nunify_with_list_sym */
  1196.     goto contcase;
  1197.  
  1198.  
  1199. nbldval:
  1200.     if ((op1 & 3) == 0)
  1201.     {nderef(op1, nbldval);
  1202.      follow(op1) = (word)hreg;
  1203.      pushtrail(op1);
  1204.      new_heap_free;}
  1205.     else new_heap_node(op1);
  1206.     goto contcase;
  1207.     
  1208. subtryme:
  1209. {
  1210.   register word *b;
  1211.   if (breg < le_reg)
  1212.     b = breg;
  1213.   else
  1214.     b = le_reg - *(cpreg - 5) ;  /* 1st arg. of call instruction */
  1215.  
  1216.     if (b < hreg+100) if (!overflow_f) 
  1217.         {overflow_f = 1; lpcreg = set_intercode(2); goto contcase;}
  1218.  
  1219.   for (i = 1; i <= op1; i++)
  1220.     {
  1221.     *b-- = regc(i);
  1222.     /* b = b + 1; */
  1223.     }
  1224.   *b-- = (word)le_reg;
  1225.   *b-- = (word)cpreg;
  1226.   *b-- = (word)trreg;
  1227.   *b-- = (word)hreg;
  1228.   *b-- = (word)breg;
  1229.   *b-- = op2;  /* next process' entry pt. */
  1230.   breg = b; /* next free space was b+6*/
  1231.   hbreg = hreg;}
  1232.   goto contcase; /* end of subtryme */
  1233.   
  1234.  
  1235. rerestore:
  1236. {
  1237.   register word *b;
  1238.   word *oldtr;
  1239.  
  1240.   b = breg + 3;
  1241.   hreg = (pw)*(b);
  1242.   oldtr = (pw)*(++b);
  1243.   while (trreg != oldtr)
  1244.     {
  1245.     top = (pw)(*(++trreg));
  1246.     *(pw *)top = top; 
  1247.     }
  1248.   cpreg = (pb)*(++b);
  1249.   le_reg = (pw)(*(++b));
  1250.   for (i = op1; i >= 1;i--) 
  1251.     {
  1252.     regc(i) = *(++b);
  1253.     /* b = b - 1; */
  1254.     }
  1255.   }
  1256.   goto contcase;
  1257.  
  1258.  
  1259. trrestore:
  1260. {
  1261.   register word *b;
  1262.   word *oldtr;
  1263.  
  1264.   b = breg + 3;
  1265.   hreg = (pw)*(b);
  1266.   oldtr = (pw)*(++b);
  1267.   while (trreg != oldtr)
  1268.     {
  1269.     top = (pw)*(++trreg);
  1270.     *(pw *)top = top; 
  1271.     }
  1272.   cpreg = (pb)*(++b);
  1273.   le_reg = (pw)*(++b);
  1274.   for (i = op1; i >= 1;i--) 
  1275.     {
  1276.     regc(i) = *(++b);
  1277.     }
  1278.   }
  1279.   breg = (pw)*(breg + 2);
  1280.   hbreg = (pw)*(breg + 3);
  1281.   goto contcase;
  1282.  
  1283.  
  1284.  
  1285. call_sub: /* (psc)*/
  1286.  
  1287.   if (interrupt_code > 0) { /* combine with call_intercept check! */
  1288.     build_call(psc);
  1289.     lpcreg = set_intercode(1);
  1290.     interrupt_code = 0;
  1291.     arm_intercept();
  1292.     psc = interrupt_psc;
  1293.   }
  1294.   else if (is_PRED(psc) || is_DYNA(psc)) lpcreg = get_ep(psc);
  1295.   else if (is_BUFF(psc)) lpcreg = (byte *)get_name(psc)+4;
  1296.   else {
  1297.     build_call(psc);
  1298.     lpcreg = set_intercode(0);
  1299.     psc = interrupt_psc;
  1300.   }
  1301.  
  1302.   if (call_intercept) {
  1303.       if (hitrace) {
  1304.          printf("call/exec: ");
  1305.          writepname(stdout, get_name(psc), get_length(psc) );
  1306.          printf("/%d(", get_arity(psc));
  1307.          for (i=1; i <= get_arity(psc); i++) {
  1308.             printterm( regc(i), 1 );
  1309.             if (i < get_arity(psc)) printf(" ");
  1310.          }
  1311.          printf(")\n");
  1312.       }
  1313.       if (trace_sta) {
  1314.     if (hreg > mheaptop) mheaptop = hreg;
  1315.     if (ereg < mlocaltop) mlocaltop = ereg;
  1316.     if (breg < mlocaltop) mlocaltop = breg;
  1317.         if (trreg < mtrailtop) mtrailtop = trreg;
  1318.       }
  1319.   }
  1320.  
  1321.   goto contcase;
  1322.  
  1323.  
  1324. } /* end main */
  1325.  
  1326.