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-comp.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  58KB  |  1,992 lines
  1. /*  pl-comp.c,v 1.4 1993/02/23 13:16:27 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: compiler support
  8. */
  9.  
  10. #include "pl-incl.h"
  11.  
  12.  
  13. #define CODE(c, n, a)    { n, a, c }
  14.  
  15. struct code_info codeTable[] = {
  16.   CODE(I_NOP,        "i_nop",    0),
  17.   CODE(I_ENTER,        "i_enter",    0),
  18.   CODE(I_CALL,        "i_call",    1),
  19.   CODE(I_DEPART,    "i_depart",    1),
  20.   CODE(I_EXIT,        "i_exit",    0),
  21.   CODE(B_FUNCTOR,    "b_functor",    1),
  22.   CODE(H_FUNCTOR,    "h_functor",    1),
  23.   CODE(I_POP,        "i_pop",    0),
  24.   CODE(I_POPN,        "i_popn",    1),
  25.   CODE(B_VAR,        "b_var",    1),
  26.   CODE(H_VAR,        "h_var",    1),
  27.   CODE(B_CONST,        "b_const",    1),
  28.   CODE(H_CONST,        "h_const",    1),
  29.   CODE(H_REAL,        "h_real",    1),
  30.   CODE(H_STRING,    "h_string",    1),
  31.   CODE(B_FIRSTVAR,    "b_firstvar",    1),
  32.   CODE(H_FIRSTVAR,    "h_firstvar",    1),
  33.   CODE(B_VOID,        "b_void",    0),
  34.   CODE(H_VOID,        "h_void",    0),
  35.   CODE(B_ARGFIRSTVAR,    "b_argfirstvar",1),
  36.   CODE(B_ARGVAR,    "b_argvar",    1),
  37.   CODE(H_NIL,        "h_nil",    0),
  38.   CODE(H_CONST0,    "h_const0",    0),
  39.   CODE(H_CONST1,    "h_const1",    0),
  40.   CODE(H_CONST2,    "h_const2",    0),
  41.   CODE(H_LIST,        "h_list",    0),
  42.   CODE(H_FUNCTOR0,    "h_functor0",    0),
  43.   CODE(H_FUNCTOR1,    "h_functor1",    0),
  44.   CODE(H_FUNCTOR2,    "h_functor2",    0),
  45.   CODE(B_VAR0,        "b_var0",    0),
  46.   CODE(B_VAR1,        "b_var1",    0),
  47.   CODE(B_VAR2,        "b_var2",    0),
  48.   CODE(H_SINT,        "h_sint",    1),
  49.   CODE(B_SINT,        "b_sint",    1),
  50.   CODE(I_USERCALL,    "i_usercall",    0),
  51.   CODE(I_CUT,        "i_cut",    0),
  52.   CODE(I_APPLY,        "i_apply",    0),
  53.   CODE(A_FUNC0,        "a_func0",    1),
  54.   CODE(A_FUNC1,        "a_func1",    1),
  55.   CODE(A_FUNC2,        "a_func2",    1),
  56.   CODE(A_FUNC,        "a_func",    2),
  57.   CODE(A_LT,        "a_lt",        0),
  58.   CODE(A_GT,        "a_gt",        0),
  59.   CODE(A_LE,        "a_le",        0),
  60.   CODE(A_GE,        "a_ge",        0),
  61.   CODE(A_EQ,        "a_eq",        0),
  62.   CODE(A_NE,        "a_ne",        0),
  63.   CODE(A_IS,        "a_is",        0),
  64.   CODE(C_OR,        "c_or",        1),
  65.   CODE(C_JMP,        "c_jmp",    1),
  66.   CODE(C_MARK,        "c_mark",    1),
  67.   CODE(C_CUT,        "c_cut",    1),
  68.   CODE(C_IFTHENELSE,    "c_ifthenelse",    2),
  69.   CODE(C_VAR,        "c_var",    1),
  70.   CODE(C_END,        "c_end",    0),
  71.   CODE(C_NOT,        "c_not",    2),
  72.   CODE(C_FAIL,        "c_fail",    0),
  73.   CODE(B_REAL,        "b_real",    1),
  74.   CODE(B_STRING,    "b_string",    1),
  75.   CODE(0,        NULL,        0)
  76. };
  77.  
  78. forwards void    checkCodeTable P((void));
  79.  
  80. static void
  81. checkCodeTable()
  82. { CodeInfo ci;
  83.   int n;
  84.  
  85.   for(ci = codeTable, n = 0; ci->name != NULL; ci++, n++ )
  86.   { if ( ci->code != n )
  87.       sysError("Wrong entry in codeTable: %d", n);
  88.   }
  89.  
  90.   if ( --n != I_HIGHEST )
  91.     sysError("Mismatch in checkCodeTable()");
  92. }
  93.  
  94. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  95.             MAPPING VIRTUAL INSTRUCTIONS
  96.  
  97. The virtual machine interpreter can be optimised considerably by storing
  98. the code addressen with the clauses  rather  than  the  virtual  machine
  99. codes.  Normally the switch in translated (in pseudo assembler) to:
  100.  
  101. next_instruction:
  102.     r1 = *PC;
  103.     PC += sizeof(code);
  104.     if ( r1 > I_HIGHEST ) goto default;
  105.     r1 = jmp_table[r1 * 4];
  106.     goto r1;
  107.  
  108. This is rather silly.  Suppose  we  store  the  addresses  of  the  code
  109. segments  with  the  clauses  rather than the codes themselves, than the
  110. loop overhead can be reduced to:
  111.  
  112. next_instruction:
  113.     r1 = *PC;
  114.     PC += sizeof(code);
  115.     goto r1;
  116.  
  117. With gcc-2.1 or later, we can get this result without using assembler.
  118. All this required where a few pacthes in interpret(), the compiler and
  119. the wic (intermediate code)  generation  code.  The initialisation  is
  120. very critical:
  121.  
  122. The function interpret() (the VM interpreter)  declares a static array
  123. holding  the label  addresses      of the  various  virtual    machine
  124. instructions.  When it is  called,  it will  store the address of this
  125. table in  the  global  variable  interpreter_jmp_table.   the function
  126. initWamTable() than makes the two  translation tables wam_table[] (wam
  127. code --> label address and dewam_table[] (label address --> wam code).
  128. Note that initWamTable() calles prolog() and thus interpret to get the
  129. table with  the label addresses  out of interpret().   It does so with
  130. the  C-defined  predicate fail/0 (because   it  cannot  yet run prolog
  131. predicates).
  132.  
  133. BUGS:    Currently there are three  places were all the VM instructions
  134.     are  defined: pl-incl.h;  above and   pl-wam.c.  One day  this
  135.     should  be merged.  For  now, be very carefull  if you add  or
  136.     delete a VM instruction.
  137.  
  138.     Be carefull: pl-wam.o must be loaded in low addresses!
  139.              make sure you have VM that lets you start the
  140.              text addresses close to zero!
  141.  
  142. NOTE:    If the assert() fails, look at pl-wam.c: VMI(C_NOT, ... for
  143.     more information.
  144. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  145.  
  146. #if O_VMCODE_IS_ADDRESS
  147. void
  148. initWamTable()
  149. { int n;
  150.   int maxcoded = 0;
  151.  
  152.   if ( interpreter_jmp_table == NULL )
  153.     prolog((word) ATOM_fail);
  154.  
  155.   for(n = 0; n <= I_HIGHEST; n++)
  156.   { wam_table[n] = (code) ((int)interpreter_jmp_table[n]);
  157.     if ( wam_table[n] > maxcoded )
  158.       maxcoded = wam_table[n];
  159.   }
  160.  
  161.   assert(wam_table[C_NOT] != wam_table[C_IFTHENELSE]);
  162.  
  163.   if ( maxcoded >= (1 << (sizeof(code) * 8)) ) /* normally 64K */
  164.     fatalError("Cannot use direct jumps: maxcoded = %d (see pl-comp.c)",
  165.            maxcoded);
  166.   dewam_table = (char *)allocHeap((maxcoded + 1) * sizeof(char));
  167.   
  168.   for(n = 0; n <= I_HIGHEST; n++)
  169.     dewam_table[wam_table[n]] = (char) n;
  170.  
  171.   checkCodeTable();
  172. }
  173.  
  174. #else /* O_VMCODE_IS_ADDRESS */
  175.  
  176. void
  177. initWamTable()
  178. { checkCodeTable();
  179. }
  180.  
  181. #endif /* O_VMCODE_IS_ADDRESS */
  182.  
  183. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  184. This module forms together  with  the  module  'pl-wam.c'  the  complete
  185. kernel  of  SWI-Prolog.   It  contains  the  compiler, the predicates to
  186. interface the compiler to Prolog and the  decompiler.   SWI-Prolog  does
  187. not  offer  a  Prolog  interpreter,  which  implies that common database
  188. predicates such as assert/1 and retract/1 have to do  compilation  resp.
  189. decompilation between the term representation used on the runtime stacks
  190. and the compiled representation used in the heap.
  191.  
  192. Compiling a clause takes three different stages.  First the variables of
  193. the clause are analysed.   This  phases  determines  `void'  (singleton)
  194. variables  and assigns offsets in the environment frame to each variable
  195. occurring in the clause that is not  singleton.   Variables  serving  on
  196. their  own as an argument in the head are allocated in the corresponding
  197. argument entry of the environment frame.  The others are allocated above
  198. the arguments in the environment frame.   Singleton  variables  are  not
  199. allocated at all.
  200.  
  201. Second  unification  code  for  the  head  is  produced.   Finally   the
  202. subclauses  are  translated.   Most  vital  from  the  point  of view of
  203. performance is to distinguis between the first time an  entry  from  the
  204. variable  array  is addressed and the following times: the first time we
  205. KNOW the field should be a variable and copying the value  or  making  a
  206. reference  is  the  appropriate action.  This both saves us the variable
  207. test and the need to turn the variable array of  the  environment  frame
  208. really into an array of variables.
  209.  
  210.             ANALYSING VARIABLES
  211.  
  212. First of all the clause is scanned and all  variables  are  instantiated
  213. with  a  structure  that  mimics  a term, but isn't one.  For historical
  214. reasons this is the term $VAR$/1.  Future versions will  use  a  functor
  215. which  is  impossible  to  conflict  with  the user's program.  For each
  216. variable it's address is stored, as well  as  the  number  of  times  it
  217. occurred in the clause.
  218. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  219.  
  220. forwards bool    analyse_variables P((Word, Word, int, int*));
  221. forwards int    analyseVariables2 P((Word, int, int, int));
  222.  
  223. #if O_COMPILE_ARITH
  224. #define A_NOTARITH    0
  225. #define A_OK        1
  226. #define A_ERROR        2
  227. #endif /* O_COMPILE_ARITH */
  228.  
  229. static struct vardef
  230. { FunctorDef    functor;        /* mimic a functor (FUNCTOR_var1) */
  231.   Word        address;        /* address of the variable */
  232.   int        times;            /* occurences */
  233.   int        offset;            /* offset in environment frame */
  234. } vars[MAXVARIABLES];
  235.  
  236. static int    filledVars;        /* vardef structures filled */
  237.  
  238. #define VAROFFSET(var) ( (var) + ARGOFFSET / (int) sizeof(word) )
  239.  
  240. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  241. Split a  clause  into  its  head  and  body.   For  facts  the  body  is
  242. instantiated to NULL.  This is the only place of the compiler that knows
  243. about the :-/2 operator.
  244. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  245.  
  246. bool
  247. splitClause(term, head, body)
  248. register Word term;
  249. Word *head, *body;
  250. { if (isAtom(*term) )
  251.   { *head = term;
  252.     *body = (Word) NULL;
  253.     succeed;
  254.   }
  255.   if (!isTerm(*term) )
  256.     fail;
  257.   if (functorTerm(*term) != FUNCTOR_prove2)        /* :-/2 */
  258.   { *head = term;
  259.     *body = (Word) NULL;
  260.     succeed;
  261.   }
  262.   *head = argTermP(*term, 0);
  263.   *body = argTermP(*term, 1);
  264.   deRef(*head);
  265.   deRef(*body);
  266.  
  267.   succeed;
  268. }
  269.  
  270. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  271. Analyse the variables of a clause.  `term' is the term to  be  analysed, 
  272. which  is  either  a  fact  or  a  clause (:-/2) term.  First of all the
  273. functor and arity of the predicate are determined.   The  first  `arity'
  274. elements  of  the variable definition array are then cleared.  This part
  275. is used for sharing variables that occurr on their own in the head  with
  276. the  argument  part  of the environment frame instead of putting them in
  277. the variable part.
  278.  
  279. AnalyseVariables2() just scans the term, fills the  variable  definition
  280. array  and  binds  found  variables  to entries of this array.  The last
  281. argument indicates which plain argument we are processing.  It is set to
  282. -1 when called with the head.  While scaning the head  arguments  it  is
  283. set  to  the argument number.  For all other code it is arity (body code
  284. and nested terms of the head).  This is used for  the  argument/variable
  285. block merging.
  286.  
  287. After this scan the variable definition records are  scanned  to  assign
  288. offsets  and delete singleton variables.  We cannot leave out singletons
  289. that are sharing with the argument block.  Offset `0' is the first entry
  290. of the argument block, offset `arity' of the variable block.  Singletons
  291. are made variables again.
  292. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  293.  
  294. static bool
  295. analyse_variables(head, body, arity, nv)
  296. Word head, body;
  297. int arity;
  298. int *nv;
  299. { int nvars = 0;
  300.   register struct vardef * vd;
  301.   register int n;
  302.   int body_voids = 0;
  303.  
  304.   for(n=0, vd = vars; n<arity; n++, vd++)
  305.     vd->address = (Word) NULL;
  306.  
  307.   if ( (nvars = analyseVariables2(head, 0, arity, -1)) < 0 )
  308.     fail;
  309.   if (body != (Word) NULL)
  310.     if ( (nvars = analyseVariables2(body, nvars, arity, arity)) < 0 )
  311.       fail;
  312.  
  313.   for(n=0, vd = vars; n<arity+nvars; n++, vd++)
  314.   { if (vd->address == (Word) NULL)
  315.       continue;
  316.     if (vd->times == 1)                /* ISVOID */
  317.     { setVar(*(vd->address));
  318.       vd->address = (Word) NULL;
  319.       if (n >= arity)
  320.     body_voids++;
  321.     } else
  322.       vd->offset = n - body_voids;
  323.   }
  324.  
  325.   filledVars = arity + nvars;
  326.   *nv = nvars - body_voids;
  327.   succeed;
  328. }
  329.  
  330. static int
  331. analyseVariables2(head, nvars, arity, argn)
  332. register Word head;
  333. int nvars, arity;
  334. int argn;
  335. { int ar;
  336.  
  337.   deRef(head);
  338.  
  339.   if (isVar(*head) )
  340.   { register struct vardef *vd;
  341.     int index = ((argn >= 0 && argn < arity) ? argn : (arity + nvars++));
  342.  
  343.     if ( index >= MAXVARIABLES-1 )
  344.     { warning("Compiler: Too many variables in clause");
  345.       return -1;
  346.     }
  347.     vd = &vars[index];
  348.     vd->functor = FUNCTOR_var1;
  349.     vd->address = head;
  350.     vd->times = 1;
  351.     *head = (word) vd;
  352.  
  353.     return nvars;
  354.   }
  355.  
  356.   if ( isAtomic(*head) )
  357.     return nvars;
  358.  
  359.   if (functorTerm(*head) == FUNCTOR_var1)
  360.   { ((struct vardef *)*head)->times++;
  361.     return nvars;
  362.   }
  363.  
  364.   ar = functorTerm(*head)->arity;
  365.   head = argTermP(*head, 0);
  366.  
  367.   argn = ( argn < 0 ? 0 : arity );
  368.  
  369.   for(; ar > 0; ar--, head++, argn++)
  370.     nvars = analyseVariables2(head, nvars, arity, argn);
  371.  
  372.   return nvars;
  373. }
  374.  
  375. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  376. The compiler  itself.   First  it  calls  analyseVariables().  Next  the
  377. arguments  of  the  head  and  the subclauses are compiled.  Finally the
  378. bindings made by analyseVariables() are undone and the clause  is  saved
  379. in the heap.
  380.  
  381. compile() maintains an array of `used_var' (used variables).  This is to
  382. determine when a variable is used for the first time and thus a FIRSTVAR
  383. instruction is to be generated instead of a VAR one.
  384.  
  385. Note that the `variables' field of a clause is filled with the number of
  386. variables in the frame AND the arity.   This  saves  us  the  frame-size
  387. calculation at runtime.
  388. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  389.  
  390. #define isConjunction(w) (isTerm(w) && functorTerm(w) == FUNCTOR_comma2)
  391.  
  392. #define HEAD    2            /* compileArgument on head argument */
  393. #define HEADARG 3            /* ... on functor arg in head */
  394. #define BODY    4            /* compileArgument on body argument */
  395. #define BODYARG 5            /* ... on functor arg in body */
  396.  
  397. #define ISVOID 0            /* compileArgument produced H_VOID */
  398. #define NONVOID 1            /* ... anything else */
  399.  
  400. #define Output_0(ci, c)        ((ci)->codes[(ci)->tc++] = encode(c))
  401. #define Output_a(c1, c)        ((ci)->codes[(ci)->tc++] = (c))
  402. #define Output_1(ci, c, a)    Output_0(ci, c), Output_a(ci, a)
  403. #define Output_2(ci, c, a0, a1)    Output_1(ci, c, a0), Output_a(ci, a1)
  404.  
  405. #define BITSPERINT (sizeof(int)*8)
  406.  
  407. struct vartable
  408. { int    entry[MAXVARIABLES/BITSPERINT];
  409. } empty_var_table;
  410.  
  411. typedef struct
  412. { Module    module;            /* module to compile into */
  413.   int        arity;            /* arity of top-goal */
  414.   Clause    clause;            /* clause we are constructing */
  415.   int        tc;            /* index in tc table */
  416.   int        tx;            /* index in XR table */
  417.   struct vartable used_var;        /* boolean array of used variables */
  418.   word        XR[MAXEXTERNALS];    /* scratch XR table */
  419.   Code        codes;            /* scratch code table */
  420. } compileInfo;
  421.  
  422. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  423. Variable table operations.
  424. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  425.  
  426. #define addXRtable(entry, ci)    add_xr_table((word)(entry), (ci))
  427.  
  428. forwards bool    compileBody P((Word, code, compileInfo *));
  429. forwards int    compileArgument P((Word, int, compileInfo *));
  430. forwards int    add_xr_table P((word, compileInfo *));
  431. forwards int    addRealXRtable P((word, compileInfo *));
  432. forwards int    addStringXRtable P((word, compileInfo *));
  433. forwards bool    compileSubClause P((Word, code, compileInfo *));
  434. forwards bool    isFirstVar P((struct vartable *vt, int n));
  435. forwards void    balanceVars P((struct vartable *, struct vartable *, compileInfo *));
  436. forwards void    orVars P((struct vartable *, struct vartable *));
  437. forwards void    setVars P((Word t, struct vartable *));
  438. forwards Clause    compile P((Word, Module));
  439. #if O_COMPILE_ARITH
  440. forwards int    compileArith P((Word, compileInfo *));
  441. forwards bool    compileArithArgument P((Word, compileInfo *));
  442. #endif
  443.  
  444. #define isIndexedVarTerm(var) ( functorTerm(var) == FUNCTOR_var1 ? \
  445.                     ((struct vardef *)var)->offset : \
  446.                     -1)
  447.  
  448. #define ClearVarTable(ci)    ((ci)->used_var = empty_var_table)
  449.  
  450. static bool
  451. isFirstVar(vt, n)
  452. struct vartable *vt;
  453. register int n;
  454. { register int m  = 1 << (n % BITSPERINT);
  455.   register int *p = &vt->entry[n / BITSPERINT];
  456.   register int result;
  457.   
  458.   result = ((*p & m) == 0);
  459.   *p |= m;
  460.  
  461.   return result;
  462. }
  463.  
  464. static void
  465. balanceVars(valt1, valt2, ci)
  466. struct vartable *valt1, *valt2;
  467. compileInfo *ci;
  468. { int *p1 = &valt1->entry[0];
  469.   int *p2 = &valt2->entry[0];
  470.   register int n;
  471.  
  472.   for( n = 0; n < MAXVARIABLES/BITSPERINT; p1++, p2++, n++ )
  473.   { register int m = (~(*p1) & *p2);
  474.  
  475.     if ( m )
  476.     { register int i;
  477.  
  478.       for(i = 0; i < BITSPERINT; i++)
  479.     if ( m & (1 << i) )
  480.       Output_1(ci, C_VAR, VAROFFSET(n * BITSPERINT + i));
  481.     }
  482.   }
  483. }
  484.  
  485. static void
  486. orVars(valt1, valt2)
  487. struct vartable *valt1, *valt2;
  488. { register int *p1 = &valt1->entry[0];
  489.   register int *p2 = &valt2->entry[0];
  490.   register int n;
  491.  
  492.   for( n = 0; n < MAXVARIABLES/BITSPERINT; n++ )
  493.     *p1++ |= *p2++;
  494. }
  495.  
  496. static void
  497. setVars(t, vt)
  498. register Word t;
  499. register struct vartable *vt;
  500. { deRef(t);
  501.  
  502.   if ( isTerm(*t) )
  503.   { int index;
  504.     register int arity;
  505.  
  506.     if ( (index = isIndexedVarTerm(*t)) >= 0 )
  507.     { isFirstVar(vt, index);
  508.       return;
  509.     }
  510.     arity = functorTerm(*t)->arity;
  511.     for(t = argTermP(*t, 0); arity > 0; t++, arity--)
  512.       setVars(t, vt);
  513.   }
  514. }
  515.  
  516. static Clause
  517. compile(term, module)
  518. Word term;
  519. Module module;
  520. { compileInfo ci;            /* data base for the compiler */
  521.   Word head, body;
  522.   Procedure proc;
  523.   Clause clause;
  524.   int nvars;
  525.  
  526. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  527. Split the clause into its head and body and determine the procedure  the
  528. clause should belong to.
  529. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  530.  
  531.   if (splitClause(term, &head, &body) == FALSE)
  532.   { warning("compiler: illegal clause");
  533.     return (Clause) NULL;
  534.   }
  535.   if (isAtom(*head) )
  536.     proc = lookupProcedure(lookupFunctorDef((Atom)*head, 0), module);
  537.   else if (isTerm(*head) )
  538.     proc = lookupProcedure(functorTerm(*head), module);
  539.   else
  540.   { warning("compiler: illegal clause head");
  541.     return (Clause) NULL;
  542.   }
  543.  
  544.   if ( (ci.arity = proc->functor->arity) > MAXARITY )
  545.     return (Clause) warning("Compiler: arity too high (%d)\n", ci.arity);
  546.  
  547.   DEBUG(9, printf("Splitted and found proc\n"));
  548.  
  549. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  550. Allocate the clause and fill initialise the field we already know.
  551. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  552.  
  553.   clause = (Clause) allocHeap(sizeof(struct clause));
  554.   clause->next = (Clause) NULL;
  555.   clause->references = 0;
  556.   clear(clause, ERASED|INDEXABLE);
  557.   clause->XR_size = clause->code_size = 0;
  558.   clause->subclauses = 0;
  559.   clause->procedure = proc;
  560.  
  561. #if O_AUTOINDEX
  562.   if ( ci.arity > 0 )
  563.   { register Word a = argTermP(*head, 0);
  564.  
  565.     deRef(a);
  566.     DEBUG(9, printf("a = 0x%lx, *a = 0x%lx\n", a, *a));
  567.     if ( isAtom(*a) || isInteger(*a) || isTerm(*a) )
  568.       set(clause, INDEXABLE);
  569.   }
  570. #endif /* O_AUTOINDEX */
  571.  
  572.   DEBUG(9, printf("clause struct initialised\n"));
  573.  
  574.   { register Definition def = proc->definition;
  575.  
  576.     if ( def->indexPattern )
  577.       clause->index = getIndex(argTermP(*head, 0), def->indexPattern, 
  578.                            def->indexCardinality);
  579.     else
  580.       clause->index.key = clause->index.varmask = 0L;
  581.   }
  582.  
  583.   TRY( analyse_variables(head, body, ci.arity, &nvars) );
  584.   clause->variables = clause->slots = nvars + ci.arity;
  585.  
  586. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  587. Initialise the `compileInfo' structure.
  588. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  589.  
  590.   ci.tx = ci.tc = 0;
  591.   initAllocLocal();
  592.   ci.codes = alloc_local(MAXCODES);
  593.   ci.module = module;
  594.   ci.clause = clause;
  595.   ClearVarTable(&ci);
  596.  
  597. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  598. First compile  the  head  of  the  term.   The  arguments  are  compiled
  599. left-to-right. `lastnonvoid' is maintained to delete void variables just
  600. before the I_ENTER instructions.
  601. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  602.  
  603.   { int n;
  604.     int lastnonvoid = 0;
  605.     Word arg;
  606.  
  607.     for ( arg = argTermP(*head, 0), n = 0; n < ci.arity; n++, arg++ )
  608.       if ( compileArgument(arg, HEAD, &ci) == NONVOID )
  609.     lastnonvoid = ci.tc;
  610.     ci.tc = lastnonvoid;
  611.   }
  612.  
  613. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  614. Now compile the body.
  615. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  616.  
  617.   if (body != (Word) NULL)
  618.   { Output_0(&ci, I_ENTER);
  619.     compileBody(body, I_DEPART, &ci);
  620.   }
  621.   Output_0(&ci, I_EXIT);
  622.  
  623. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  624. Reset all variables we initialised to the variable analysis  functor  to
  625. become variables again.
  626. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  627.  
  628.   { register struct vardef * vd;
  629.     register int n;
  630.  
  631.     for(vd=vars, n=0; n < filledVars; n++, vd++)
  632.       if (vd->address != (Word) NULL)
  633.     setVar(*(vd->address));
  634.   }
  635.  
  636. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  637. Finish up the clause.
  638. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  639.  
  640.   if ( ci.tx > 0 )
  641.   { clause->externals = (Word) allocHeap(sizeof(word) * ci.tx);
  642.     memcpy(clause->externals, ci.XR, sizeof(word) * ci.tx);
  643.   } else
  644.     clause->externals = NULL;
  645.   clause->XR_size = ci.tx;
  646.   clause->codes = (Code) allocHeap(sizeof(code) * ci.tc);
  647.   memcpy(clause->codes, ci.codes, sizeof(code) * ci.tc);
  648.   clause->code_size = ci.tc;
  649.   stopAllocLocal();
  650.   statistics.externals += clause->XR_size;
  651.   statistics.codes += clause->code_size;
  652.  
  653.   return clause;
  654. }
  655.  
  656. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  657. compileBody() compiles the clause's body.  Within a body,  a  number  of
  658. constructs are recognised:
  659.  
  660. SUBGOAL
  661.     For a subgoal we generate code to push the  arguments  on  the  next
  662.     stack  frame  and finally generate either I_CALL for normal calls or
  663.     I_DEPART for the last subgoal  of  the  clause  to  allow  for  tail
  664.     recursion optimisation.
  665.  
  666. VARIABLE or META CALL
  667.     Single variables or constructs  of  the  form  term:term  imply  the
  668.     generation of a metacall.
  669.  
  670. A ; B, A -> B, A -> B ; C, \+ A
  671.     The compilation of these statements are  a  bit  more  tricky.   Two
  672.     mechanisms support this compilation:
  673.     
  674.     C_MARK var    Mark for `soft-cut'
  675.     C_CUT  var    Cut alternatives generated since C_MARK var
  676.  
  677.     and
  678.     
  679.     C_OR jmp    Generate a choicepoint.  It the continuation
  680.             fails skip `jmp' instructions and continue
  681.             there.
  682.     C_JMP jmp    Just skip `jmp' instructions.
  683.  
  684.     This set  is  augmented  with  some  compound  statements  and  some
  685.     statements  with  different  names,  but equal semantics to help the
  686.     decompiler.  See pl-wam.c for more details.
  687.  
  688.     NOTE: A tricky bit now is that we  can  reach  the  same  point  via
  689.     different  paths.   Each of these paths may result in another set of
  690.     variabled  already  instantiated.   This  gives  troubles  with  the
  691.     FIRSTVAR  type  of instructions.  to avoid such trouble the compiler
  692.     generates  SETVAR  instructions  to  balance  both   brances.    See
  693.     balanceVars();
  694. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  695.  
  696. #if PROTO
  697. static bool
  698. compileBody(register Word body, code call, register compileInfo *ci)
  699. #else
  700. static bool
  701. compileBody(body, call, ci)
  702. register Word body;
  703. code call;
  704. register compileInfo *ci;
  705. #endif
  706. { deRef(body);
  707.  
  708.   if ( isTerm(*body) )
  709.   { FunctorDef fd = functorTerm(*body);
  710.  
  711.     if ( fd == FUNCTOR_comma2 )            /* A , B */
  712.     { TRY( compileBody(argTermP(*body, 0), I_CALL, ci) );
  713.       return compileBody(argTermP(*body, 1), call, ci);
  714. #if O_COMPILE_OR
  715.     } else if ( fd == FUNCTOR_semicolon2 ||
  716.         fd == FUNCTOR_bar2 )        /* A ; B and (A -> B ; C) */
  717.     { register Word a0 = argTermP(*body, 0);
  718.       struct vartable vsave, valt1, valt2;
  719.  
  720.       vsave = valt1 = valt2 = ci->used_var;
  721.       setVars(argTermP(*body, 0), &valt1);
  722.       setVars(argTermP(*body, 1), &valt2);
  723.  
  724.       deRef(a0);
  725.       if ( isTerm(*a0) && functorTerm(*a0) == FUNCTOR_ifthen2 ) /* A -> B ; C */
  726.       { int var = VAROFFSET(ci->clause->variables++);
  727.     int tc_or, tc_jmp;
  728.  
  729.     Output_2(ci, C_IFTHENELSE, var, (code)0);
  730.     tc_or = ci->tc;
  731.     TRY( compileBody(argTermP(*a0, 0), I_CALL, ci) );    
  732.     Output_1(ci, C_CUT, var);
  733.     TRY( compileBody(argTermP(*a0, 1), I_CALL, ci) );    
  734.     balanceVars(&valt1, &valt2, ci);
  735.     Output_1(ci, C_JMP, (code)0);
  736.     tc_jmp = ci->tc;
  737.     ci->codes[tc_or-1] = (code)(ci->tc - tc_or);
  738.     ci->used_var = vsave;
  739.     TRY( compileBody(argTermP(*body, 1), call, ci) );
  740.     balanceVars(&valt2, &valt1, ci);
  741.     ci->codes[tc_jmp-1] = (code)(ci->tc - tc_jmp);
  742.       } else                    /* A ; B */
  743.       { int tc_or, tc_jmp;
  744.  
  745.     Output_1(ci, C_OR, (code)0);
  746.     tc_or = ci->tc;
  747.     TRY( compileBody(argTermP(*body, 0), I_CALL, ci) );
  748.     balanceVars(&valt1, &valt2, ci);
  749.     Output_1(ci, C_JMP, (code)0);
  750.     tc_jmp = ci->tc;
  751.     ci->codes[tc_or-1] = (code)(ci->tc - tc_or);
  752.     ci->used_var = vsave;
  753.     TRY( compileBody(argTermP(*body, 1), call, ci) );
  754.     balanceVars(&valt2, &valt1, ci);
  755.     ci->codes[tc_jmp-1] = (code)(ci->tc - tc_jmp);
  756.       }
  757.  
  758.       orVars(&valt1, &valt2);
  759.       ci->used_var = valt1;
  760.  
  761.       succeed;
  762.     } else if ( fd == FUNCTOR_ifthen2 )        /* A -> B */
  763.     { int var = VAROFFSET(ci->clause->variables++);
  764.  
  765.       Output_1(ci, C_MARK, var);
  766.       TRY( compileBody(argTermP(*body, 0), I_CALL, ci) );
  767.       Output_1(ci, C_CUT, var);
  768.  
  769.       TRY( compileBody(argTermP(*body, 1), call, ci) );
  770.       Output_0(ci, C_END);
  771.       
  772.       succeed;
  773.     } else if ( fd == FUNCTOR_not_provable1 )        /* \+/1 */
  774.     { int var = VAROFFSET(ci->clause->variables++);
  775.       int tc_or;
  776.       struct vartable vsave;
  777.  
  778.       vsave = ci->used_var;
  779.  
  780.       Output_2(ci, C_NOT, var, (code)0);
  781.       tc_or = ci->tc;
  782.       TRY( compileBody(argTermP(*body, 0), I_CALL, ci) );    
  783.       Output_1(ci, C_CUT, var);
  784.       Output_0(ci, C_FAIL);
  785.       ci->codes[tc_or-1] = (code)(ci->tc - tc_or);
  786.       ci->used_var = vsave;
  787.       
  788.       succeed;
  789. #endif /* O_COMPILE_OR */
  790.     }
  791.   }
  792.  
  793.   TRY( compileSubClause(body, call, ci) );
  794.   ci->clause->subclauses++;
  795.  
  796.   succeed;
  797. }
  798.  
  799.  
  800. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  801. compileArgument() is the key function of the compiler.  Its function  is
  802. to   generate  the  term  matching/construction  instructions  both  for
  803. arguments of the head as for arguments to subclauses.   It  distinguises
  804. three  different  places:  compiling plain arguments to the head (HEAD),
  805. arguments of terms occurring in the head (HEADARG) and body arguments
  806. (BODY).
  807.  
  808. The  isIndexedVar()  macro  detects  a   term   has   been   filled   by
  809. analyseVariables()  and  returns the offset of the variable, or -1 if it
  810. is not produced by this function.
  811.  
  812. compileArgument() returns ISVOID if a void instruction resulted from the
  813. compilation.  This is used to detect  the  ...ISVOID,  [I_ENTER,  I_POP]
  814. sequences,  in  which  case  we  can leave out the VOIDS just before the
  815. I_ENTER or I_POP instructions.
  816. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  817.  
  818. static int lastPopped;        /* how many contiguous pops? */
  819.  
  820. static int
  821. compileArgument(arg, where, ci)
  822. register Word arg;
  823. register int where;
  824. register compileInfo *ci;
  825. { int index;
  826.   bool first;
  827.  
  828.   lastPopped = 0;        /* going to produce something else */
  829.   deRef(arg);
  830.  
  831. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  832. A void.  Generate either B_VOID or H_VOID.  Note that the  return  value
  833. ISVOID  is reserved for head variables only (B_VOID sets the location to
  834. be a variable, and thus cannot be removed if it is before an I_POP.
  835. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  836.  
  837.   if ( isVar(*arg) )
  838.   { if (where & BODY)
  839.     { Output_0(ci, B_VOID);
  840.       return NONVOID;
  841.     }
  842.     Output_0(ci, H_VOID);
  843.     return ISVOID;
  844.   }
  845.  
  846.  
  847.   if ( isAtomic(*arg) )
  848.   { int index;
  849.  
  850.     if (isNil(*arg) && (where & HEAD))
  851.     { Output_0(ci, H_NIL);
  852.       return NONVOID;
  853.     }
  854.  
  855.     if ( isIndirect(*arg) )
  856.     { if ( isReal(*arg) )
  857.       { Output_1(ci, where & HEAD ? H_REAL : B_REAL,
  858.              addRealXRtable(*arg, ci));
  859.     return NONVOID;
  860.       }
  861. #if O_STRING
  862.       if ( isString(*arg) )
  863.       { Output_1(ci, where & HEAD ? H_STRING : B_STRING,
  864.              addStringXRtable(*arg, ci));
  865.     return NONVOID;
  866.       }
  867. #endif /* O_STRING */
  868.     }
  869.  
  870.     if ( isInteger(*arg) )
  871.     { long val = valNum(*arg);
  872.       if ( val >= -32768L && val <= 32767L )
  873.       { Output_1(ci, (where & BODY) ? B_SINT : H_SINT, (code) val);
  874.         return NONVOID;
  875.       }
  876.     }
  877.  
  878.     index = addXRtable(*arg, ci);
  879.     if (index < 3 && (where & HEAD))
  880.     { Output_0(ci, H_CONST0 + index);
  881.       return NONVOID;
  882.     }
  883.     Output_1(ci, (where & BODY) ? B_CONST : H_CONST, index);
  884.     return NONVOID;
  885.   }
  886.     
  887.   SECURE(                /* should be a term when here */
  888.     if (!isTerm(*arg))
  889.       return sysError("Illegal type in compileArgument()"));
  890.  
  891. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  892. Non-void variables. There are many cases for this.
  893. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  894.   if ( (index = isIndexedVarTerm(*arg)) >= 0 )
  895.   { first = isFirstVar(&ci->used_var, index);
  896.  
  897.     if ( index < ci->arity )        /* variable on its own in the head */
  898.     { switch ( where )
  899.       { case BODY:    if ( index < 3 )
  900.             { Output_0(ci, B_VAR0 + index);
  901.               return NONVOID;
  902.             }
  903.             Output_0(ci, B_VAR);    break;
  904.     case BODYARG:    Output_0(ci, B_ARGVAR);    break;
  905.     case HEAD:    if ( first )
  906.             { Output_0(ci, H_VOID);
  907.               return ISVOID;
  908.             } /*FALLTHROUGH*/
  909.     case HEADARG:    Output_0(ci, H_VAR);    break;
  910.       }
  911.       Output_a(ci, VAROFFSET(index));
  912.       return NONVOID;
  913.     }
  914.  
  915.     /* normal variable (i.e. not shared in the head and non-void) */
  916.     switch(where)
  917.     { case BODY:    if ( index < 3 && !first )
  918.             { Output_0(ci, B_VAR0 + index);
  919.               return NONVOID;
  920.             }
  921.             Output_0(ci, first ? B_FIRSTVAR    : B_VAR);    break;
  922.       case BODYARG:    Output_0(ci, first ? B_ARGFIRSTVAR : B_ARGVAR); break;
  923.       default:        Output_0(ci, first ? H_FIRSTVAR    : H_VAR);    break;
  924.     }
  925.     Output_a(ci, VAROFFSET(index));
  926.     return NONVOID;
  927.   }
  928.  
  929.   { int ar;
  930.     int lastnonvoid;
  931.     FunctorDef fdef;
  932.  
  933.     fdef = functorTerm(*arg);
  934.     if ( fdef == FUNCTOR_dot2 && (where & HEAD) )
  935.     { Output_0(ci, H_LIST);
  936.     } else
  937.     { index = addXRtable(fdef, ci);
  938.       if (index < 3 && (where & HEAD))
  939.       { Output_0(ci, H_FUNCTOR0 + index);
  940.       } else
  941.       { Output_1(ci, where & BODY ? B_FUNCTOR : H_FUNCTOR, index);
  942.       }
  943.     }
  944.     lastnonvoid = ci->tc;
  945.     ar = fdef->arity;
  946.     for(arg = argTermP(*arg, 0); ar > 0; ar--, arg++)
  947.     { if ( compileArgument(arg, (where & BODY) ? BODYARG : HEADARG, ci)
  948.                             == NONVOID )
  949.     lastnonvoid = ci->tc;
  950.     }
  951.     ci->tc = lastnonvoid;
  952.     switch(lastPopped)
  953.     { case 0:        Output_0(ci, I_POP);
  954.                 break;
  955.       case 1:        ci->codes[ci->tc-1] = encode(I_POPN);
  956.             Output_a(ci, 2);
  957.             break;
  958.       case 65535L:    Output_0(ci, I_POP);    /* I_POPN 65535, I_POP... */
  959.             lastPopped = 0;
  960.             break;
  961.       default:        ci->codes[ci->tc-1]++;
  962.     }
  963.     lastPopped++;
  964.     return NONVOID;
  965.   }
  966. }
  967.  
  968. #define CheckMaxExternals(ci)    \
  969.     { if ( ci->tx >= MAXEXTERNALS ) \
  970.       { warning("Compiler limit: too many external references"); \
  971.         pl_abort(); \
  972.       } \
  973.     }
  974.  
  975. static int
  976. add_xr_table(entry, ci)
  977. register word entry;
  978. register compileInfo *ci;
  979. { register int n;
  980.   register Word XR = ci->XR;
  981.  
  982.   for(n=0; n<ci->tx; n++, XR++)
  983.     if (entry == *XR)
  984.       return n;
  985.   CheckMaxExternals(ci);
  986.   *XR = entry;
  987.  
  988.   return ci->tx++;
  989. }
  990.  
  991. static int
  992. addRealXRtable(entry, ci)
  993. register word entry;
  994. register compileInfo *ci;
  995. { register int n;
  996.   register Word XR = ci->XR;
  997.  
  998.   for(n=0; n<ci->tx; n++, XR++)
  999.     if (isReal(*XR) && valReal(entry) == valReal(*XR) )
  1000.       return n;
  1001.   CheckMaxExternals(ci);
  1002.   *XR = heapReal(valReal(entry));
  1003.  
  1004.   return ci->tx++;
  1005. }
  1006.  
  1007.  
  1008. #if O_STRING
  1009. static int
  1010. addStringXRtable(entry, ci)
  1011. register word entry;
  1012. register compileInfo *ci;
  1013. { register int n;
  1014.   register Word XR = ci->XR;
  1015.  
  1016.   for(n=0; n<ci->tx; n++, XR++)
  1017.     if ( isString(*XR) && equalString(entry, *XR) )
  1018.       return n;
  1019.   CheckMaxExternals(ci);
  1020.   *XR = heapString(valString(entry));
  1021.  
  1022.   return ci->tx++;
  1023. }
  1024. #endif /* O_STRING */
  1025.  
  1026.  
  1027. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1028. The task of compileSubClause() is to  generate  code  for  a  sunclause.
  1029. First  it will call compileArgument for each argument to the call.  Then
  1030. an instruction to call the procedure is added.  Before doing all this it
  1031. will check for the subclause just beeing a variable or the cut.
  1032. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1033.  
  1034. #if PROTO
  1035. static bool
  1036. compileSubClause(register Word arg, code call, compileInfo *ci)
  1037. #else
  1038. static bool
  1039. compileSubClause(arg, call, ci)
  1040. register Word arg;
  1041. code call;
  1042. compileInfo *ci;
  1043. #endif
  1044. { Module tm = ci->module;
  1045.  
  1046.   deRef(arg);
  1047.  
  1048.   if ( isTerm(*arg) )
  1049.   {
  1050. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1051. A non-void variable. Create a I_USERCALL instruction for it.
  1052. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1053.     if ( isIndexedVarTerm(*arg) >= 0 )
  1054.     { compileArgument(arg, BODY, ci);
  1055.       Output_0(ci, I_USERCALL);
  1056.       succeed;
  1057.     }
  1058.  
  1059. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1060. If the argument is of the form <Module>:<Goal>, <Module> is an atom  and
  1061. <Goal>  is  nonvar  then compile to the specified module.  Otherwise use
  1062. the meta-call mechanism (BUG: `user:hello:foo' is called  via  meta-call
  1063. mechanism, but this only is a bit slower).
  1064.  
  1065. This is a bit more complex then expected: foo:assert(baz) should  assert
  1066. baz/0  into module foo.  In general: the context module should be set to
  1067. the appropriate value.  This needs a  new  virtual  machine  instruction
  1068. that  handles  calls  with  specified context module.  For the moment we
  1069. will use the meta-call mechanism for all these types of calls.
  1070. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1071.     if ( functorTerm(*arg) == FUNCTOR_module2 )
  1072.     {
  1073.   /*                            SEE COMMENT ABOVE
  1074.       register Word mp, g;
  1075.  
  1076.       mp = argTermP(*arg, 0); deRef(mp);
  1077.       if ( isAtom(*mp) )
  1078.       { g = argTermP(*arg, 1); deRef(g);
  1079.     if ( isIndexedVarTerm(*g) < 0 )
  1080.     { arg = g;
  1081.       tm = lookupModule(*mp);
  1082.       goto cont;
  1083.     }
  1084.       }
  1085.   */
  1086.  
  1087.       compileArgument(arg, BODY, ci);
  1088.       Output_0(ci, I_USERCALL);
  1089.       succeed;
  1090.     }
  1091. /*  cont: */
  1092.  
  1093. #if O_COMPILE_ARITH
  1094.     if ( status.optimise )
  1095.     { switch( compileArith(arg, ci) )
  1096.       { case A_OK:    succeed;
  1097.     case A_ERROR:    fail;
  1098.       }
  1099.     }
  1100. #endif /* O_COMPILE_ARITH */
  1101.  
  1102. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1103. Term, not a variable and not a module call.  Compile the  arguments  and
  1104. generate  the  call  instruction.   Note  this  codes traps the $apply/2
  1105. operator.
  1106. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1107.     { Procedure proc;
  1108.       int ar;
  1109.  
  1110.       proc = lookupProcedure(functorTerm(*arg), tm);
  1111.       ar = functorTerm(*arg)->arity;
  1112.  
  1113.       for(arg = argTermP(*arg, 0); ar > 0; ar--, arg++)
  1114.     compileArgument(arg, BODY, ci);
  1115.       if ( proc->functor == FUNCTOR_apply2 )
  1116.       { Output_0(ci, I_APPLY);
  1117.     succeed;
  1118.       }
  1119.       Output_1(ci, call, addXRtable(proc, ci));
  1120.  
  1121.       succeed;
  1122.     }
  1123.   }
  1124.  
  1125.   if ( isAtom(*arg) )
  1126.   { if ( *arg == (word) ATOM_cut )
  1127.     { Output_0(ci, I_CUT);
  1128.       succeed;
  1129.     }
  1130.  
  1131.     Output_1(ci,
  1132.          call,
  1133.          addXRtable(lookupProcedure(lookupFunctorDef((Atom)*arg, 0), tm), ci));
  1134.  
  1135.     succeed;
  1136.   }
  1137.     
  1138.   return warning("assert/1: illegal clause");
  1139. }
  1140.  
  1141. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1142. Arithmetic compilation compiles is/2, >/2, etc.  Instead of building the
  1143. compound terms holding the arithmetic expression as  a  whole  and  then
  1144. calling  is/2,  etc.  to evaluate the result, a stack machine is used to
  1145. compute the value.  The ARGP virtual machine register, normally used  in
  1146. body  mode to push the arguments to the next functioncall now is used to
  1147. push the arguments to the arithmetic functions.  Normally, a term f(a,b)
  1148. is translated to:
  1149.  
  1150.     * Create f and set ARGP to point to first argument of f
  1151.     * Push a and b via ARGP
  1152.     * pop ARGP
  1153.  
  1154. This constructs a term.  In arithmetic mode, we generate:
  1155.  
  1156.     * Push a and b via ARGP
  1157.     * Call f/2 to pick the top two words from the stack and push
  1158.       the result back onto it.
  1159.  
  1160. This has two advantages: No term is created on the global stack and  the
  1161. mapping  between  the  term  and  the arithmetic function is done by the
  1162. compiler rather than the evaluation routine.
  1163. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1164.  
  1165. #if O_COMPILE_ARITH
  1166. static int
  1167. compileArith(arg, ci)
  1168. Word arg;
  1169. register compileInfo *ci;
  1170. { code a_func;
  1171.   register FunctorDef fdef = functorTerm(*arg);
  1172.  
  1173.   if      ( fdef == FUNCTOR_ar_equals2 )    a_func = A_EQ;    /* =:= */
  1174.   else if ( fdef == FUNCTOR_ar_not_equal2 )    a_func = A_NE;    /* =\= */
  1175.   else if ( fdef == FUNCTOR_smaller2 )         a_func = A_LT;    /* < */
  1176.   else if ( fdef == FUNCTOR_larger2 )        a_func = A_GT;    /* > */
  1177.   else if ( fdef == FUNCTOR_smaller_equal2 )    a_func = A_LE;    /* =< */
  1178.   else if ( fdef == FUNCTOR_larger_equal2 )    a_func = A_GE;    /* >= */
  1179.   else if ( fdef == FUNCTOR_is2 )        a_func = A_IS;    /* is */
  1180.   else return A_NOTARITH;            /* not arith function */
  1181.  
  1182.   if ( compileArithArgument(argTermP(*arg, 0), ci) == FALSE )
  1183.     return A_ERROR;
  1184.   if ( compileArithArgument(argTermP(*arg, 1), ci) == FALSE )
  1185.     return A_ERROR;
  1186.   Output_0(ci, a_func);
  1187.  
  1188.   return A_OK;
  1189. }
  1190.  
  1191. static
  1192. bool
  1193. compileArithArgument(arg, ci)
  1194. register Word arg;
  1195. register compileInfo *ci;
  1196. { int index;
  1197.  
  1198.   deRef(arg);
  1199.  
  1200.   if ( isInteger(*arg) )        /* integer */
  1201.   { Output_1(ci, B_CONST, addXRtable(*arg, ci));
  1202.     succeed;
  1203.   }
  1204.   if ( isReal(*arg) )            /* real */
  1205.   { Output_1(ci, B_REAL, addRealXRtable(*arg, ci));
  1206.     succeed;
  1207.   }
  1208.                     /* variable */
  1209.   if ( isTerm(*arg) && (index = isIndexedVarTerm(*arg)) >= 0 )
  1210.   { int first = isFirstVar(&ci->used_var, index);
  1211.  
  1212.     if ( index < ci->arity )    /* shared in the head */
  1213.     { if ( index < 3 )
  1214.       { Output_0(ci, B_VAR0 + index);
  1215.     succeed;
  1216.       }
  1217.       Output_0(ci, B_VAR);
  1218.     } else
  1219.     { if ( index < 3 && !first )
  1220.       { Output_0(ci, B_VAR0 + index);
  1221.         succeed;
  1222.       }
  1223.       Output_0(ci, first ? B_FIRSTVAR : B_VAR);
  1224.     }          
  1225.     Output_a(ci, VAROFFSET(index));
  1226.     succeed;
  1227.   }
  1228.  
  1229.   { FunctorDef fdef;
  1230.     int ar;
  1231.     Word a;
  1232.  
  1233.     if ( isAtom(*arg) )
  1234.     { fdef = lookupFunctorDef((Atom)*arg, 0);
  1235.       ar = 0;
  1236.       a = NULL;
  1237.     } else if ( isTerm(*arg) )
  1238.     { fdef = functorTerm(*arg);
  1239.       ar = fdef->arity;
  1240.       a = argTermP(*arg, 0);      
  1241.     } else
  1242.       return warning("Illegal argument to arithmic function");
  1243.  
  1244.     if ( (index = indexArithFunction(fdef, ci->module)) < 0 )
  1245.       return warning("%s/%d: unknown arithmetic operator",
  1246.              stringAtom(fdef->name), fdef->arity);
  1247.  
  1248.     for(; ar > 0; a++, ar--)
  1249.       TRY( compileArithArgument(a, ci) );
  1250.  
  1251.     switch(fdef->arity)
  1252.     { case 0:    Output_1(ci, A_FUNC0, index); break;
  1253.       case 1:    Output_1(ci, A_FUNC1, index); break;
  1254.       case 2:    Output_1(ci, A_FUNC2, index); break;
  1255.       default:  Output_2(ci, A_FUNC,  index, (code) fdef->arity); break;
  1256.     }
  1257.  
  1258.     succeed;
  1259.   }
  1260. }
  1261. #endif /* O_COMPILE_ARITH */
  1262.  
  1263.  
  1264.         /********************************
  1265.         *  PROLOG DATA BASE MANAGEMENT  *
  1266.         *********************************/
  1267.  
  1268. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1269. Assert is used by assert[az] and record_clause/2 (used by  the  compiler
  1270. toplevel).  It asserts a term in the database, either at the start or at
  1271. the  end  of  the predicate and if a file is present, updates the source
  1272. administration, checks for reconsults, etc.
  1273.  
  1274. The warnings should help explain what is going on here.
  1275. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1276.  
  1277. #if PROTO
  1278. Clause
  1279. assert_term(Word term, char where, Atom file)
  1280. #else
  1281. Clause
  1282. assert_term(term, where, file)
  1283. Word term;
  1284. char where;
  1285. Atom file;
  1286. #endif
  1287. { Clause clause;
  1288.   Procedure proc;
  1289.   Definition def;
  1290.   Module source_module = (file != (Atom) NULL ? modules.source : (Module) NULL);
  1291.   Module module = source_module;
  1292.   static Procedure current = (Procedure) NULL;
  1293.  
  1294.   term = stripModule(term, &module);
  1295.  
  1296.   DEBUG(9, printf("compiling "); pl_write(term); printf(" ... "););
  1297.   if ((clause = compile(term, module)) == (Clause) NULL)
  1298.     return (Clause) NULL;
  1299.   DEBUG(9, printf("ok\n"));
  1300.   proc = clause->procedure;
  1301.   def = proc->definition;
  1302.  
  1303. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1304. If file is defined, we are called from record_clause/2.  This code takes
  1305. care of reconsult, redefinition, etc.
  1306. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1307.  
  1308.   if (file != (Atom) NULL)
  1309.   { SourceFile sf;
  1310.  
  1311.     sf = lookupSourceFile(file);
  1312.  
  1313.     if ( true(def, MULTIFILE) )
  1314.     { if (sf->count != 1)
  1315.       { warning("Multifile predicate %s not updated", procedureName(proc) );
  1316.     freeClause(clause);
  1317.     return (Clause) NULL;
  1318.       }
  1319.       return assertProcedure(proc, clause, where) == FALSE ? (Clause) NULL
  1320.                                : clause;
  1321.     }
  1322.  
  1323.     if (def->module != module)
  1324.     { if ( true(def->module, SYSTEM) )
  1325.         warning("Attempt to redefine a system predicate: %s", 
  1326.                 procedureName(proc));
  1327.       else
  1328.     warning("%s/%d already imported from module %s", 
  1329.                 stringAtom(proc->functor->name), 
  1330.                 proc->functor->arity, 
  1331.                 stringAtom(proc->definition->module->name) );
  1332.       freeClause(clause);
  1333.       return (Clause) NULL;
  1334.     }
  1335.  
  1336.     if (def->source == sf && def->source_count == sf->count)
  1337.     { if (proc != current)
  1338.       { if ( (debugstatus.styleCheck & DISCONTIGUOUS_STYLE) &&
  1339.          false(def, DISCONTIGUOUS) )
  1340.       warning("Clauses of %s are not together in the source file", 
  1341.                 procedureName(proc) );
  1342.     current = proc;
  1343.       }
  1344.  
  1345.       return assertProcedure(proc, clause, where) == FALSE ? (Clause) NULL
  1346.                                : clause;
  1347.     }
  1348.  
  1349.     current = proc;
  1350.  
  1351. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1352. This `if' locks predicates as system predicates  if  we  are  in  system
  1353. mode, the predicate is still undefined and is not dynamic or multifile.
  1354. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1355.  
  1356.     if ( SYSTEM_MODE &&
  1357.      false(def, SYSTEM) &&
  1358.      false(def, DYNAMIC) &&
  1359.      false(def, MULTIFILE) &&
  1360.      def->definition.clauses == (Clause) NULL)
  1361.     { set(def, SYSTEM);
  1362.       set(def, HIDE_CHILDS);
  1363.  
  1364.       def->source = sf;
  1365.       def->source_count = sf->count;
  1366.  
  1367.       return assertProcedure(proc, clause, where) == FALSE ? (Clause) NULL
  1368.                                : clause;
  1369.     }
  1370.  
  1371.     if ( true(def, SYSTEM) && !SYSTEM_MODE )
  1372.     { warning("Attempt to redefine a system predicate: %s", 
  1373.                 procedureName(proc) );
  1374.       freeClause(clause);
  1375.       return (Clause) NULL;
  1376.     }
  1377.  
  1378.     if (def->source != sf)
  1379.     { if (def->definition.clauses != (Clause) NULL)
  1380.       {    abolishProcedure(proc, module);
  1381.     warning("Redefined: %s", procedureName(proc) );
  1382.       }
  1383.       def->source = sf;
  1384.       def->source_count = sf->count;
  1385.     } else
  1386.     { if (def->source_count < sf->count)    /* reconsult */
  1387.       { removeClausesProcedure(proc);
  1388.         def->source = sf;
  1389.           def->source_count = sf->count;
  1390.       }
  1391.     }
  1392.     return assertProcedure(proc, clause, where) == FALSE ? (Clause) NULL
  1393.                              : clause;
  1394.   }
  1395.  
  1396.   /* assert[az]/1 */
  1397.  
  1398.   if ( true(def, SYSTEM) && false(def, DYNAMIC) )
  1399.   { warning("Attempt to redefine a system predicate: %s", 
  1400.                 procedureName(proc) );
  1401.     freeClause(clause);
  1402.     return (Clause) NULL;
  1403.   }
  1404.  
  1405.   if ( def->module != module && false(def, DYNAMIC) )
  1406.   { warning("Attempt to redefine an imported predicate %s", 
  1407.                   procedureName(proc) );
  1408.     freeClause(clause);
  1409.     return (Clause) NULL;
  1410.   }
  1411.   set(def, DYNAMIC);            /* Make dynamic on first assert */
  1412.  
  1413.   return assertProcedure(proc, clause, where) == FALSE ? (Clause) NULL
  1414.                                : clause;
  1415. }
  1416.  
  1417. word
  1418. pl_assertz(term)
  1419. Word term;
  1420. { return assert_term(term, 'z', (Atom)NULL) == (Clause)NULL ? FALSE : TRUE;
  1421. }
  1422.  
  1423. word
  1424. pl_asserta(term)
  1425. Word term;
  1426. { return assert_term(term, 'a', (Atom)NULL) == (Clause)NULL ? FALSE : TRUE;
  1427. }
  1428.  
  1429. word
  1430. pl_assertz2(term, ref)
  1431. Word term, ref;
  1432. { Clause clause = assert_term(term, 'z', (Atom)NULL);
  1433.  
  1434.   if (clause == (Clause)NULL)
  1435.     fail;
  1436.  
  1437.   return unifyAtomic(ref, pointerToNum(clause));
  1438. }
  1439.  
  1440. word
  1441. pl_asserta2(term, ref)
  1442. Word term, ref;
  1443. { Clause clause = assert_term(term, 'a', (Atom)NULL);
  1444.  
  1445.   if (clause == (Clause)NULL)
  1446.     fail;
  1447.  
  1448.   return unifyAtomic(ref, pointerToNum(clause));
  1449. }
  1450.  
  1451. word
  1452. pl_record_clause(term, file)
  1453. Word term, file;
  1454. { if (!isAtom(*file) )
  1455.     fail;
  1456.  
  1457.   return assert_term(term, 'z', (Atom)*file) == (Clause)NULL ? FALSE : TRUE;
  1458. }  
  1459.  
  1460.  
  1461.         /********************************
  1462.         *          DECOMPILER           *
  1463.         *********************************/
  1464.  
  1465. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1466. The decompiler is rather straightforwards.  First it  will  construct  a
  1467. term  with  variables  for  the  head  and an array of variables for all
  1468. variables in  the  clause.   Next  the  head  arguments  are  filled  by
  1469. decompiling  the head code.  Finally the body is decompiled.  The latter
  1470. is slightly more complex as it is given in reverse polish notation.   We
  1471. first  will  skip  the  argument  filling  code,  looking for the actual
  1472. calling code.  This provides us the functor and arity of the  subclause.
  1473. Then we create a term, back up and fill the arguments.
  1474. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1475.  
  1476. #define PC    (di->pc)
  1477. #define XR    (di->xr)
  1478. #define ARGP    (di->argp)
  1479.  
  1480. typedef struct
  1481. { Code    pc;                /* pc for decompilation */
  1482.   Word  xr;                /* xr table for decompilation */
  1483.   Word    argp;                /* argument pointer */
  1484.   Word    variables[MAXVARIABLES];    /* variable table */
  1485. } decompileInfo;
  1486.  
  1487. forwards bool    unifyVar P((Word, Word *, int));
  1488. forwards bool    decompile_head P((Clause, Word, decompileInfo *));
  1489. forwards bool    decompileBody P((decompileInfo *, code, Code));
  1490. forwards void    build_term P((FunctorDef, decompileInfo *));
  1491.  
  1492. static bool
  1493. unifyVar(var, vars, i)
  1494. register Word var;
  1495. register Word vars[];
  1496. register int i;
  1497. { DEBUG(3, printf("unifyVar(%d, %d, %d)\n", var, vars, i) );
  1498.   if (vars[i] == (Word)NULL)
  1499.   { vars[i] = var;
  1500.     succeed;
  1501.   }
  1502.   return (bool) pl_unify(var, vars[i]);
  1503. }
  1504.  
  1505. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1506. decompileHead()  is  public  as  it  is  needed  to  update  the   index
  1507. information  for  clauses  if this changes when the predicate is already
  1508. defined.  Also for intermediate  code  file  loaded  clauses  the  index
  1509. information  is  recalculated  as  the  constants in the XR table may be
  1510. different accross runs.
  1511. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1512.  
  1513. bool
  1514. decompileHead(clause, head)
  1515. Clause clause;
  1516. Word head;
  1517. { decompileInfo di;
  1518.  
  1519.   return decompile_head(clause, head, &di);
  1520. }
  1521.  
  1522. static bool
  1523. decompile_head(clause, head, di)
  1524. Clause clause;
  1525. Word head;
  1526. register decompileInfo *di;
  1527. { int arity;
  1528.   Word argp, argp0;
  1529.  
  1530.   deRef(head);
  1531.  
  1532.   DEBUG(5, printf("Decompiling head of %s\n", procedureName(clause->procedure)));
  1533.   arity = clause->procedure->functor->arity;
  1534.   if (arity == 0)
  1535.   { TRY(unifyAtomic(head, clause->procedure->functor->name) );
  1536.   } else
  1537.   { TRY(unifyFunctor(head, clause->procedure->functor) );
  1538.   }
  1539.   argp0 = argp = argTermP(*head, 0);
  1540.   PC = clause->codes;
  1541.   XR = clause->externals;
  1542.  
  1543.   { register int m;
  1544.     register Word *p;
  1545.  
  1546.     m = VAROFFSET(clause->variables);    /* index of highest var + 1 */
  1547.     for(p = di->variables; m-- > 0;)
  1548.       *p++ = (Word) NULL;
  1549.   }
  1550.  
  1551.   for(;;)
  1552.   { switch(decode(*PC++))
  1553.     { case I_NOP:
  1554.       continue;
  1555.       case H_NIL:
  1556.       TRY(unifyAtomic(argp++, ATOM_nil) );
  1557.       continue;
  1558.       case H_REAL:
  1559.       TRY( unifyAtomic(argp++, globalReal(valReal(XR[*PC++]))) );
  1560.       continue;
  1561. #if O_STRING
  1562.       case H_STRING:
  1563.       TRY( unifyAtomic(argp++, globalString(valString(XR[*PC++]))) );
  1564.       continue;
  1565. #endif /* O_STRING */
  1566.       case H_CONST:
  1567.       TRY(unifyAtomic(argp++, XR[*PC++]) );
  1568.       continue;
  1569.       case H_CONST0:
  1570.       TRY(unifyAtomic(argp++, XR[0]) );
  1571.       continue;
  1572.       case H_CONST1:
  1573.       TRY(unifyAtomic(argp++, XR[1]) );
  1574.       continue;
  1575.       case H_CONST2:
  1576.       TRY(unifyAtomic(argp++, XR[2]) );
  1577.       continue;
  1578.       case H_SINT:
  1579.       TRY(unifyAtomic(argp++, consNumFromCode(*PC++)));
  1580.       continue;
  1581.       case H_FIRSTVAR:
  1582.       case H_VAR:
  1583.       TRY(unifyVar(argp++, di->variables, *PC++) );
  1584.       continue;
  1585.       case H_VOID:
  1586.     { int arg;        /* FIRSTVAR in the head */
  1587.       if ((arg = (int)(argp - argp0)) < arity && arg >= 0)
  1588.         TRY(unifyVar(argp, di->variables, VAROFFSET(arg)) );
  1589.       argp++;
  1590.       continue;
  1591.     }
  1592.       case H_FUNCTOR:
  1593.     { register FunctorDef fdef = (FunctorDef) XR[*PC++];
  1594.  
  1595.       common_functor:
  1596.       TRY(unifyFunctor(argp, fdef) );
  1597.       *aTop++ = argp + 1;
  1598.       verifyStack(argument);
  1599.       deRef(argp);
  1600.       argp = argTermP(*argp, 0);
  1601.       continue;
  1602.       case H_FUNCTOR0:      fdef = (FunctorDef) XR[0];     goto common_functor;
  1603.       case H_FUNCTOR1:      fdef = (FunctorDef) XR[1];     goto common_functor;
  1604.       case H_FUNCTOR2:      fdef = (FunctorDef) XR[2];     goto common_functor;
  1605.       case H_LIST:      fdef = FUNCTOR_dot2;        goto common_functor;
  1606.     }
  1607.       case I_POP:
  1608.       argp = *--aTop;
  1609.       continue;
  1610.       case I_POPN:
  1611.       aTop -= *PC++;
  1612.       argp = *aTop;
  1613.       continue;
  1614.       case I_EXIT:            /* fact */
  1615.       case I_ENTER:            /* fix H_VOID, H_VOID, I_ENTER */
  1616.     { int arg;
  1617.  
  1618.       for(arg = (int)(argp - argp0); arg < arity; arg++)
  1619.        TRY(unifyVar(argp++, di->variables, VAROFFSET(arg)) );
  1620.  
  1621.       succeed;
  1622.     }
  1623.       default:
  1624.       sysError("Illegal instruction in clause head: %d = %d", PC[-1], decode(PC[-1]));
  1625.       fail;
  1626.     }
  1627.   }
  1628. }
  1629.  
  1630. #define isVarRef(w)    (isRef(w) && (int)unRef(w) < MAXVARIABLES \
  1631.                         ? (int)unRef(w) : -1)
  1632.  
  1633. bool
  1634. decompile(clause, term)
  1635. Clause clause;
  1636. Word term;
  1637. { decompileInfo dinfo;
  1638.   register decompileInfo *di = &dinfo;
  1639.   Word head, body;
  1640.  
  1641.   deRef(term);
  1642.  
  1643.   if ((clause->subclauses) == 0)            /* fact */
  1644.   { return decompileHead(clause, term);
  1645.   } else
  1646.   { TRY(unifyFunctor(term, FUNCTOR_prove2) );
  1647.     head = argTermP(*term, 0);
  1648.     body = argTermP(*term, 1); deRef(body);
  1649.   }
  1650.  
  1651.   TRY( decompile_head(clause, head, di) );
  1652.   ARGP = (Word) lTop;
  1653.  
  1654.   decompileBody(di, I_EXIT, (Code) NULL);
  1655.  
  1656.   { word b;
  1657.     int var;
  1658.  
  1659.     setVar(b);
  1660.     ARGP--;
  1661.     if ( (var = isVarRef(*ARGP)) >= 0 )
  1662.       unifyVar(&b, di->variables, var);
  1663.     else
  1664.       b = *ARGP;
  1665.  
  1666.     return (bool) pl_unify(body, &b);
  1667.   }
  1668. }
  1669.  
  1670.  
  1671. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1672. Body decompilation.  A previous version of this part of the code  worked
  1673. top-down,  refining the term given using unification.  This approach has
  1674. three advantages:
  1675.  
  1676.   - Decompilation will fail as soon as  unification  of  generated  code
  1677.     fails.
  1678.   - If the body is instantiated no copy will be created  on  the  global
  1679.     stack, thus saving memory.
  1680.   - Handling variables is somewhat simpler as no intermediate storage is
  1681.     needed.
  1682.  
  1683. Unfortunately it also has some serious disadvantages:
  1684.  
  1685.   - The call/depart code is written in reverse polish notation.   If  we
  1686.     work  top-down  we  will need the functor of the subclause before we
  1687.     can start working on the arguments.  This implies we  have  to  skip
  1688.     the  argument instructions first to find the call/depart instruction
  1689.     and then back-up to fill the arguments, introducing one  more  place
  1690.     where we need to know the WAM code semantics.
  1691.   - With the  introduction  of  nested  reverse  polish  constructs  for
  1692.     arithmic  it  gets  very  difficult  to do the decompilation without
  1693.     using a stack for  intermediate  data  storage,  building  the  term
  1694.     bottom-up.
  1695.  
  1696. In the current implementation the head is decompiled in the  unification
  1697. style  and the head is decompiled using a stack machine.  This takes the
  1698. best of both approaches: the head is not in reverse polish notation  and
  1699. is  not  unlikely  to be instantiated (retract/1), while it is very rare
  1700. that clause/retract are used with instantiated body.
  1701.  
  1702. The decompilation stack is located on top of the local  stack,  as  this
  1703. area is not in use during decompilation.
  1704. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1705.  
  1706. #if PROTO
  1707. static bool
  1708. decompileBody(register decompileInfo *di, code end, Code until)
  1709. #else
  1710. static bool
  1711. decompileBody(di, end, until)
  1712. register decompileInfo *di;
  1713. code end;
  1714. Code until;
  1715. #endif
  1716. { int nested = 0;        /* nesting in FUNCTOR ... POP */
  1717.   int pushed = 0;        /* Subclauses pushed on the stack */
  1718.  
  1719.   for(; decode(*PC) != end && PC != until; )
  1720.   { switch(decode(*PC++))
  1721.     {   case I_NOP:        continue;
  1722.     case B_CONST:
  1723.                 *ARGP++ = XR[*PC++];
  1724.                 continue;
  1725.     case B_REAL:
  1726.                 *ARGP++ = globalReal(valReal(XR[*PC++]));
  1727.                 continue;
  1728.     case B_STRING:
  1729.                 *ARGP++ = globalString(valString(XR[*PC++]));
  1730.                 continue;
  1731.     case B_SINT:
  1732.                 *ARGP++ = consNumFromCode(*PC++);
  1733.                 continue;
  1734.       { register int index;      
  1735.  
  1736.     case B_ARGVAR:
  1737.     case B_ARGFIRSTVAR:
  1738.     case B_FIRSTVAR:
  1739.     case B_VAR:        index = *PC++;        goto var_common;
  1740.     case B_VAR0:        index = VAROFFSET(0);    goto var_common;
  1741.     case B_VAR1:        index = VAROFFSET(1);    goto var_common;
  1742.     case B_VAR2:        index = VAROFFSET(2);    var_common:
  1743.                 if ( nested )
  1744.                   unifyVar(ARGP++, di->variables, index);
  1745.                 else
  1746.                   *ARGP++ = makeRef(index);
  1747.                 continue;
  1748.       }
  1749.       case B_VOID:
  1750.                 setVar(*ARGP++);
  1751.                 continue;
  1752.       case B_FUNCTOR:
  1753.                 *ARGP = globalFunctor((FunctorDef)XR[*PC++]);
  1754.                 *aTop++ = ARGP + 1;
  1755.                 verifyStack(argument);
  1756.                 ARGP = argTermP(*ARGP, 0);
  1757.                 nested++;
  1758.                 continue;
  1759.       case I_POP:
  1760.                 ARGP = *--aTop;
  1761.                 nested--;
  1762.                 continue;
  1763.       case I_POPN:
  1764.                 aTop -= *PC;
  1765.                 nested -= *PC++;
  1766.                 ARGP = *aTop;
  1767.                 continue;
  1768. #if O_COMPILE_ARITH
  1769.       case A_FUNC0:
  1770.       case A_FUNC1:
  1771.       case A_FUNC2:
  1772.                 build_term(functorArithFunction(*PC++), di);
  1773.                 continue;
  1774.       case A_FUNC:
  1775.                       build_term(functorArithFunction(*PC++), di);
  1776.                       PC++;
  1777.                 continue;
  1778. #endif /* O_COMPILE_ARITH */
  1779.       { FunctorDef f;
  1780. #if O_COMPILE_ARITH
  1781.     case A_LT:        f = FUNCTOR_smaller2;    goto f_common;
  1782.     case A_LE:        f = FUNCTOR_smaller_equal2;    goto f_common;
  1783.     case A_GT:        f = FUNCTOR_larger2;    goto f_common;
  1784.     case A_GE:        f = FUNCTOR_larger_equal2;    goto f_common;
  1785.     case A_EQ:        f = FUNCTOR_ar_equals2;    goto f_common;
  1786.     case A_NE:        f = FUNCTOR_ar_not_equal2;    goto f_common;
  1787.     case A_IS:        f = FUNCTOR_is2;        goto f_common;
  1788. #endif /* O_COMPILE_ARITH */
  1789.     case I_APPLY:        f = FUNCTOR_apply2;        f_common:
  1790.                 build_term(f, di);
  1791.                 pushed++;
  1792.                 continue;
  1793.       }
  1794.       case I_CUT:        *ARGP++ = (word) ATOM_cut;
  1795.                 pushed++;
  1796.                 continue;
  1797.       case I_DEPART:
  1798.       case I_CALL:
  1799.                 build_term(((Procedure)XR[*PC++])->functor, di);
  1800.                 pushed++;
  1801.                 continue;
  1802.       case I_USERCALL:
  1803.                 pushed++;
  1804.                 continue;
  1805. #if O_COMPILE_OR
  1806. #define DECOMPILETOJUMP { int to_jump = (int) *PC++; \
  1807.               decompileBody(di, (code)-1, PC+to_jump); \
  1808.             }
  1809.       case C_CUT:
  1810.       case C_VAR:
  1811.       case C_JMP:
  1812.                 PC++;
  1813.                 continue;
  1814.       case C_OR:                /* A ; B */
  1815.                 DECOMPILETOJUMP;    /* A */
  1816.                 PC--;        /* get C_JMP argument */
  1817.                 DECOMPILETOJUMP;    /* B */
  1818.                 build_term(FUNCTOR_semicolon2, di);
  1819.                 pushed++;
  1820.                 continue;
  1821.       case C_NOT:                /* \+ A */
  1822.               { PC += 2;        /* skip the two arguments */
  1823.                 decompileBody(di, C_CUT, (Code)NULL);   /* A */
  1824.                 PC += 3;        /* skip C_CUT <n> and C_FAIL */
  1825.                 build_term(FUNCTOR_not_provable1, di);
  1826.                 pushed++;
  1827.                 continue;
  1828.               }
  1829.       case C_IFTHENELSE:            /* A -> B ; C */
  1830.               { Code adr1;
  1831.                 int jmp;
  1832.  
  1833.                 PC++;        /* skip the 'MARK' variable */
  1834.                 jmp  = (int) *PC++;
  1835.                 adr1 = PC+jmp;
  1836.  
  1837.                 decompileBody(di, C_CUT, (Code)NULL);   /* A */
  1838.                 PC += 2;        /* skip the cut */
  1839.                 decompileBody(di, (code)-1, adr1);        /* B */
  1840.                 build_term(FUNCTOR_ifthen2, di);
  1841.                 PC--;
  1842.                 DECOMPILETOJUMP;    /* C */
  1843.                 build_term(FUNCTOR_semicolon2, di);
  1844.                 pushed++;
  1845.                 continue;
  1846.               }
  1847.       case C_MARK:                /* A -> B */
  1848.                 PC++;
  1849.                 decompileBody(di, C_CUT, (Code)NULL);   /* A */
  1850.                 PC += 2;
  1851.                 decompileBody(di, C_END, (Code)NULL);   /* B */
  1852.                 PC++;
  1853.                 build_term(FUNCTOR_ifthen2, di);
  1854.                 pushed++;
  1855.                 continue;
  1856. #endif /* O_COMPILE_OR */
  1857.       case I_EXIT:
  1858.                 break;
  1859.       default:
  1860.       sysError("Illegal instruction in clause body: %d", PC[-1]);
  1861.       /*NOTREACHED*/
  1862.     }
  1863.   }
  1864.  
  1865.   while( pushed-- > 1)
  1866.     build_term(FUNCTOR_comma2, di);
  1867.  
  1868.   succeed;
  1869. }
  1870.  
  1871. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1872. Build the actual term.  The arguments are on  the  decompilation  stack.
  1873. We  construct a term of requested arity and name, copy `arity' arguments
  1874. from the stack into the term and finally  push  the  term  back  on  the
  1875. stack.
  1876. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1877.  
  1878. static void
  1879. build_term(f, di)
  1880. register FunctorDef f;
  1881. register decompileInfo *di;
  1882. { word term;
  1883.   int arity;
  1884.   register Word a;
  1885.  
  1886.   if ( f->arity == 0 )
  1887.   { *ARGP++ = (word) f->name;
  1888.     return;
  1889.   }    
  1890.  
  1891.   term = globalFunctor(f);
  1892.   arity = f->arity;
  1893.   a = argTermP(term, arity-1);
  1894.  
  1895.   ARGP--;
  1896.   for( ; arity-- > 0; a--, ARGP-- )
  1897.   { register int var;
  1898.  
  1899.     if ( (var = isVarRef(*ARGP)) >= 0 )
  1900.       unifyVar(a, di->variables, var);
  1901.     else
  1902.       *a = *ARGP;
  1903.   }
  1904.   ARGP++;
  1905.  
  1906.   *ARGP++ = term;
  1907. }
  1908.  
  1909.  
  1910. word
  1911. pl_clause(p, term, ref, h)
  1912. Word p, term, ref;
  1913. word h;
  1914. { Procedure proc;
  1915.   Clause clause;
  1916.   Module module = (Module)NULL;
  1917.  
  1918.   if ( ForeignControl(h) == FRG_CUTTED )
  1919.     succeed;
  1920.  
  1921.   if (!isVar(*ref))  
  1922.   { Module defModule;
  1923.     Word head, body;
  1924.  
  1925.     if (!isInteger(*ref))
  1926.       return warning("clause/3: illegal reference");
  1927.  
  1928.     clause = (Clause) numToPointer(*ref);
  1929.     
  1930.     if (!inCore(clause) || !isClause(clause))
  1931.       return warning("clause/3: Invalid integer reference");
  1932.     
  1933.     if (decompile(clause, term) == FALSE)
  1934.       fail;
  1935.  
  1936.     proc = clause->procedure;
  1937.     defModule = proc->definition->module;
  1938.  
  1939.     if (isTerm(*term) && functorTerm(*term) == FUNCTOR_module2)
  1940.     { p = stripModule(p, &module);
  1941.       if (module != defModule)
  1942.     fail;
  1943.     }
  1944.  
  1945.     if (isVar(*p))
  1946.     { if (defModule != MODULE_user &&
  1947.        defModule != contextModule(environment_frame) )
  1948.       { unifyFunctor(p, FUNCTOR_module2);
  1949.     unifyAtomic(argTermP(*p, 0), defModule->name);
  1950.     p = argTermP(*p, 1);
  1951.       }
  1952.     }
  1953.  
  1954.     TRY(splitClause(term, &head, &body));
  1955.     return pl_unify(p, head);
  1956.   }
  1957.  
  1958.   if ( ForeignControl(h) == FRG_FIRST_CALL)
  1959.   { if ( (proc = findProcedure(p)) == (Procedure) NULL ||
  1960.          true(proc->definition, FOREIGN) )
  1961.       fail;
  1962.     clause = proc->definition->definition.clauses;
  1963.   } else
  1964.   { clause = (Clause) ForeignContextAddress(h);
  1965.     proc = clause->procedure;
  1966.   }
  1967.  
  1968.   p = stripModule(p, &module);
  1969.  
  1970.   for(; clause; clause = clause->next)
  1971.   { bool det;
  1972.  
  1973.     if ((clause = findClause(clause, 
  1974.                  proc->functor->arity == 0 ? (Word)NULL
  1975.                                : argTermP(*p, 0), 
  1976.                  proc->definition, &det)) == (Clause)NULL)
  1977.       fail;
  1978.  
  1979.     if (decompile(clause, term) == FALSE)
  1980.       continue;
  1981.     if (unifyAtomic(ref, pointerToNum(clause)) == FALSE)
  1982.       continue;
  1983.  
  1984.     if ( det == TRUE )
  1985.       succeed;
  1986.  
  1987.     ForeignRedo(clause->next);
  1988.   }
  1989.  
  1990.   fail;
  1991. }
  1992.