home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / p / plbin.zip / pl / src / pl-wam.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  66KB  |  2,029 lines
  1. /*  pl-wam.c,v 1.8 1993/02/23 13:16:49 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: Virtual machine instruction interpreter
  8. */
  9.  
  10. #include "pl-incl.h"
  11.  
  12. #if sun
  13. #include <prof.h>            /* in-function profiling */
  14. #else
  15. #define MARK(label)
  16. #endif
  17.  
  18. forwards void    copyFrameArguments P((LocalFrame, LocalFrame, int));
  19. forwards inline bool    callForeign P((const Procedure, LocalFrame));
  20. forwards void    leaveForeignFrame P((LocalFrame));
  21.  
  22. #if COUNTING
  23.  
  24. forwards void    countHeader P((void));
  25. forwards void    countArray P((char *, int *));
  26. forwards void    countOne P((char *, int));
  27.  
  28. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  29. The counting code has been added while investigating the  time  critical
  30. WAM  instructions.   I'm afraid it has not been updated correctly since.
  31. Please  check  the  various  counting  macros  and  their  usage  before
  32. including this code.
  33. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  34.  
  35. static
  36. struct
  37. { int i_nop;
  38.   int h_const_n[256];
  39.   int b_const_n[256];
  40.   int h_sint[256];
  41.   int b_sint[256];
  42.   int h_nil;
  43.   int h_var_n[256];
  44.   int b_var_n[256];
  45.   int b_argvar_n[256];
  46.   int h_firstvar_n[256];
  47.   int b_firstvar_n[256];
  48.   int b_argfirstvar_n[256];
  49.   int h_void;
  50.   int b_void;
  51.   int h_functor_n[256];
  52.   int h_list;
  53.   int b_functor_n[256];
  54.   int i_pop;
  55.   int i_pop_n[256];
  56.   int i_enter;
  57.   int i_cut;
  58.   int i_usercall;
  59.   int i_apply;
  60.   int i_depart;
  61.   int i_call;
  62.   int i_exit;
  63. #if O_COMPILE_ARITH
  64.   int a_func0[256];
  65.   int a_func1[256];
  66.   int a_func2[256];
  67.   int a_func[256];
  68.   int a_lt;
  69.   int a_le;
  70.   int a_gt;
  71.   int a_ge;
  72.   int a_eq;
  73.   int a_ne;
  74.   int a_is;
  75. #endif /* O_COMPILE_ARITH */
  76. #if O_COMPILE_OR
  77.   int c_or[256];
  78.   int c_jmp[256];
  79.   int c_mark[256];
  80.   int c_cut[256];
  81.   int c_ifthenelse[512];
  82.   int c_fail;
  83.   int c_end;
  84. #endif /* O_COMPILE_OR */
  85. } counting;
  86.  
  87. forwards void countHeader();
  88. forwards void countOne();
  89. forwards void countArray();
  90.  
  91. word
  92. pl_count()
  93. { countHeader();
  94.   countArray("H_CONST",     counting.h_const_n);  
  95.   countArray("B_CONST",     counting.b_const_n);  
  96.   countArray("B_REAL",         counting.b_real_n);  
  97.   countArray("B_STRING",     counting.b_string_n);  
  98.   countArray("H_SINT",        counting.h_sint);
  99.   countArray("B_SINT",        counting.b_sint);
  100.   countOne(  "H_NIL",         counting.h_nil);
  101.   countArray("H_VAR",         counting.h_var_n);  
  102.   countArray("B_VAR",         counting.b_var_n);  
  103.   countArray("B_ARGVAR",     counting.b_argvar_n);  
  104.   countArray("H_FIRSTVAR",     counting.h_firstvar_n);  
  105.   countArray("B_FIRSTVAR",     counting.b_firstvar_n);  
  106.   countArray("B_ARGFIRSTVAR",     counting.b_argfirstvar_n);  
  107.   countOne(  "H_VOID",         counting.h_void);
  108.   countOne(  "B_VOID",         counting.b_void);
  109.   countArray("H_FUNCTOR",     counting.h_functor_n);  
  110.   countOne(  "H_LIST",         counting.h_list);  
  111.   countArray("B_FUNCTOR",     counting.b_functor_n);  
  112.   countOne(  "I_POP",         counting.i_pop);
  113.   countArray("I_POPN",         counting.i_pop_n);  
  114.   countOne(  "I_ENTER",     counting.i_enter);
  115.   countOne(  "I_CUT",         counting.i_cut);
  116.   countOne(  "I_USERCALL",     counting.i_usercall);
  117.   countOne(  "I_APPLY",     counting.i_apply);
  118.   countOne(  "I_DEPART",     counting.i_depart);
  119.   countOne(  "I_CALL",         counting.i_call);
  120.   countOne(  "I_EXIT",         counting.i_exit);
  121.  
  122.   succeed;
  123. }
  124.  
  125. static void
  126. countHeader()
  127. { int m;
  128.  
  129.   Putf("%13s: ", "Instruction");
  130.   for(m=0; m < 20; m++)
  131.     Putf("%8d", m);
  132.   Putf("\n");
  133.   for(m=0; m<(15+20*8); m++)
  134.     Putf("=");
  135.   Putf("\n");
  136. }  
  137.  
  138. static void
  139. countArray(s, array)
  140. char *s;
  141. int *array;
  142. { int n, m;
  143.  
  144.   for(n=255; array[n] == 0; n--) ;
  145.   Putf("%13s: ", s);
  146.   for(m=0; m <= n; m++)
  147.     Putf("%8d", array[m]);
  148.   Putf("\n");
  149. }
  150.  
  151. static
  152. void
  153. countOne(s, i)
  154. char *s;
  155. int i;
  156. { Putf("%13s: %8d\n", s, i);
  157. }
  158.  
  159. #define COUNT_N(name)  { counting.name[*PC]++; }
  160. #define COUNT_2N(name) { counting.name[*PC]++; counting.name[PC[1]+256]++; }
  161. #define COUNT(name)    { counting.name++; }
  162. #else /* ~COUNTING */
  163. #define COUNT_N(name)
  164. #define COUNT_2N(name)
  165. #define COUNT(name)
  166. #endif /* COUNTING */
  167.  
  168.  
  169.         /********************************
  170.         *         FOREIGN CALLS         *
  171.         *********************************/
  172.  
  173. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  174. Calling foreign predicates.  We will have to  set  `lTop',  compose  the
  175. argument  vector  for  the  foreign  function,  call  it and analyse the
  176. result.  The arguments of the frame are derefenced  here  to  avoid  the
  177. need for explicit dereferencing in most foreign predicates themselves.
  178.  
  179. A foreign predicate can  return  either  the  constant  FALSE  to  start
  180. backtracking,  TRUE to indicate success without alternatives or anything
  181. else.  The return value is saved in the `clause' slot of the frame.   In
  182. this  case  the  interpreter  will  leave a backtrack point and call the
  183. foreign function again with  the  saved  value  as  `backtrack  control'
  184. argument  if  backtracking is needed.  This `backtrack control' argument
  185. is appended to the argument list normally given to the foreign function.
  186. This makes it possible for  foreign  functions  that  do  not  use  this
  187. mechanism  to  ignore it.  For the first call the constant FIRST_CALL is
  188. given as `backtrack control'.
  189. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  190.  
  191. static inline bool
  192. callForeign(proc, frame)
  193. Procedure proc;
  194. register LocalFrame frame;
  195. { int argc = proc->functor->arity;
  196.   word result;
  197.   Word argv[10];
  198.   Func function;
  199.  
  200.   { register Word a, *ap;
  201.     register int n;
  202.  
  203.     a = argFrameP(frame, 0);
  204.     lTop = (LocalFrame) argFrameP(a, argc);
  205.     for(ap = argv, n = argc; n > 0; n--, a++, ap++)
  206.       deRef2(a, *ap)
  207.   }
  208.  
  209.   DEBUG(7, printf("Calling built in %s\n", procedureName(proc)) );
  210.  
  211.   SECURE(
  212.   int n;
  213.   for(n = 0; n < argc; n++)
  214.     checkData(argv[n]);
  215.   );
  216.  
  217.   function = proc->definition->definition.function;
  218.  
  219. #define A(n) argv[n]
  220. #define F (*function)
  221. #define B ((word) frame->clause)
  222.  
  223.   gc_status.blocked++;
  224.   switch(argc)
  225.   { case 0:  result = F(B); break;
  226.     case 1:  result = F(A(0), B); break;
  227.     case 2:  result = F(A(0), A(1), B); break;
  228.     case 3:  result = F(A(0), A(1), A(2), B); break;
  229.     case 4:  result = F(A(0), A(1), A(2), A(3), B); break;
  230.     case 5:  result = F(A(0), A(1), A(2), A(3), A(4), B); break;
  231.     case 6:  result = F(A(0), A(1), A(2), A(3), A(4), A(5), B); break;
  232.     case 7:  result = F(A(0), A(1), A(2), A(3), A(4), A(5), A(6), B); break;
  233.     case 8:  result = F(A(0), A(1), A(2), A(3), A(4), A(5), A(6), A(7),
  234.             B); break;
  235.     case 9:  result = F(A(0), A(1), A(2), A(3), A(4), A(5), A(6), A(7),
  236.             A(8), B); break;
  237.     case 10: result = F(A(0), A(1), A(2), A(3), A(4), A(5), A(6), A(7),
  238.             A(8), A(9), B); break;
  239. #if !mips                /* MIPS doesn't handle that many */
  240.     case 11: result = F(A(0), A(1), A(2), A(3), A(4), A(5), A(6), A(7),
  241.             A(8), A(9), A(10), B); break;
  242.     case 12: result = F(A(0), A(1), A(2), A(3), A(4), A(5), A(6), A(7),
  243.             A(8), A(9), A(10), A(11), B); break;
  244.     case 13: result = F(A(0), A(1), A(2), A(3), A(4), A(5), A(6), A(7),
  245.             A(8), A(9), A(10), A(11), A(12), B); break;
  246.     case 14: result = F(A(0), A(1), A(2), A(3), A(4), A(5), A(6), A(7),
  247.             A(8), A(9), A(10), A(11), A(12), A(13), B); break;
  248.     case 15: result = F(A(0), A(1), A(2), A(3), A(4), A(5), A(6), A(7),
  249.             A(8), A(9), A(10), A(11), A(12), A(13), A(14),
  250.             B); break;
  251. #endif
  252.     default:    return sysError("Too many arguments to foreign function");
  253.   }
  254.   gc_status.blocked--;
  255.  
  256. #undef B
  257. #undef F
  258. #undef A
  259.  
  260.   SECURE(
  261.   int n;
  262.   for(n=0;n<argc; n++)
  263.     checkData(argv[n]);
  264.   );
  265.  
  266.   if ( result == FALSE )
  267.   { frame->clause = NULL;
  268.     fail;
  269.   } else if ( result == TRUE )
  270.   { frame->clause = NULL;
  271.     succeed;
  272.   } else
  273.   { if ( true(proc->definition, NONDETERMINISTIC) )
  274.     { if ( !result & FRG_MASK )
  275.       { warning("Illegal return value from foreign predicate %s: 0x%x",
  276.                     procedureName(proc), result);
  277.     fail;
  278.       }
  279.       frame->clause = (Clause) result;
  280.       succeed;
  281.     }
  282.     warning("Deterministic foreign predicate %s returns 0x%x",
  283.                 procedureName(proc), result);
  284.     fail;
  285.   }
  286. }
  287.  
  288. static void
  289. leaveForeignFrame(fr)
  290. register LocalFrame fr;
  291. { if ( true(fr->procedure->definition, NONDETERMINISTIC) )
  292.   { register Procedure proc = fr->procedure;
  293.     register Func f = proc->definition->definition.function;
  294.     register word context = (word) fr->clause | FRG_CUT;
  295.  
  296. #define U ((Word) NULL)
  297.     DEBUG(5, printf("Cut %s, context = 0x%lx\n", procedureName(proc), context));
  298.     switch(proc->functor->arity)
  299.     { case 0:    (*f)(context);                    return;
  300.       case 1:    (*f)(U, context);                return;
  301.       case 2:    (*f)(U, U, context);                return;
  302.       case 3:    (*f)(U, U, U, context);                return;
  303.       case 4:    (*f)(U, U, U, U, context);            return;
  304.       case 5:    (*f)(U, U, U, U, U, context);            return;
  305.       case 6:    (*f)(U, U, U, U, U, U, context);        return;
  306.       case 7:    (*f)(U, U, U, U, U, U, U, context);        return;
  307.       case 8:    (*f)(U, U, U, U, U, U, U, U, context);        return;
  308.       case 9:    (*f)(U, U, U, U, U, U, U, U, U, context);    return;
  309.       case 10:    (*f)(U, U, U, U, U, U, U, U, U, U, context);    return;
  310.       default:    sysError("Too many arguments (%d) to leaveForeignFrame()");
  311.     }
  312.   }
  313. #undef U
  314. }
  315.  
  316.  
  317.         /********************************
  318.         *          INTERPRETER          *
  319.         *********************************/
  320.  
  321. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  322.              MACHINE REGISTERS
  323.  
  324.   - PROC
  325.     Current procedure running.
  326.   - DEF
  327.     Definition structure of current procedure.
  328.   - PC
  329.     Virtual machine `program counter': pointer to the next byte code  to
  330.     interpret.
  331.   - XR
  332.     External referecence pointer.  Pointer to an  array  holding  atoms, 
  333.     integers,  reals,  strings functors  and  procedures  used  by  the
  334.     current clause.  Each entry of this array is a 4 byte entity (a `word').
  335.   - ARGP
  336.     Argument pointer.  Pointer to the next argument to be matched  (when
  337.     in the clause head) or next argument to be instantiated (when in the
  338.     clause  body).   Saved  and  restored  via  the  argument  stack for
  339.     functors.
  340.   - FR
  341.     Current environment frame
  342.   - BFR
  343.     Frame where execution should continue if  the  current  goal  fails.
  344.     Used by I_CALL and deviates to fill the backtrackFrame slot of a new
  345.     frame and set by various instructions.
  346.   - deterministic
  347.     Last clause has been found deterministically
  348. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  349.  
  350. #define FRAME_FAILED        goto frame_failed
  351. #define CLAUSE_FAILED        goto clause_failed
  352. #define BODY_FAILED        goto body_failed
  353. #define SetBfr(fr)         (BFR = (fr))
  354.  
  355. bool
  356. interpret(Context, Goal, debug)
  357. Module Context;
  358. word Goal;
  359. bool debug;
  360. { register LocalFrame FR;        /* current frame */
  361.   register Word          ARGP;        /* current argument pointer */
  362.   register Code          PC;        /* program counter */
  363.        Word          XR;        /* current external ref. table */
  364.        LocalFrame BFR;        /* last backtrack frame */
  365.          Procedure  PROC;        /* current procedure */  
  366.          Definition DEF;        /* definition of current procedure */
  367.        bool          deterministic;    /* clause found deterministically */
  368. #define              CL (FR->clause)    /* clause of current frame */
  369.  
  370. #if O_LABEL_ADDRESSES
  371.   static void *jmp_table[] =
  372.   { &&I_NOP_LBL,
  373.     &&I_ENTER_LBL,
  374.     &&I_CALL_LBL,
  375.     &&I_DEPART_LBL,
  376.     &&I_EXIT_LBL,
  377.     &&B_FUNCTOR_LBL,
  378.     &&H_FUNCTOR_LBL,
  379.     &&I_POP_LBL,
  380.     &&I_POPN_LBL,
  381.     &&B_VAR_LBL,
  382.     &&H_VAR_LBL,
  383.     &&B_CONST_LBL,
  384.     &&H_CONST_LBL,
  385.     &&H_REAL_LBL,
  386. #if O_STRING
  387.     &&H_STRING_LBL,
  388. #endif /* O_STRING */
  389.  
  390.     &&B_FIRSTVAR_LBL,
  391.     &&H_FIRSTVAR_LBL,
  392.     &&B_VOID_LBL,
  393.     &&H_VOID_LBL,
  394.     &&B_ARGFIRSTVAR_LBL,
  395.     &&B_ARGVAR_LBL,
  396.  
  397.     &&H_NIL_LBL,
  398.     &&H_CONST0_LBL,
  399.     &&H_CONST1_LBL,
  400.     &&H_CONST2_LBL,
  401.  
  402.     &&H_LIST_LBL,
  403.     &&H_FUNCTOR0_LBL,
  404.     &&H_FUNCTOR1_LBL,
  405.     &&H_FUNCTOR2_LBL,
  406.  
  407.     &&B_VAR0_LBL,
  408.     &&B_VAR1_LBL,
  409.     &&B_VAR2_LBL,
  410.  
  411.     &&H_SINT_LBL,
  412.     &&B_SINT_LBL,
  413.  
  414.     &&I_USERCALL_LBL,
  415.     &&I_CUT_LBL,
  416.     &&I_APPLY_LBL,
  417.  
  418. #if O_COMPILE_ARITH
  419.     &&A_FUNC0_LBL,
  420.     &&A_FUNC1_LBL,
  421.     &&A_FUNC2_LBL,
  422.     &&A_FUNC_LBL,
  423.     &&A_LT_LBL,
  424.     &&A_GT_LBL,
  425.     &&A_LE_LBL,
  426.     &&A_GE_LBL,
  427.     &&A_EQ_LBL,
  428.     &&A_NE_LBL,
  429.     &&A_IS_LBL,
  430. #endif /* O_COMPILE_ARITH */
  431.  
  432. #if O_COMPILE_OR
  433.     &&C_OR_LBL,
  434.     &&C_JMP_LBL,
  435.     &&C_MARK_LBL,
  436.     &&C_CUT_LBL,
  437.     &&C_IFTHENELSE_LBL,
  438.     &&C_VAR_LBL,
  439.     &&C_END_LBL,
  440.     &&C_NOT_LBL,
  441.     &&C_FAIL_LBL,
  442. #endif /* O_COMPILE_OR */
  443.  
  444.     &&B_REAL_LBL,
  445.     &&B_STRING_LBL
  446.   };
  447.  
  448. #define VMI(Name, Count, Msg)    Name ## _LBL: Count; DEBUG(8, printf Msg);
  449. #if O_VMCODE_IS_ADDRESS
  450. #define NEXT_INSTRUCTION    goto *(void *)((int)(*PC++))
  451. #else
  452. #define NEXT_INSTRUCTION    goto *jmp_table[*PC++]
  453. #endif
  454.  
  455. #else /* O_LABEL_ADDRESSES */
  456.  
  457. #define VMI(Name, Count, Msg)    case Name: Count; DEBUG(8, printf Msg);
  458. #define NEXT_INSTRUCTION    goto next_instruction
  459.  
  460. #endif /* O_LABEL_ADDRESSES */
  461.  
  462. #if O_VMCODE_IS_ADDRESS
  463.   interpreter_jmp_table = jmp_table;    /* make it globally known */
  464.  
  465. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  466. If the assertion below fails, addresses cannot be  stored in VM codes.
  467. Add #define O_VMCODE_IS_ADDRESS 0 to your md.h file.
  468. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  469.  
  470.   DEBUG(0, { int i;
  471.  
  472.          for(i=0; i<=I_HIGHEST; i++)
  473.            assert((long) jmp_table[i] >= (1 << (sizeof(code)*8)));
  474.        });
  475. #endif /* O_VMCODE_IS_ADDRESS */
  476.  
  477.   DEBUG(1, { extern int Output;        /* --atoenne-- */
  478.          if ( Output )
  479.          { Putf("Interpret: ");
  480.            pl_write(&Goal);
  481.            Putf("\n");
  482.          } else
  483.            printf("Interpret goal in unitialized environment.\n");
  484.        });
  485.  
  486.   /* Allocate a local stack frame */
  487.  
  488.   FR = lTop;
  489.   FR->parent = (LocalFrame) NULL;
  490.  
  491. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  492. Find the procedure definition associated with `Goal'.
  493. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  494.  
  495.   { Word gp;
  496.     word g;
  497.     Module module = Context;
  498.     FunctorDef functor;
  499.  
  500.     if ((gp = stripModule(&Goal, &module)) == (Word) NULL)
  501.       fail;
  502.  
  503.     g = *gp;
  504.     if ( isAtom(g) )
  505.     { functor = lookupFunctorDef((Atom)g, 0);
  506.     } else if ( isTerm(g) )
  507.     { int arity;
  508.       Word a, args = argTermP(g, 0);
  509.  
  510.       functor = functorTerm(g);
  511.       arity = functor->arity;
  512.       ARGP = argFrameP(FR, 0);
  513.  
  514.       for(; arity-- > 0; args++)
  515.       { deRef2(args, a);
  516.     *ARGP++ = (isVar(*a) ? makeRef(a) : *a);
  517.       }
  518.     } else
  519.       return warning("Illegal goal while called from C");
  520.  
  521.     PROC = resolveProcedure(functor, module);
  522.     DEF = PROC->definition;
  523.  
  524. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  525. Finally fill all the slots of  the  frame  and  initialise  the  machine
  526. registers.
  527. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  528.  
  529.     FR->context = (true(DEF, TRANSPARENT) ? module : DEF->module);
  530.     clearFlags(FR);
  531.     setLevelFrame(FR, !parentFrame(FR) ? 0L : levelFrame(parentFrame(FR)) + 1);
  532.     if ( !debug )
  533.       set(FR, FR_NODEBUG);
  534.     FR->backtrackFrame = (LocalFrame) NULL;
  535.     FR->procedure = PROC;
  536.     FR->clause = (Clause) NULL;
  537.     SetBfr(FR);
  538.     Mark(FR->mark);
  539.     environment_frame = FR;
  540.  
  541.     if ( (CL = DEF->definition.clauses) == (Clause) NULL )
  542.     { trapUndefined(PROC);
  543.       DEF = PROC->definition;        /* may have changed! */
  544.     }
  545.  
  546.     if ( debugstatus.debugging )
  547.     { LocalFrame lTopSave = lTop;
  548.       int action;
  549.  
  550.       lTop = (LocalFrame) argFrameP(FR, PROC->functor->arity);
  551.       action = tracePort(FR, CALL_PORT);
  552.       lTop = lTopSave;
  553.       switch(action)
  554.       { case ACTION_FAIL:    fail;
  555.     case ACTION_IGNORE:    succeed;
  556.       }
  557.     }
  558.  
  559.     if ( true(DEF, FOREIGN) )
  560.     { FR->clause = FIRST_CALL;
  561.  
  562.       return callForeign(PROC, FR);
  563.     }
  564.  
  565.     ARGP = argFrameP(FR, 0);
  566.     if ( (CL = findClause(CL, ARGP, DEF, &deterministic)) == NULL )
  567.       fail;
  568.     if ( deterministic )
  569.       set(FR, FR_CUT);
  570.     CL->references++;
  571.     PC = CL->codes;
  572.     XR = CL->externals;
  573.     lTop = (LocalFrame) argFrameP(FR, CL->variables);
  574.   }
  575.  
  576. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  577. Main entry of the virtual machine cycle.  A branch to `next instruction'
  578. will  cause  the  next  instruction  to  be  interpreted.   All  machine
  579. registers  should  hold  valid  data  and  the  machine stacks should be
  580. initialised properly.
  581. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  582.  
  583. #if O_LABEL_ADDRESSES
  584.   NEXT_INSTRUCTION;
  585. #else
  586. next_instruction:
  587.   switch( *PC++ )
  588. #endif
  589.   { VMI(I_NOP, COUNT(i_nop), ("i_nop\n"))
  590.     NEXT_INSTRUCTION;
  591.  
  592. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  593. An atomic constant in the head  of  the  clause.   ARGP  points  to  the
  594. current  argument  to be matched.  ARGP is derefenced and unified with a
  595. constant from the external reference array XR.
  596. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  597.  
  598.   { word c;
  599.     register Word k;                    MARK(HCONST);
  600.  
  601.     VMI(H_CONST,    COUNT_N(h_const_n),    ("h_const %d\n", *PC))
  602.     c = XR[*PC++];
  603.     goto common_hconst;
  604.     VMI(H_CONST0,    COUNT(h_const_n[0]),    ("h_const 0\n"))
  605.     c = XR[0];
  606.     goto common_hconst;
  607.     VMI(H_CONST1,    COUNT(h_const_n[1]),    ("h_const 1\n"))
  608.         c = XR[1];
  609.     goto common_hconst;
  610.     VMI(H_CONST2,    COUNT(h_const_n[2]),    ("h_const 2\n"))
  611.         c = XR[2];
  612.         goto common_hconst;
  613.     VMI(H_SINT,        COUNT_N(h_sint),    ("h_sint %d\n", *PC))
  614.         c = consNumFromCode(*PC++);
  615.         goto common_hconst;
  616.     VMI(H_NIL,        COUNT(h_nil),        ("h_nil\n"))
  617.         c = (word) ATOM_nil;
  618.  
  619.   common_hconst:
  620.         deRef2(ARGP++, k);
  621.         if (isVar(*k))
  622.     { Trail(k);
  623.       *k = c;
  624.       NEXT_INSTRUCTION;
  625.     }
  626.         if (*k == c)
  627.       NEXT_INSTRUCTION;
  628.         CLAUSE_FAILED;
  629.   }
  630.  
  631. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  632. Real in the head. This is unlikely, but some poeple seem to use it. We have
  633. to copy the real on the global stack as the user might retract the clause:
  634. (this is a bit silly programming, but it should not crash)
  635.     x(3.4).
  636.     run :- x(X), retractall(x(_)), Y is X * 2, assert(x(Y)).
  637. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  638.  
  639.     VMI(H_REAL, COUNT(h_real), ("h_real %d\n", *PC))    MARK(HREAL);
  640.       { register Word k;
  641.  
  642.     deRef2(ARGP++, k);
  643.     if (isVar(*k))
  644.     { Trail(k);
  645.       *k = globalReal(valReal(XR[*PC++]));
  646.       NEXT_INSTRUCTION;
  647.     }
  648.     if (isReal(*k) && valReal(*k) == valReal(XR[*PC++]))
  649.       NEXT_INSTRUCTION;
  650.     CLAUSE_FAILED;
  651.       }
  652.  
  653. #if O_STRING
  654. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  655. String in the head. See H_REAL and H_CONST for details.
  656. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  657.  
  658.     VMI(H_STRING, COUNT(h_string), ("h_string %d\n", *PC)) MARK(HSTR);
  659.       { register Word k;
  660.  
  661.     deRef2(ARGP++, k);
  662.     if (isVar(*k))
  663.     { word str = XR[*PC++];
  664.       Trail(k);
  665.       *k = globalString(valString(str));
  666.       NEXT_INSTRUCTION;
  667.     }
  668.     if ( isString(*k) )
  669.     { word str = XR[*PC++];
  670.       if ( equalString(*k, str) )
  671.         NEXT_INSTRUCTION;
  672.     }
  673.     CLAUSE_FAILED;
  674.       }
  675. #endif /* O_STRING */
  676.  
  677. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  678. An atomic constant in the body of  a  clause.   We  know  that  ARGP  is
  679. pointing  to  a  not  yet  instantiated  argument  of the next frame and
  680. therefore can just fill the argument.  Trailing is not needed as this is
  681. above the stack anyway.
  682. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  683.     VMI(B_CONST, COUNT_N(b_const_n), ("b_const %d\n", *PC)) MARK(BCONST);
  684.       { *ARGP++ = XR[*PC++];
  685.     NEXT_INSTRUCTION;
  686.       }
  687.  
  688. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  689. B_REAL and B_STRING need to copy the value on the global  stack  because
  690. the XR-table might be freed due to a retract.  We should write fast copy
  691. algorithms,   especially   for   the   expensive   globalReal(valReal())
  692. construct.
  693. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  694.     VMI(B_REAL, COUNT_N(b_real_n), ("b_real %d\n", *PC)) MARK(BREAL);
  695.       { *ARGP++ = globalReal(valReal(XR[*PC++]));
  696.     NEXT_INSTRUCTION;
  697.       }
  698.  
  699.     VMI(B_STRING, COUNT_N(b_string_n), ("b_string %d\n", *PC)) MARK(BSTRING);
  700.       { *ARGP++ = globalString(valString(XR[*PC++]));
  701.     NEXT_INSTRUCTION;
  702.       }
  703.  
  704. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  705. A small integer in the body. As B_CONST.
  706. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  707.     VMI(B_SINT, COUNT_N(b_sint), ("b_sint %d\n", *PC)) MARK(B_SINT);
  708.       { *ARGP++ = consNumFromCode(*PC++);
  709.     NEXT_INSTRUCTION;
  710.       }
  711. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  712. A variable in the head which is not an anonymous one and is not used for
  713. the first time.  Invoke general unification between the argument pointer
  714. and the variable, whose offset is given relative to  the  frame.   Note:
  715. this once was done in place to avoid a function call.  It turns out that
  716. using a function call is faster (at least on SUN_3).
  717. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  718.     VMI(H_VAR, COUNT_N(h_var_n), ("h_var %d\n", *PC)) MARK(HVAR);
  719.       { if (unify(varFrameP(FR, *PC++), ARGP++) )
  720.       NEXT_INSTRUCTION;
  721.     CLAUSE_FAILED;
  722.       }
  723. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  724. A variable in the body which is not an anonymous one, is  not  used  for
  725. the  first  time  and is nested in a term (with B_FUNCTOR).  We now know
  726. that *ARGP is a variable,  so  we  either  copy  the  value  or  make  a
  727. reference.   The  difference between this one and B_VAR is the direction
  728. of the reference link in case *k turns out to be variable.
  729. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  730.     VMI(B_ARGVAR, COUNT_N(b_argvar_n), ("b_argvar %d\n", *PC)) MARK(BAVAR);
  731.       { register Word k;
  732.  
  733.     deRef2(varFrameP(FR, *PC++), k);    
  734.     if (isVar(*k))
  735.     { if (ARGP < k)
  736.       { setVar(*ARGP);
  737.         Trail(k);
  738.         *k = makeRef(ARGP++);
  739.         NEXT_INSTRUCTION;
  740.       }
  741.       *ARGP++ = makeRef(k);        /* both on global stack! */
  742.       NEXT_INSTRUCTION;      
  743.     }
  744.     *ARGP++ = *k;
  745.  
  746.     NEXT_INSTRUCTION;
  747.       }
  748. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  749. A variable in the body which is not an anonymous one and is not used for
  750. the first time.  We now know that *ARGP is a variable, so we either copy
  751. the value or make a reference.  Trailing is not needed as we are writing
  752. above the stack.
  753. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  754.  
  755. #define BODY_VAR(n)   { register Word k; \
  756.             deRef2(varFrameP(FR, (n)), k); \
  757.             *ARGP++ = (isVar(*k) ? makeRef(k) : *k); \
  758.             NEXT_INSTRUCTION; \
  759.               }
  760.     VMI(B_VAR, COUNT_N(b_var_n), ("b_var %d\n", *PC)) MARK(BVARN);
  761.       BODY_VAR(*PC++);
  762.     VMI(B_VAR0, COUNT(b_var_n[9]), ("b_var 9\n")) MARK(BVAR0);
  763.       BODY_VAR(ARGOFFSET / sizeof(word));
  764.     VMI(B_VAR1, COUNT(b_var_n[10]), ("b_var 10\n")) MARK(BVAR1);
  765.       BODY_VAR(1 + ARGOFFSET / sizeof(word));
  766.     VMI(B_VAR2, COUNT(b_var_n[11]), ("b_var 11\n")) MARK(BVAR2);
  767.       BODY_VAR(2 + ARGOFFSET / sizeof(word));
  768.  
  769. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  770. A variable in the head, which is not anonymous, but encountered for  the
  771. first  time.  So we know that the variable is still a variable.  Copy or
  772. make a reference.  Trailing is not needed as  we  are  writing  in  this
  773. frame.
  774. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  775.     VMI(H_FIRSTVAR, COUNT_N(h_firstvar_n), ("h_firstvar %d\n", *PC))
  776.       MARK(HFVAR);
  777.       { varFrame(FR, *PC++) = (isVar(*ARGP) ? makeRef(ARGP++)
  778.                            : *ARGP++);
  779.     NEXT_INSTRUCTION;
  780.       }
  781. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  782. A variable in the body nested in a term, encountered for the first time.
  783. We now know both *ARGP and the variable are variables.  ARGP  points  to
  784. the  argument  of  a  term  on  the  global stack.  The reference should
  785. therefore go from k to ARGP.
  786. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  787.     VMI(B_ARGFIRSTVAR, COUNT_N(b_argfirstvar_n), ("b_argfirstvar %d\n", *PC))
  788.       MARK(BAFVAR);
  789.       { setVar(*ARGP);
  790.     varFrame(FR, *PC++) = makeRef(ARGP++);
  791.     NEXT_INSTRUCTION;
  792.       }
  793. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  794. A variable in the body, encountered for the first  time.   We  now  know
  795. both  *ARGP and the variable are variables.  We set the variable to be a
  796. variable (it is uninitialised memory) and make a reference.  No trailing
  797. needed as we are writing in this and the next frame.
  798. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  799.     VMI(B_FIRSTVAR, COUNT_N(b_firstvar_n), ("b_firstvar %d\n", *PC))
  800.       MARK(BFVAR);
  801.       { register Word k = varFrameP(FR, *PC++);
  802.  
  803.     setVar(*k);
  804.     *ARGP++ = makeRef(k);
  805.     NEXT_INSTRUCTION;
  806.       }
  807. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  808. A singleton variable in the head.  Just increment the argument  pointer.
  809. Also generated for non-singleton variables appearing on their own in the
  810. head  and  encountered  for  the  first  time.   Note  that the compiler
  811. suppresses H_VOID when there are no other instructions before I_ENTER or
  812. I_EXIT.
  813. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  814.     VMI(H_VOID, COUNT(h_void), ("h_void\n")) MARK(HVOID);
  815.       { ARGP++;
  816.     NEXT_INSTRUCTION;
  817.       }
  818. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  819. A singleton variable in the body. Ensure the argument is a variable.
  820. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  821.     VMI(B_VOID, COUNT(b_void), ("b_void\n")) MARK(BVOID);
  822.       { setVar(*ARGP++);
  823.     NEXT_INSTRUCTION;
  824.       }
  825. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  826. A functor in the head.  If the current argument is a  variable  we  will
  827. instantiate  it  with  a  new  term,  all  whose  arguments  are  set to
  828. variables.  Otherwise we check the functor  definition.   In  both  case
  829. ARGP  is  pushed  on the argument stack and set to point to the leftmost
  830. argument of the  term.   Note  that  the  instantiation  is  trailed  as
  831. dereferencing might have caused we are now pointing in a parent frame or
  832. the global stack (should we check?  Saves trail! How often?).
  833. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  834.  
  835.     VMI(H_FUNCTOR, COUNT_N(h_functor_n), ("h_functor %d\n", *PC))
  836.       MARK(HFUNC);
  837.       { register FunctorDef fdef;
  838.  
  839.     fdef = (FunctorDef) XR[*PC++];
  840.  
  841.     common_functor:
  842.     *aTop++ = ARGP + 1;
  843.     verifyStack(argument);
  844.         deRef(ARGP);
  845.     if (isVar(*ARGP) )
  846.     { Trail(ARGP);
  847.       *ARGP = globalFunctor(fdef);
  848.       ARGP = argTermP(*ARGP, 0);
  849.       NEXT_INSTRUCTION;
  850.     }
  851.     if (isTerm(*ARGP) && functorTerm(*ARGP) == fdef)
  852.     { ARGP = argTermP(*ARGP, 0);
  853.       NEXT_INSTRUCTION;
  854.     }
  855.     CLAUSE_FAILED;        
  856.     VMI(H_FUNCTOR0, COUNT(h_functor_n[0]), ("h_functor 0\n")) MARK(HFUNC0);
  857.     fdef = (FunctorDef) XR[0];
  858.     goto common_functor;
  859.     VMI(H_FUNCTOR1, COUNT(h_functor_n[1]), ("h_functor 0\n")) MARK(HFUNC1);
  860.     fdef = (FunctorDef) XR[1];
  861.     goto common_functor;
  862.     VMI(H_FUNCTOR2, COUNT(h_functor_n[2]), ("h_functor 0\n")) MARK(HFUNC2);
  863.     fdef = (FunctorDef) XR[2];
  864.     goto common_functor;
  865.     VMI(H_LIST, COUNT(h_list), ("h_list\n")) MARK(HLIST);
  866.     *aTop++ = ARGP + 1;
  867.     verifyStack(argument);
  868.     deRef(ARGP);
  869.     if (isVar(*ARGP) )
  870.     { STACKVERIFY( if (gTop + 3 > gMax) outOf((Stack)&stacks.global) );
  871.       Trail(ARGP);
  872.       *ARGP = (word) gTop;
  873.       *gTop++ = (word) FUNCTOR_dot2;
  874.       ARGP = gTop;
  875.       setVar(*gTop++);
  876.       setVar(*gTop++);
  877.       NEXT_INSTRUCTION;
  878.     }
  879.     if ( isList(*ARGP) )
  880.     { ARGP = argTermP(*ARGP, 0);
  881.       NEXT_INSTRUCTION;
  882.     }
  883.     CLAUSE_FAILED;
  884.       }
  885.  
  886. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  887. A functor in the body.  As we don't expect ARGP to point to  initialised
  888. memory  while  in  body  mode  we  just  allocate  the  term,  but don't
  889. initialise the arguments to variables.  Allocation is done in  place  to
  890. avoid a function call.
  891. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  892.     VMI(B_FUNCTOR, COUNT_N(b_functor_n), ("b_functor %d\n", *PC)) MARK(BFUNC);
  893.       { register FunctorDef fdef = (FunctorDef) XR[*PC++];
  894.  
  895.     *ARGP = (word) gTop;
  896.     *aTop++ = ++ARGP;
  897.     verifyStack(argument);
  898.     *gTop++ = (word) fdef;
  899.     ARGP = gTop;
  900.     gTop += fdef->arity;
  901.     verifyStack(global);
  902.  
  903.     NEXT_INSTRUCTION;
  904.       }
  905. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  906. Pop the saved argument pointer (see H_FUNCTOR and B_FUNCTOR).
  907. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  908.  
  909.     VMI(I_POP, COUNT(i_pop), ("pop\n")) MARK(POP);
  910.       { ARGP = *--aTop;
  911.     NEXT_INSTRUCTION;
  912.       }
  913.     VMI(I_POPN, COUNT_N(i_pop_n), ("popn %d\n", *PC)) MARK(POPN);
  914.       { aTop -= *PC++;
  915.     ARGP = *aTop;
  916.     NEXT_INSTRUCTION;
  917.       }
  918.  
  919. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  920. Enter the body of the clause.  This  instruction  is  left  out  if  the
  921. clause  has no body.  The basic task of this instruction is to move ARGP
  922. from the argument part of this frame into the argument part of the child
  923. frame to be built.  `BFR' (the last frame with alternatives) is  set  to
  924. this   frame   if   this   frame  has  alternatives,  otherwise  to  the
  925. backtrackFrame of this frame.
  926.  
  927. If this frame has no alternatives it is possible to  put  the  backtrack
  928. frame  immediately  on  the backtrack frame of this frame.  This however
  929. makes debugging much more  difficult  as  the  system  will  do  a  deep
  930. backtrack without showing the fail ports explicitely.
  931. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  932.     VMI(I_ENTER, COUNT(i_enter), ("enter\n")) MARK(ENTER);
  933.       { ARGP = argFrameP(lTop, 0);
  934.  
  935.     if ( debugstatus.debugging )
  936.     { tracePort(FR, UNIFY_PORT);
  937.       SetBfr(FR);
  938.     } else
  939.     { if ( true(FR, FR_CUT ) )
  940.       { SetBfr(FR->backtrackFrame);
  941.       } else
  942.       { SetBfr(FR);
  943.       }
  944.     }
  945.  
  946.     NEXT_INSTRUCTION;
  947.       }
  948. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  949. !. Basic task is to mark the frame, telling it  is  cut  off,  restoring
  950. `BFR'  to the backtrack frame of this frame (this, nor one of the childs
  951. has alternatives left due to the cut).  `lTop'  is  set  to  point  just
  952. above this frame, as all childs can be abbandoned now.
  953.  
  954. After the cut all child frames with alternatives and their parents  that
  955. are childs of this frame become garbage.  The interpreter will visit all
  956. these  frames  and  decrease the references of the clauses referenced by
  957. the Prolog goals.
  958.  
  959. If the debugger is on we change the backtrack frame to this frame rather
  960. than to the  backtrackframe  of  the  current  frame  to  avoid  a  long
  961. backtrack that makes it difficult to understand the tracer's output.
  962. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  963.     i_cut:            /* from I_USERCALL */
  964.     VMI(I_CUT, COUNT(i_cut), ("cut frame %d\n", REL(FR))) MARK(CUT);
  965.       { LocalFrame fr;
  966.     register LocalFrame fr2;
  967.  
  968.     set(FR, FR_CUT);
  969.     for(fr = BFR; fr > FR; fr = fr->backtrackFrame)
  970.     { for(fr2 = fr; fr2->clause && fr2 > FR; fr2 = fr2->parent)
  971.       { DEBUG(3, printf("discard %d\n", (Word)fr2 - (Word)lBase) );
  972.         leaveFrame(fr2);
  973.         fr2->clause = (Clause) NULL;
  974.       }
  975.     }
  976.     SetBfr(debugstatus.debugging ? FR : FR->backtrackFrame);
  977.  
  978.     DEBUG(3, printf("BFR = %d\n", (Word)BFR - (Word)lBase) );
  979.     lTop = (LocalFrame) argFrameP(FR, CL->variables);
  980.     ARGP = argFrameP(lTop, 0);
  981.  
  982.     NEXT_INSTRUCTION;
  983.       }
  984.  
  985. #if O_COMPILE_OR
  986. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  987. WAM support for ``A ; B'', ``A -> B'' and ``A -> B ; C'' constructs.  As
  988. these functions introduce control within the WAM instructions  they  are
  989. tagged `C_'.
  990. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  991.  
  992. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  993. C_JMP skips the amount stated in the pointed XR table value.   The  PC++
  994. could be compiled out, but this is a bit more neath.
  995. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  996.     VMI(C_JMP, COUNT_N(c_jmp), ("c_jmp %d\n", *PC)) MARK(C_JMP);
  997.       { PC += *PC;
  998.     PC++;
  999.  
  1000.     NEXT_INSTRUCTION;
  1001.       }
  1002.  
  1003. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1004. C_MARK saves the value of BFR (current backtrack frame) into a local
  1005. frame slot reserved by the compiler. 
  1006. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1007.    VMI(C_MARK, COUNT_N(c_mark), ("c_mark %d\n", *PC)) MARK(C_MARK);
  1008.       { varFrame(FR, *PC++) = (word) BFR;
  1009.  
  1010.     NEXT_INSTRUCTION;
  1011.       }
  1012.  
  1013. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1014. C_VAR is generated by the compiler to ensure the  instantiation  pattern
  1015. of  the  variables  is  the  same after finishing both paths of the `or'
  1016. wired in the clause.  Its task is to make the n-th variable slot of  the
  1017. current frame to be a variable.
  1018. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1019.    VMI(C_VAR, COUNT_N(c_var), ("c_var %d\n", *PC)) MARK(C_VAR);
  1020.       { setVar(varFrame(FR, *PC++));
  1021.  
  1022.     NEXT_INSTRUCTION;
  1023.       }
  1024.  
  1025. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1026. C_CUT will  destroy  all  backtrack  points  created  after  the  C_MARK
  1027. instruction in this clause.  It assumes the value of BFR has been stored
  1028. in the nth-variable slot of the current local frame.
  1029.  
  1030. If the saved backtrack point is older than the current  frame  use  this
  1031. frame  as  basis.   This  avoids  us to dereference the currently active
  1032. frame.
  1033.  
  1034. All frames created since what becomes now the  backtrack  point  can  be
  1035. discarded.
  1036. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1037.     VMI(C_CUT, COUNT_N(c_cut), ("c_cut %d\n", *PC)) MARK(C_CUT);
  1038.       { LocalFrame obfr = (LocalFrame) varFrame(FR, *PC++);
  1039.     LocalFrame fr;
  1040.     register LocalFrame fr2;
  1041.  
  1042.     if ( obfr < FR )
  1043.       obfr = FR;
  1044.  
  1045.     for(fr = BFR; fr > obfr; fr = fr->backtrackFrame)
  1046.     { for(fr2 = fr; fr2->clause && fr2 > obfr; fr2 = fr2->parent)
  1047.       { DEBUG(3, printf("discard %d: ", (Word)fr2 - (Word)lBase) );
  1048.         DEBUG(3, writeFrameGoal(fr2, 2); pl_nl() );
  1049.         leaveFrame(fr2);
  1050.         fr2->clause = (Clause) NULL;
  1051.       }
  1052.     }
  1053.  
  1054.         SetBfr(obfr);
  1055.     DEBUG(3, Putf("BFR at "); writeFrameGoal(BFR, 2); pl_nl() );
  1056.     { int nvar = (true(BFR->procedure->definition, FOREIGN)
  1057.                 ? BFR->procedure->functor->arity
  1058.                 : BFR->clause->variables);
  1059.       lTop = (LocalFrame) argFrameP(BFR, nvar);
  1060.       ARGP = argFrameP(lTop, 0);
  1061.     }
  1062.  
  1063.         NEXT_INSTRUCTION;
  1064.       }
  1065.  
  1066. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1067. C_END is a dummy instruction to help the decompiler to fin the end of  A
  1068. ->  B.  (Note  that  a  :-  (b  ->  c),  d == a :- (b -> c, d) as far as
  1069. semantics.  They are different terms however.
  1070. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1071.    VMI(C_END, COUNT(c_end), ("c_end\n")) MARK(C_END);
  1072.       {    NEXT_INSTRUCTION;
  1073.       }
  1074.  
  1075. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1076. C_FAIL is equivalent to fail/0. Used to implement \+/1.
  1077. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1078.    VMI(C_FAIL, COUNT(c_fail), ("c_fail\n")) MARK(C_FAIL);
  1079.       {    BODY_FAILED;
  1080.       }
  1081. #endif /* O_COMPILE_OR */
  1082.  
  1083. #if O_COMPILE_ARITH
  1084. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1085. Arithmic is compiled using a stack  machine.   ARGP  is  used  as  stack
  1086. pointer and the stack is arithmic stack is allocated on top of the local
  1087. stack,  starting  at  the  argument  field of the next slot of the stack
  1088. (where ARGP points to when processing the body anyway).
  1089.  
  1090. Arguments to functions are pushed on the stack  starting  at  the  left,
  1091. thus `add1(X, Y) :- Y is X + 1' translates to:
  1092.  
  1093.     I_ENTER    % enter body
  1094.     B_VAR 0    % push X via ARGP
  1095.     B_CONST 0    % push `1' via ARGP
  1096.     A_FUNC2 N    % execute arithmic function 'N' (+/2), leaving X+1 on
  1097.         % the stack
  1098.     A_IS 1    % unify top of stack ('X+1') with Y
  1099.     EXIT    % leave the clause
  1100.  
  1101. a_func0:    % executes arithmic function without arguments, pushing
  1102.         % its value on the stack
  1103. a_func1:    % unary function. Changes the top of the stack.
  1104. a_func2:    % binary function. Pops two values and pushes one.
  1105.  
  1106. Note that we do not call `ar_func0(*PC++, &ARGP)' as ARGP is a register
  1107. variable.  Also, for compilers that do register allocation it is unwise
  1108. to give the compiler a hint to put ARGP not into a register.
  1109. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1110.  
  1111.     VMI(A_FUNC0, COUNT_N(a_func0), ("a_func0 %d\n", *PC)) MARK(A_FUNC0);
  1112.       {    Word argp = ARGP;
  1113.     if ( ar_func_n(*PC++, 0, &argp) == FALSE )
  1114.       BODY_FAILED;
  1115.     ARGP = argp;
  1116.                 DEBUG(8, printf("ARGP = 0x%x; top = ", ARGP);
  1117.                      pl_write(ARGP-1);
  1118.                      printf("\n"));
  1119.     NEXT_INSTRUCTION;
  1120.       }
  1121.  
  1122.     VMI(A_FUNC1, COUNT_N(a_func1), ("a_func1 %d\n", *PC)) MARK(A_FUNC1);
  1123.       {    Word argp = ARGP;
  1124.     if ( ar_func_n(*PC++, 1, &argp) == FALSE )
  1125.       BODY_FAILED;
  1126.     ARGP = argp;
  1127.                 DEBUG(8, printf("ARGP = 0x%x; top = ", ARGP);
  1128.                      pl_write(ARGP-1);
  1129.                      printf("\n"));
  1130.     NEXT_INSTRUCTION;
  1131.       }
  1132.  
  1133.     VMI(A_FUNC2, COUNT_N(a_func2), ("a_func2 %d\n", *PC)) MARK(A_FUNC2);
  1134.       {    Word argp = ARGP;
  1135.                 DEBUG(8, printf("ARGP = 0x%x; top = ", ARGP);
  1136.                      pl_write(ARGP-2); printf(" & ");
  1137.                      pl_write(ARGP-1);
  1138.                      printf("\n"));
  1139.     if ( ar_func_n(*PC++, 2, &argp) == FALSE )
  1140.       BODY_FAILED;
  1141.     ARGP = argp;
  1142.                 DEBUG(8, printf("ARGP = 0x%x; top = ", ARGP);
  1143.                      pl_write(ARGP-1);
  1144.                      printf("\n"));
  1145.     NEXT_INSTRUCTION;
  1146.       }
  1147.  
  1148.     VMI(A_FUNC, COUNT_N(a_func), ("a_func %d %d\n",*PC,PC[1])) MARK(A_FUNC);
  1149.       {    Word argp = ARGP;
  1150.     if ( ar_func_n(*PC++, *PC++, &argp) == FALSE )
  1151.       BODY_FAILED;
  1152.     ARGP = argp;
  1153.     NEXT_INSTRUCTION;
  1154.       }
  1155.  
  1156. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1157. Translation of the arithmic comparison predicates (<, >, =<,  >=,  =:=).
  1158. Both sides are pushed on the stack, so we just compare the two values on
  1159. the  top  of  this  stack  and  backtrack  if  they  do  not suffice the
  1160. condition.  Example translation: `a(Y) :- b(X), X > Y'
  1161.  
  1162.     ENTER
  1163.     B_FIRSTVAR 1    % Link X from B's frame to a new var in A's frame
  1164.     CALL 0        % call b/1
  1165.     B_VAR 1        % Push X
  1166.     B_VAR 0        % Push Y
  1167.     A_GT        % compare
  1168.     EXIT
  1169. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1170.  
  1171.     VMI(A_LT, COUNT(a_lt), ("a_lt\n")) MARK(A_LT);
  1172.       { ARGP -= 2;
  1173.     if ( compareNumbers(ARGP, ARGP+1, LT) == FALSE )
  1174.       BODY_FAILED;
  1175.     NEXT_INSTRUCTION;
  1176.       }
  1177.  
  1178.     VMI(A_LE, COUNT(a_le), ("a_le\n")) MARK(A_LE);
  1179.       { ARGP -= 2;
  1180.     if ( compareNumbers(ARGP, ARGP+1, LE) == FALSE )
  1181.       BODY_FAILED;
  1182.     NEXT_INSTRUCTION;
  1183.       }
  1184.  
  1185.     VMI(A_GT, COUNT(a_gt), ("a_gt\n")) MARK(A_GT);
  1186.       { ARGP -= 2;
  1187.     if ( compareNumbers(ARGP, ARGP+1, GT) == FALSE )
  1188.       BODY_FAILED;
  1189.     NEXT_INSTRUCTION;
  1190.       }
  1191.  
  1192.     VMI(A_GE, COUNT(a_ge), ("a_ge\n")) MARK(A_GE);
  1193.       { ARGP -= 2;
  1194.     if ( compareNumbers(ARGP, ARGP+1, GE) == FALSE )
  1195.       BODY_FAILED;
  1196.     NEXT_INSTRUCTION;
  1197.       }
  1198.  
  1199.     VMI(A_EQ, COUNT(a_eq), ("a_eq\n")) MARK(A_EQ);
  1200.       { ARGP -= 2;
  1201.     if ( compareNumbers(ARGP, ARGP+1, EQ) == FALSE )
  1202.       BODY_FAILED;
  1203.     NEXT_INSTRUCTION;
  1204.       }
  1205.  
  1206.     VMI(A_NE, COUNT(a_ne), ("a_ne\n")) MARK(A_NE);
  1207.       { ARGP -= 2;
  1208.     if ( compareNumbers(ARGP, ARGP+1, NE) == FALSE )
  1209.       BODY_FAILED;
  1210.     NEXT_INSTRUCTION;
  1211.       }
  1212.  
  1213. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1214. Translation of is/2.  Unify the  two  pushed  values.   Order  does  not
  1215. matter here.
  1216. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1217.  
  1218.     VMI(A_IS, COUNT(a_is), ("a_is\n")) MARK(A_IS);
  1219.       { ARGP -= 2;
  1220.     if ( unify(ARGP, ARGP+1) == FALSE )
  1221.       BODY_FAILED;
  1222.     NEXT_INSTRUCTION;
  1223.       }
  1224. #endif /* O_COMPILE_ARITH */
  1225.  
  1226. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1227. I_USERCALL is generated by the compiler if a variable is encountered  as
  1228. a  subclause.   Note that the compount statement opened here is encloses
  1229. also  I_APPLY  and  I_CALL.   This  allows  us  to  use  local  register
  1230. variables,  but  still  jump to the `normal_call' label to do the common
  1231. part of all these three virtual machine instructions.
  1232.  
  1233. I_USERCALL has the task of  analysing  the  goal:  it  should  fill  the
  1234. ->procedure  slot of the new frame and save the current program counter.
  1235. It also is responsible of filling the argument part of  the  environment
  1236. frame with the arguments of the term.
  1237.  
  1238. BUG: have to find out how to proceed in case of failure (I am afraid the
  1239. `goto frame_failed' is a bit dangerous here).
  1240. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1241.     VMI(I_USERCALL, COUNT(i_usercall), ("user_call\n")) MARK(USRCLL);
  1242.       { word goal;
  1243.     int arity;
  1244.     Word args, a;
  1245.     int n;
  1246.     register LocalFrame next;
  1247.     Module module = (Module) NULL;
  1248.     FunctorDef functor;
  1249.  
  1250.     next = lTop;            /* open next frame */
  1251.     next->flags = FR->flags;
  1252.     if ( true(DEF, HIDE_CHILDS) )
  1253.       set(next, FR_NODEBUG);
  1254.     a = argFrameP(next, 0);        /* get the (now) instantiated */
  1255.     deRef(a);            /* variable */
  1256.  
  1257.     if ((a = stripModule(a, &module)) == (Word) NULL)
  1258.       FRAME_FAILED;
  1259.  
  1260. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1261. Determine the functor definition associated with the goal as well as the
  1262. arity and a pointer to the argument vector of the goal.
  1263. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1264.  
  1265.     if ( isAtom(goal = *a) )
  1266.     { if ( *a == (word) ATOM_cut )
  1267.         goto i_cut;
  1268.       functor = lookupFunctorDef((Atom) goal, 0);
  1269.     } else if ( isTerm(goal) )
  1270.     { args = argTermP(goal, 0);
  1271.       functor = functorTerm(goal);
  1272.       arity = functor->arity;
  1273. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1274. Now scan the argument vector of the goal and fill the arguments  of  the
  1275. frame.
  1276. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1277.       ARGP = argFrameP(next, 0);
  1278.       for(; arity-- > 0; ARGP++, args++)
  1279.       { Word a;
  1280.  
  1281.         deRef2(args, a);
  1282.         *ARGP = (isVar(*a) ? makeRef(a) : *a);
  1283.       }
  1284.     } else
  1285.     { warning("Illegal goal");
  1286.       FRAME_FAILED;
  1287.     }
  1288.  
  1289. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1290. Find the associated procedure.  First look in the specified module.   If
  1291. the function is not there then look in the user module.  Finally specify
  1292. the context module environment for the goal. This is not necessary if it
  1293. will  be  specified  correctly  by  the goal started.  Otherwise tag the
  1294. frame and write  the  module  name  just  below  the  frame.   See  also
  1295. contextModule().
  1296. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1297.  
  1298.     PROC = resolveProcedure(functor, module);
  1299.     DEF = PROC->definition;
  1300.     next->procedure = PROC;
  1301.  
  1302. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1303. Save the program counter (note that  I_USERCALL  has  no  argument)  and
  1304. continue as with a normal call.
  1305. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1306.     next->programPointer = PC;
  1307.     next->context = module;
  1308.     goto normal_call;
  1309.     
  1310. #if O_COMPILE_OR
  1311. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1312. If-then-else is a contraction of C_MARK and C_OR.  This contraction  has
  1313. been  made  to help the decompiler distinguis between (a ; b) -> c and a
  1314. -> b ; c, which would otherwise only be  possible  to  distinguis  using
  1315. look-ahead.
  1316.  
  1317. The   asm("nop")  is a  tricky.    The  problem  is    that  C_NOT and
  1318. C_IFTHENELSE are the same instructions.   The one is generated on \+/1
  1319. and the  other    on (Cond ->   True    ;   False).   Their  different
  1320. virtual-machine   id is  used   by  the   decompiler.  Now,   as   the
  1321. O_VMCODE_IS_ADDRESS is in effect,  these two instruction would  become
  1322. the same.  The asm("nop") ensures  they have the same *functionality*,
  1323. but a  *different* address.  If your  machine does't like nop,  define
  1324. the  macro ASM_NOP  in your md-file  to do something that 1)  has  *no
  1325. effect* and 2) is *not optimised* away by the compiler.
  1326. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1327.     VMI(C_NOT, {}, ("c_not %d\n", *PC))
  1328. #if O_VMCODE_IS_ADDRESS
  1329. #ifdef ASM_NOP
  1330.       ASM_NOP
  1331. #else
  1332.       asm("nop");
  1333. #endif
  1334. #endif
  1335.     VMI(C_IFTHENELSE, COUNT_2N(c_ifthenelse), ("c_ifthenelse %d\n", *PC))
  1336.       MARK(C_ITE);
  1337.       { varFrame(FR, *PC++) = (word) BFR;    /* C_MARK */
  1338.  
  1339.     /*FALL-THROUGH to C_OR*/
  1340.       }
  1341.  
  1342. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1343. C_OR introduces a backtrack point within the clause.   The  argument  is
  1344. how  many  entries  of  the  code  array  to skip should backtracking be
  1345. necessary.  It is implemented by calling a foreign  functions  predicate
  1346. with as argument the amount of bytes to skip.  The foreign function will
  1347. on  first  call  succeed,  leaving  a  backtrack  point.   It does so by
  1348. returning the amount to skip as backtracking  argument.   On  return  it
  1349. will increment PC in its frame with this amount (which will be popped on
  1350. its exit) and succeed deterministically.
  1351.  
  1352. Note that this one is enclosed in the compound statement of  I_USERCALL,
  1353. I_APPLY,  I_CALL  and I_DEPART to allow sharing of the register variable
  1354. `next' with them and thus make the `goto common_call' valid.
  1355. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1356.     VMI(C_OR, COUNT_N(c_or), ("c_or %d\n", *PC)) MARK(C_OR);
  1357.       { *ARGP++ = consNum(*PC++);    /* push amount to skip (as B_CONST) */
  1358.     
  1359.     PROC = PROCEDURE_alt1;        /* fill the frame arguments */
  1360.     DEF  = PROC->definition;
  1361.     next = lTop;
  1362.     next->flags = FR->flags;
  1363.     next->procedure = PROC;
  1364.     next->programPointer = PC;
  1365.     next->context = MODULE_system;
  1366.  
  1367.     goto normal_call;
  1368.       }
  1369. #endif /* O_COMPILE_OR */
  1370.  
  1371. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1372. I_APPLY is the code generated by the Prolog goal $apply/2 (see reference
  1373. manual for the definition of apply/2).  We expect a term  in  the  first
  1374. argument  of  the  frame  and a list in the second, comtaining aditional
  1375. arguments.  Most comments of I_USERCALL apply to I_APPLY as well.   Note
  1376. that  the two arguments are copied in local variables as they will later
  1377. be overwritten by the arguments for the actual call.
  1378. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1379.       VMI(I_APPLY, COUNT(i_apply), ("apply\n")) MARK(APPLY);
  1380.       { Atom functor;
  1381.     word list;
  1382.     Module module = (Module) NULL;
  1383.     Word gp;
  1384.  
  1385.     next = lTop;
  1386.     next->flags = FR->flags;
  1387.     if ( true(DEF, HIDE_CHILDS) )
  1388.       set(next, FR_NODEBUG);
  1389.  
  1390.     ARGP = argFrameP(next, 0); deRef(ARGP); gp = ARGP;
  1391.     ARGP = argFrameP(next, 1); deRef(ARGP); list = *ARGP;
  1392. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1393. Obtain the functor of the actual goal from the first argument  and  copy
  1394. the arguments of this term in the frame.
  1395. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1396.     
  1397.     if ((gp = stripModule(gp, &module)) == (Word) NULL)
  1398.       FRAME_FAILED;
  1399.     next->context = module;
  1400.     goal = *gp;
  1401.  
  1402.     ARGP = argFrameP(next, 0);
  1403.  
  1404.     if (isAtom(goal) )
  1405.     { functor = (Atom) goal;
  1406.       arity = 0;
  1407.     } else if (isTerm(goal) )
  1408.     { functor = functorTerm(goal)->name;
  1409.       arity   = functorTerm(goal)->arity;
  1410.       args    = argTermP(goal, 0);
  1411.       for(n=0; n<arity; n++, ARGP++, args++)
  1412.       { deRef2(args, a);
  1413.         *ARGP = (isVar(*a) ? makeRef(a) : *a);
  1414.       }
  1415.     } else
  1416.     { warning("apply/2: Illegal goal");
  1417.       FRAME_FAILED;
  1418.     }
  1419. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1420. Scan the list and add the elements to the argument vector of the frame.
  1421. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1422.     while(!isNil(list) )
  1423.     { if (!isList(list) )
  1424.       { warning("apply/2: Illegal argument list");
  1425.         FRAME_FAILED;
  1426.       }
  1427.       args = argTermP(list, 0);
  1428.       deRef(args);
  1429.       *ARGP++ = (isVar(*args) ? makeRef(args) : *args);
  1430.       arity++;
  1431.       if (arity > MAXARITY)
  1432.       { warning("apply/2: arity too high");
  1433.         FRAME_FAILED;
  1434.       }
  1435.       args = argTermP(list, 1);
  1436.       deRef(args);
  1437.       list = *args;
  1438.     }
  1439. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1440. Find the associated procedure (see I_CALL for module handling), save the
  1441. program pointer and jump to the common part.
  1442. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1443.     { FunctorDef fdef;
  1444.  
  1445.       fdef = lookupFunctorDef(functor, arity);
  1446.       PROC = resolveProcedure(fdef, module);
  1447.       DEF = PROC->definition;
  1448.       next->procedure = PROC;
  1449.       next->programPointer = PC;
  1450.       next->context = module;
  1451.     }
  1452.  
  1453.     goto normal_call;
  1454.       }
  1455. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1456. I_CALL and I_DEPART form the normal code generated by the  compiler  for
  1457. calling  predicates.   The  arguments  are  already written in the frame
  1458. starting at `lTop'.  I_DEPART implies it is the last  subclause  of  the
  1459. clause.  This is be the entry point for tail recursion optimisation.
  1460.  
  1461. The task of I_CALL is to  save  necessary  information  in  the  current
  1462. frame,  fill  the next frame and initialise the machine registers.  Then
  1463. execution can continue at `next_instruction'
  1464. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1465. #define TAILRECURSION 1
  1466.       VMI(I_DEPART, COUNT(i_depart), ("depart %d\n", *PC)) MARK(DEPART);
  1467. #if TAILRECURSION
  1468.     if ( true(FR, FR_CUT) && BFR <= FR && !debugstatus.debugging )
  1469.     { leaveClause(CL);
  1470.  
  1471.       if ( true(DEF, HIDE_CHILDS) )
  1472.         set(FR, FR_NODEBUG);
  1473.  
  1474.       PROC = FR->procedure = (Procedure) XR[*PC++];
  1475.       DEF = PROC->definition;
  1476.  
  1477.       copyFrameArguments(lTop, FR, PROC->functor->arity);
  1478.  
  1479.       goto depart_continue;
  1480.     }
  1481. #endif
  1482.       VMI(I_CALL, COUNT(i_call), ("call %d\n", *PC)) MARK(CALL);
  1483.         next = lTop;
  1484.         next->flags = FR->flags;
  1485.     if ( true(DEF, HIDE_CHILDS) )        /* parent has hide_childs */
  1486.       set(next, FR_NODEBUG);
  1487.     PROC = next->procedure = (Procedure)XR[*PC++];
  1488.     DEF = PROC->definition;
  1489.     next->programPointer = PC;        /* save PC in child */
  1490.     next->context = FR->context;
  1491.  
  1492. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1493. This is the common part of the call variations.  By now the following is
  1494. true:
  1495.  
  1496.   - arguments, nodebug, programPointer        filled
  1497.   - context                    filled with context for
  1498.                         transparent predicate
  1499.   - PROC, DEF                    filled
  1500. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1501.  
  1502.       normal_call:
  1503.     STACKVERIFY( if (next > lMax) outOf((Stack)&stacks.local) );
  1504.  
  1505. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1506. Initialise those slots of the frame that are common to Prolog predicates
  1507. and foreign ones.  There might be some possibilities for optimisation by
  1508. delaying these initialisations till they are really  needed  or  because
  1509. the information they are calculated from is destroyed.  This probably is
  1510. not worthwile.
  1511.  
  1512. Note: we are working above `lTop' here!
  1513. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1514.     next->backtrackFrame = BFR;
  1515.     next->parent = FR;
  1516.     environment_frame = FR = next;    /* open the frame */
  1517.  
  1518.       depart_continue:
  1519. #if tos
  1520.     { static int tick;
  1521.  
  1522.       if ( (++tick & 0x7f) == 0 )
  1523.       { if ( kbhit() )
  1524.           TtyAddChar(getch());
  1525.       }        
  1526.     }
  1527. #endif
  1528.     incLevel(FR);
  1529.     clear(FR, FR_CUT|FR_SKIPPED);
  1530.  
  1531.     statistics.inferences++;
  1532.     Mark(FR->mark);
  1533.  
  1534. #if O_PROFILE
  1535.     if (statistics.profiling)
  1536.       DEF->profile_calls++;
  1537. #endif /* O_PROFILE */
  1538.  
  1539. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1540. Undefined   predicate detection and   handling.  trapUndefined() takes
  1541. care of  linking from the  public  modules  or  calling  the exception
  1542. handler.
  1543.  
  1544. Note that DEF->definition is  a  union  of  the clause  or C-function.
  1545. Testing is suffices to find out that the predicate is defined.
  1546. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1547.  
  1548.     if ( !DEF->definition.clauses && false(DEF, DYNAMIC) )    
  1549.     { lTop = (LocalFrame) argFrameP(FR, PROC->functor->arity);
  1550.       trapUndefined(PROC);
  1551.       DEF = PROC->definition;
  1552.     }
  1553.  
  1554.     if ( false(DEF, TRANSPARENT) )
  1555.       FR->context = DEF->module;
  1556.     if ( false(DEF, SYSTEM) )
  1557.       clear(FR, FR_NODEBUG);
  1558.  
  1559. #if O_DYNAMIC_STACKS
  1560.     if ( gc_status.requested )
  1561.     { lTop = (LocalFrame) argFrameP(FR, PROC->functor->arity);
  1562.       garbageCollect(FR);
  1563.     }
  1564. #else
  1565.     if ( gMax - gTop < 1024L || tMax - tTop < 1024L )
  1566.     { lTop = (LocalFrame) argFrameP(FR, PROC->functor->arity);
  1567.       garbageCollect(FR);
  1568.     }
  1569. #endif    
  1570.  
  1571.     if ( debugstatus.debugging )
  1572.     { lTop = (LocalFrame) argFrameP(FR, PROC->functor->arity);
  1573.       CL = (Clause) NULL;
  1574.       switch(tracePort(FR, CALL_PORT))
  1575.       { case ACTION_FAIL:    goto frame_failed;
  1576.         case ACTION_IGNORE: goto exit_builtin;
  1577.       }
  1578.     }
  1579.  
  1580.     if ( true(DEF, FOREIGN) )
  1581.     { CL = (Clause) FIRST_CALL;
  1582.  
  1583.       call_builtin:                /* foreign `redo' action */
  1584.  
  1585.       if (callForeign(PROC, FR) == TRUE)
  1586.         goto exit_builtin;
  1587.       goto frame_failed;
  1588.     }
  1589.  
  1590. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1591. Call a normal Prolog predicate.  Just load the  machine  registers  with
  1592. values  found  in  the  clause, give a referecence to the clause and set
  1593. `lTop' to point to the first location after the current frame.
  1594. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1595.     ARGP = argFrameP(FR, 0);
  1596.  
  1597.     DEBUG(9, printf("Searching clause ... "));
  1598.  
  1599.     if ( (CL = findClause(DEF->definition.clauses, ARGP, DEF,
  1600.                   &deterministic)) == NULL )
  1601.     { DEBUG(9, printf("No clause matching index.\n"));
  1602.       FRAME_FAILED;
  1603.     }
  1604.     DEBUG(9, printf("Clauses found.\n"));
  1605.  
  1606.     if ( deterministic )
  1607.       set(FR, FR_CUT);
  1608.     CL->references++;
  1609.     XR = CL->externals;
  1610.     PC = CL->codes;
  1611.     lTop = (LocalFrame)(ARGP + CL->variables);
  1612.  
  1613.     SECURE(
  1614.     int argc; int n;
  1615.     argc = PROC->functor->arity;
  1616.     for(n=0; n<argc; n++)
  1617.       checkData(argFrameP(FR, n) );
  1618.     );
  1619.  
  1620.     NEXT_INSTRUCTION;
  1621.       }
  1622.  
  1623. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1624. Leave the clause:
  1625.  
  1626.   - update reference of current clause
  1627.     If there are no alternatives left and BFR  <=  frame  we  will
  1628.     never  return  at  this clause and can decrease the reference count.
  1629.     If BFR > frame the backtrack frame is a child of  this  frame, 
  1630.     so  this frame can become active again and we might need to continue
  1631.     this clause.
  1632.  
  1633.   - update BFR
  1634.     `BFR' will become the backtrack frame of other childs  of  the
  1635.     parent  frame  in which we are going to continue.  If this frame has
  1636.     alternatives and is newer than the old backFrame `BFR'  should
  1637.     become this frame.
  1638.  
  1639.     If there are no alternatives and  the  BFR  is  this  one  the
  1640.     BFR can become this frame's backtrackframe.
  1641.  
  1642.   - Update `lTop'.
  1643.     lTop can be set to this frame if there are no alternatives  in  this
  1644.     frame  and  BFR  is  older  than this frame (e.g. there are no
  1645.     frames with alternatives that are newer).
  1646.  
  1647.   - restore machine registers from parent frame
  1648. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1649.       {
  1650.     exit_builtin:
  1651.                 MARK(I_EXIT);
  1652.     if ( FR->parent == (LocalFrame) NULL )
  1653.       goto top_exit;
  1654.  
  1655.     if ( FR->clause )
  1656.     { if ( FR > BFR )
  1657.         SetBfr(FR);
  1658.     } else
  1659.     { if ( BFR <= FR )
  1660.       { if ( BFR == FR )
  1661.           SetBfr(FR->backtrackFrame);
  1662.         lTop = FR;
  1663.       }
  1664.     }
  1665.     goto normal_exit;
  1666.  
  1667.     VMI(I_EXIT, COUNT(i_exit), ("exit ")) MARK(EXIT);
  1668.     if (FR->parent == (LocalFrame) NULL)
  1669.     { leaveClause(CL);
  1670.     top_exit:
  1671.       if (debugstatus.debugging)
  1672.       { CL = (Clause) NULL;
  1673.         switch(tracePort(FR, EXIT_PORT) )
  1674.         { case ACTION_RETRY:    goto retry;
  1675.           case ACTION_FAIL:        set(FR, FR_CUT);
  1676.                     goto frame_failed;
  1677.         }
  1678.       }
  1679.       succeed;
  1680.     }
  1681.  
  1682.     if ( false(FR, FR_CUT) )
  1683.     { if ( FR > BFR )            /* alternatives */
  1684.         SetBfr(FR);
  1685.     } else
  1686.     { if ( BFR <= FR )            /* deterministic */
  1687.       { if ( BFR == FR )
  1688.           SetBfr(FR->backtrackFrame);
  1689.         lTop = FR;
  1690.         leaveClause(CL);
  1691.       }
  1692.     }
  1693.  
  1694.     normal_exit:
  1695.     if (debugstatus.debugging)
  1696.     { switch(tracePort(FR, EXIT_PORT) )
  1697.       { case ACTION_RETRY:    goto retry;
  1698.         case ACTION_FAIL:    set(FR, FR_CUT);    /* references !!! */
  1699.                 goto frame_failed;
  1700.       }
  1701.     }
  1702.  
  1703.     PC = FR->programPointer;
  1704.     environment_frame = FR = FR->parent;
  1705.     PROC = FR->procedure;
  1706.     DEF = PROC->definition;
  1707.     XR = CL->externals;
  1708.     ARGP = argFrameP(lTop, 0);
  1709.  
  1710.     NEXT_INSTRUCTION;
  1711.       }      
  1712.   }
  1713.  
  1714. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1715.             TRACER RETRY ACTION
  1716.  
  1717. To retry we should first undo all actions done since the start  of  this
  1718. frame  by  resetting  the  global  stack and calling Undo(). The current
  1719. frame becomes the backtrack frame for the new childs.
  1720.  
  1721. Foreign functions can now just be restarted.  For Prolog  ones  we  will
  1722. create  a  dummy  clause before the first one and proceed as with normal
  1723. backtracking.
  1724.  
  1725. BUG: Clause reference counts should be  updated  properly.   Needs  some
  1726. detailed study!
  1727. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1728.  
  1729. retry:                    MARK(RETRY);
  1730.   Undo(FR->mark);
  1731.   SetBfr(FR);
  1732.   clear(FR, FR_CUT);
  1733.   if (debugstatus.debugging)
  1734.   { LocalFrame lTopSave = lTop;
  1735.     lTop = (LocalFrame) argFrameP(FR, PROC->functor->arity);
  1736.     tracePort(FR, CALL_PORT);
  1737.     lTop = lTopSave;
  1738.   }
  1739.   if ( false(DEF, FOREIGN) )
  1740.   { struct clause zero;                /* fake a clause */
  1741.  
  1742.     clear(&zero, ERASED);            /* avoid destruction */
  1743.     zero.next = DEF->definition.clauses;
  1744.     CL = &zero;
  1745.  
  1746.     CLAUSE_FAILED;
  1747.   }
  1748.   FR->clause = FIRST_CALL;
  1749.   goto call_builtin;
  1750.  
  1751. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1752. The rest of this giant procedure handles backtracking.  There are  three
  1753. different ways we can get here:
  1754.  
  1755.   - Head unification code failed            (clause_failed)
  1756.     In this case we should continue with the next clause of the  current
  1757.     procedure  and  if we are out of clauses continue with the backtrack
  1758.     frame of this frame.
  1759.  
  1760.   - A foreign goal failed                (frame_failed)
  1761.     In this case we can continue at the backtrack frame of  the  current
  1762.     frame.
  1763.  
  1764.   - Body instruction failed                (body_failed)
  1765.     This can only occur since arithmetic is compiled.   Future  versions
  1766.     might incorporate more WAM instructions that can fail.  In this case
  1767.     we should continue with frame BFR.
  1768.  
  1769. In  all  cases,  once  the  right  frame  to  continue  is  found   data
  1770. backtracking  can be invoked, the registers can be reloaded and the main
  1771. loop resumed.
  1772.  
  1773. The argument stack is set back to its base as we cannot  be  sure  about
  1774. it's current value.
  1775.  
  1776. The `shallow_backtrack' entry is used from `deep_backtrack'  to  do  the
  1777. common part.
  1778. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1779.  
  1780. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1781. A WAM instruction in the body wants to start backtracking.  If backtrack
  1782. frames have been created  after  this  frame  we  want  to  resume  that
  1783. backtrack frame.  In this case the current clause remains active.  If no
  1784. such frames are created the current clause fails.
  1785. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1786.  
  1787. body_failed:                MARK(BKTRK);
  1788.   DEBUG(9, printf("body_failed\n"));
  1789.   if ( BFR > FR )
  1790.   { environment_frame = FR = BFR;
  1791.     goto resume_from_body;
  1792.   }
  1793.  
  1794. clause_failed:
  1795.   { register Clause next;
  1796.  
  1797.     next = CL->next;
  1798.     leaveClause(CL);
  1799.     CL = next;
  1800.   }
  1801.   if ( true(FR, FR_CUT) )
  1802.     goto frame_failed;
  1803.  
  1804. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1805. Resume frame FR.  CL points  to  the  next  (candidate)  clause.   First
  1806. indexing  is  activated  to find the next real candidate.  If this fails
  1807. the entire frame has failed, so we cab continue at `frame_failed'.
  1808. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1809.  
  1810. resume_frame:
  1811.   ARGP = argFrameP(FR, 0);
  1812.   Undo(FR->mark);        /* backtrack before clause indexing */
  1813.  
  1814.   if ( (CL = findClause(CL, ARGP, DEF, &deterministic)) == NULL )
  1815.     goto frame_failed;
  1816.  
  1817.   if ( deterministic )
  1818.     set(FR, FR_CUT);
  1819.   else
  1820.     clear(FR, FR_CUT);
  1821.  
  1822.   SetBfr(FR->backtrackFrame);
  1823.   CL->references++;
  1824.   XR = CL->externals;
  1825.   PC = CL->codes;
  1826.   aTop = aBase;
  1827.   lTop = (LocalFrame) argFrameP(FR, CL->variables);
  1828.  
  1829.   NEXT_INSTRUCTION;
  1830.  
  1831. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1832. Deep backtracking part of the system.  This code handles the failure  of
  1833. the goal associated with `frame'.  This would have been simple if we had
  1834. not  to  update  the clause references.  The main control loop will walk
  1835. along the backtrack frame links until either it reaches the top goal  or
  1836. finds a frame that really has a backtrack point left (the sole fact that
  1837. a  frame  is backtrackframe does not guaranty it still has alternatives:
  1838. the alternative clause might be retracted).
  1839. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1840.  
  1841. frame_failed:                MARK(FAIL);
  1842.  
  1843.   for(;;)
  1844.   { 
  1845. #if O_PROFILE
  1846.     if (statistics.profiling)
  1847.       FR->procedure->definition->profile_fails++;
  1848. #endif /* O_PROFILE */
  1849.  
  1850.     if ( debugstatus.debugging )
  1851.     { switch( tracePort(FR, FAIL_PORT) )
  1852.       { case ACTION_RETRY:    PROC = FR->procedure;
  1853.                 DEF = PROC->definition;
  1854.                 goto retry;
  1855.     case ACTION_IGNORE:    Putf("ignore not (yet) implemented here\n");
  1856.       }
  1857.     }
  1858.  
  1859. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1860. Update references due to failure of this frame.  The references of  this
  1861. frame's  clause are already updated.  All frames that can be reached via
  1862. the parent links and are  created  after  the  backtrack  frame  can  be
  1863. visited for dereferencing.
  1864. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1865.  
  1866.     if ( !FR->backtrackFrame )            /* top goal failed */
  1867.     { register LocalFrame fr = FR->parent;
  1868.  
  1869.       for(; fr; fr = fr->parent)
  1870.         leaveFrame(fr);
  1871.  
  1872.       gc_status.segment = NULL;
  1873.  
  1874.       fail;
  1875.     }
  1876.  
  1877.     { register LocalFrame fr = FR->parent;
  1878.  
  1879.       environment_frame = FR = FR->backtrackFrame;
  1880.  
  1881.       for( ; fr > FR; fr = fr->parent )
  1882.         leaveFrame(fr);
  1883.     }
  1884.  
  1885.     { register LocalFrame bfr = FR->backtrackFrame;
  1886.  
  1887.       if ( bfr < gc_status.segment )
  1888.         gc_status.segment = bfr;
  1889.     }
  1890.  
  1891. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1892. References except for this frame are OK again.  First fix the references
  1893. for this frame if it is a Prolog frame.  This  cannot  be  in  the  loop
  1894. above as we need to put CL on the next clause.  Dereferencing the clause
  1895. might free it!
  1896. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1897. resume_from_body:
  1898.  
  1899.     PROC = FR->procedure;
  1900.     DEF = PROC->definition;
  1901.     if ( false(DEF, FOREIGN) )
  1902.     { register Clause next;
  1903.  
  1904.       next = CL->next;
  1905.       leaveClause(CL);
  1906.       CL = next;
  1907.     }
  1908.  
  1909.     if ( debugstatus.debugging )
  1910.     { Undo(FR->mark);            /* data backtracking to get nice */
  1911.                     /* tracer output */
  1912.  
  1913.       switch( tracePort(FR, REDO_PORT) )
  1914.       { case ACTION_FAIL:    continue;
  1915.     case ACTION_IGNORE:    CL = (Clause) NULL;
  1916.                 goto exit_builtin;
  1917.     case ACTION_RETRY:    goto retry;
  1918.       }
  1919.     }
  1920.     
  1921.     statistics.inferences++;
  1922. #if O_PROFILE
  1923.     if ( statistics.profiling )
  1924.       FR->procedure->definition->profile_redos++;
  1925. #endif /* O_PROFILE */
  1926.  
  1927. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1928. Finaly restart.  If it is a Prolog frame this is the same as  restarting
  1929. as  resuming  a  frame after unification of the head failed.  If it is a
  1930. foreign frame we have to set BFR and do data backtracking.
  1931. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1932.  
  1933.     if ( false(DEF, FOREIGN) )
  1934.     { if ( true(FR, FR_CUT) || !CL )
  1935.     continue;
  1936.       goto resume_frame;
  1937.     }
  1938.  
  1939.     SetBfr(FR->backtrackFrame);
  1940.     Undo(FR->mark);
  1941.  
  1942.     goto call_builtin;
  1943.   }
  1944. } /* end of interpret() */
  1945.  
  1946.  
  1947. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1948. Tail recursion copy of the arguments of the new frame back into the  old
  1949. one.   This  should  be  optimised  by the compiler someday, but for the
  1950. moment this will do.
  1951.  
  1952. The new arguments block can contain the following types:
  1953.   - Instantiated data (atoms, ints, reals, strings, terms
  1954.     These can just be copied.
  1955.   - Plain variables
  1956.     These can just be copied.
  1957.   - References to frames older than the `to' frame
  1958.     These can just be copied.
  1959.   - 1-deep references into the `to' frame.
  1960.     This is hard as there might be two of  them  pointing  to  the  same
  1961.     location  int  the  `to' fram, indicating sharing variables.  In the
  1962.     first pass we will fill the  variable  in  the  `to'  frame  with  a
  1963.     reference  to the new variable.  If we get another reference to this
  1964.     field we will copy the reference saved in the `to'  field.   Because
  1965.     on  entry  references into this frame are always 1 deep we KNOW this
  1966.     is a saved reference.  The critical program for this is:
  1967.  
  1968.     a :- b(X, X).
  1969.     b(X, Y) :- X == Y.
  1970.     b(X, Y) :- write(bug), nl.
  1971.  
  1972.                     This one costed me 1/10 bottle of
  1973.                     brandy to Huub Knops, SWI
  1974. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1975.  
  1976. static void
  1977. copyFrameArguments(from, to, argc)
  1978. LocalFrame from;
  1979. LocalFrame to;
  1980. register int argc;
  1981. { register Word ARGD, ARGS;
  1982.   register word k;
  1983.   int argc_save;
  1984.  
  1985.   if ( (argc_save = argc) == 0 )
  1986.     return;
  1987.  
  1988.   ARGS = argFrameP(from, 0);
  1989.   ARGD = argFrameP(to, 0);
  1990.   for( ;argc-- > 0; ARGS++, ARGD++)    /* dereference the block */
  1991.   { if ( !isRef(k = *ARGS) )
  1992.       continue;
  1993.     if ( (long)unRef(k) < (long)to )    /* to older frame */
  1994.       continue;
  1995.     if ( isVar(*unRef(k)) )
  1996.     { *unRef(k) = makeRef(ARGD);
  1997.       setVar(*ARGS);
  1998.       continue;
  1999.     }
  2000.     *ARGS = *unRef(k);
  2001.   }
  2002.     
  2003.   ARGS = argFrameP(from, 0);
  2004.   ARGD = argFrameP(to, 0);
  2005.   argc = argc_save;
  2006.   while(argc-- > 0)            /* now copy them */
  2007.     *ARGD++ = *ARGS++;  
  2008. }
  2009.  
  2010. #if O_COMPILE_OR
  2011. word
  2012. pl_alt(skip, h)
  2013. Word skip;
  2014. word h;
  2015. { switch( ForeignControl(h) )
  2016.   { case FRG_FIRST_CALL:
  2017.       SECURE( if (!isInteger(*skip)) sysError("pl_alt()") );
  2018.       ForeignRedo(valNum(*skip));
  2019.     case FRG_REDO:
  2020.       DEBUG(8, printf("$alt/1: skipping %d codes\n", ForeignContext(h)) );
  2021.       environment_frame->programPointer += ForeignContext(h);
  2022.       succeed;
  2023.     case FRG_CUTTED:
  2024.     default:
  2025.       succeed;
  2026.   }
  2027. }
  2028. #endif /* O_COMPILE_OR */
  2029.