home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / plbin.zip / pl / src / pl-pro.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  11KB  |  404 lines
  1. /*  pl-pro.c,v 1.3 1993/02/23 13:16:41 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: Support for virtual machine
  8. */
  9.  
  10. #include "pl-incl.h"
  11.  
  12.         /********************************
  13.         *    CALLING THE INTERPRETER    *
  14.         *********************************/
  15.  
  16. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  17. Starts a new Prolog toplevel.  Resets I/O to point to the user and stops
  18. the debugger.  Restores I/O and debugger on exit.  The Prolog  predicate
  19. `$break' is called to actually built the break environment.
  20. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  21.  
  22. word
  23. pl_break()
  24. { word goal = (word) ATOM_break;
  25.  
  26.   return pl_break1(&goal);
  27. }
  28.  
  29. word
  30. pl_break1(goal)
  31. Word goal;
  32. { extern int Input, Output;
  33.   bool rval;
  34.  
  35.   int         inSave    = Input;
  36.   int         outSave   = Output;
  37.   long         skipSave  = debugstatus.skiplevel;
  38.   bool         traceSave = debugstatus.tracing;
  39.   bool         debugSave = debugstatus.debugging;
  40.   int         suspSave  = debugstatus.suspendTrace;
  41.  
  42.   Input = 0;
  43.   Output = 1;
  44.  
  45.   debugstatus.tracing = FALSE;
  46.   debugstatus.debugging = FALSE;
  47.   debugstatus.skiplevel = 0;
  48.   debugstatus.suspendTrace = 0;
  49.  
  50.   rval = callGoal(MODULE_user, *goal, FALSE);
  51.  
  52.   debugstatus.suspendTrace = suspSave;
  53.   debugstatus.skiplevel    = skipSave;
  54.   debugstatus.debugging    = debugSave;
  55.   debugstatus.tracing      = traceSave;
  56.  
  57.   Output = outSave;
  58.   Input = inSave;
  59.  
  60.   return rval;
  61. }
  62.  
  63. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  64. Call a prolog goal from C. The argument must  be  an  instantiated  term
  65. like for the Prolog predicate call/1.  The goal is executed in a kind of
  66. break environment and thus bindings which result of the call are lost.
  67. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  68.  
  69. bool
  70. callGoal(module, goal, debug)
  71. Module module;
  72. word goal;
  73. bool debug;
  74. { LocalFrame lSave   = lTop;
  75.   LocalFrame envSave = environment_frame;
  76.   mark       m;
  77.   Word *     aSave = aTop;
  78.   bool         rval;
  79.  
  80.   lTop = (LocalFrame)addPointer(lTop, sizeof(struct localFrame) +
  81.                       MAXARITY * sizeof(word));
  82.   lTop = (LocalFrame) addPointer(lTop, sizeof(LocalFrame));
  83.   verifyStack(local);
  84.   varFrame(lTop, -1) = (word) environment_frame;
  85.  
  86.   Mark(m);
  87. /*  lockMark(&m); */
  88.   gc_status.blocked++;
  89.   rval = interpret(module, goal, debug);
  90.   gc_status.blocked--;
  91.   Undo(m);
  92. /*  unlockMark(&m); */
  93.   lTop = lSave;
  94.   aTop = aSave;
  95.   environment_frame = envSave;
  96.  
  97.   return rval;
  98. }
  99.  
  100. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  101. Bring the Prolog system itself to life.  Prolog  saves  the  C-stack  to
  102. enable  aborts.   pl_abort()  will  close  open  files, reset all clause
  103. references to `0' and finally long_jumps back to prolog().
  104. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  105.  
  106. static jmp_buf abort_context;        /* jmp buffer for abort() */
  107.  
  108. word
  109. pl_abort()
  110. { if (critical > 0)            /* abort in critical region: delay */
  111.   { aborted = TRUE;
  112.     succeed;
  113.   }
  114.   PopTty(&ttytab);
  115.   resetRead();
  116.   closeFiles();
  117.   resetReferences();
  118.   resetForeign();
  119. #if O_PROFILE
  120.   pl_reset_profiler();
  121. #endif
  122.  
  123.   longjmp(abort_context, 1);
  124.   /*NOTREACHED*/
  125.   fail;
  126. }
  127.  
  128.  
  129. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  130. Initial entry point from C to start  the  Prolog  engine.   Saves  abort
  131. context,  clears  the  stack  and  finally  starts  the  virtual machine
  132. interpreter with the toplevel goal.
  133. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  134.  
  135. bool
  136. prolog(goal)
  137. volatile word goal;
  138. { if (setjmp(abort_context) != 0)
  139.   { goal = (word) ATOM_abort;
  140.   } else
  141.   { debugstatus.debugging = FALSE;
  142.   }
  143.  
  144.   lTop = (LocalFrame) addPointer(lBase, sizeof(LocalFrame));
  145.   varFrame(lTop, -1) = (word) NULL;
  146.   tTop = tBase;
  147.   gTop = gBase;
  148.   aTop = aBase;
  149.   pTop = pBase;
  150.   gc_status.blocked   = 0;
  151.   gc_status.requested = FALSE;
  152.   status.arithmetic   = 0;
  153.  
  154.   debugstatus.tracing = FALSE;
  155.   debugstatus.suspendTrace = 0;
  156.  
  157.   return interpret(MODULE_system, goal, FALSE);
  158. }
  159.  
  160. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  161. Cut (!) as called via the  meta-call  mechanism has no effect.
  162. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  163.  
  164. word
  165. pl_metacut()
  166. { succeed;
  167. }
  168.  
  169.  
  170.         /********************************
  171.         *          UNIFICATION          *
  172.         *********************************/
  173.  
  174. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  175. Unify is the general unification procedure.   This  raw  routine  should
  176. only be called by interpret as it does not undo bindings made during the
  177. unification  in  case  the  unification fails.  pl_unify() (implementing
  178. =/2) does undo bindings and should be used by foreign predicates.
  179.  
  180. Unification depends on the datatypes available in the system and will in
  181. general need updating if new types are added.  It should be  noted  that
  182. unify()  is  not  the only place were unification happens.  Other points
  183. are:
  184.   - various of the virtual machine instructions
  185.   - various macros, for example APPENDLIST and CLOSELIST
  186.   - unifyAtomic(), unifyFunctor(): unification of atomic data.
  187.   - various builtin predicates. They should be flagged some way.
  188.  
  189. The Gould does not accept the construct (word)t1 = *t1.  This implies we
  190. have to define extra variables, slowing down execution a bit (on the SUN
  191. this trick saves about 10% on this function).
  192. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  193.  
  194. #if !O_NO_LEFT_CAST
  195. #define w1 ((word)t1)
  196. #define w2 ((word)t2)
  197. #endif
  198.  
  199. bool
  200. unify(t1, t2)
  201. register Word t1, t2;
  202. {
  203. #if O_NO_LEFT_CAST
  204.   register word w1, w2;
  205. #endif
  206.  
  207.   deRef(t1);  
  208.   deRef(t2);
  209.  
  210.   if (isVar(*t1) )
  211.   { if (isVar(*t2) )
  212.     { if (t1 < t2)        /* always point downwards */
  213.       { Trail(t2);
  214.         *t2 = makeRef(t1);
  215.     succeed;
  216.       }
  217.       if (t1 == t2)
  218.     succeed;
  219.       Trail(t1);
  220.       *t1 = makeRef(t2);
  221.       succeed;
  222.     }
  223.     Trail(t1);
  224.     *t1 = *t2;
  225.     succeed;
  226.   }
  227.   if (isVar(*t2) )
  228.   { Trail(t2);
  229.     *t2 = *t1;
  230.     succeed;
  231.   }
  232.  
  233.   if ( (w1 = *t1) == (w2 = *t2) )
  234.     succeed;
  235.   if ( mask(w1) != mask(w2) )
  236.     fail;
  237.  
  238.   if ( mask(w1) != 0 )
  239.   { if ( !isIndirect(w1) )
  240.       fail;
  241. #if O_STRING
  242.     if ( isString(w1) && isString(w2) && equalString(w1, w2) )
  243.       succeed;
  244. #endif /* O_STRING */
  245.     if ( isReal(w1) && isReal(w2) && valReal(w1) == valReal(w2) )
  246.       succeed;
  247.     fail;
  248.   }
  249.  
  250. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  251. Now both w1 and w2 can still represent a term or an atom.  If  both  are
  252. atoms  they are not the same atom.  We can do a quick and dirty test for
  253. atom as it is not a variable, nor a masked type.
  254. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  255.  
  256.   { register int arity;
  257.     register FunctorDef fd;
  258.  
  259.     if ( pointerIsAtom(w1) || 
  260.      pointerIsAtom(w2) ||
  261.      (fd = functorTerm(w1)) != functorTerm(w2) )
  262.       fail;
  263.  
  264.     arity = fd->arity;
  265.     t1 = argTermP(w1, 0);
  266.     t2 = argTermP(w2, 0);
  267.     for(; arity > 0; arity--, t1++, t2++)
  268.       if (unify(t1, t2) == FALSE)
  269.     fail;
  270.   }
  271.  
  272.   succeed;
  273. }
  274.  
  275. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  276. unify_atomic(p, a) is normally called through unifyAtomic(). It  unifies
  277. a  term,  represented  by  a pointer to it, with an atomic value.  It is
  278. intended for foreign language functions.
  279. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  280.  
  281. bool
  282. unify_atomic(p, a)
  283. register Word p;
  284. word a;
  285. { deRef(p);
  286.  
  287.   if (*p == a)
  288.     succeed;
  289.  
  290.   if (isVar(*p) )
  291.   { Trail(p);
  292.     *p = a;
  293.     succeed;
  294.   }
  295.  
  296.   if (isIndirect(a) && isIndirect(*p) )
  297.   { if (isReal(a) && isReal(*p) && valReal(a) == valReal(*p))
  298.       succeed;
  299. #if O_STRING
  300.     if (isString(a) && isString(*p) && equalString(a, *p))
  301.       succeed;
  302. #endif /* O_STRING */
  303.   }
  304.  
  305.   fail;
  306. }
  307.  
  308. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  309. Unify a (pointer to a) term with a functor (is name/arity pair).  If the
  310. term is instantiated to a term of the name and arity  indicated  by  the
  311. functor  this  call just succeeds.  If the term is a free variable it is
  312. bound to a term whose arguments are all variables.  Otherwise this  call
  313. fails.
  314. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  315.  
  316. bool
  317. unifyFunctor(term, functor)
  318. register Word term;
  319. register FunctorDef functor;
  320. { if (functor->arity == 0)
  321.     return unifyAtomic(term, functor->name);
  322.  
  323.   deRef(term);
  324.  
  325.   if (isVar(*term) )
  326.   { Trail(term);
  327.     *term = globalFunctor(functor);
  328.     succeed;
  329.   }
  330.   if (isTerm(*term) && functorTerm(*term) == functor)
  331.     succeed;
  332.  
  333.   fail;
  334. }
  335.  
  336. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  337. checkData(p) verifies p points to valid  Prolog  data  and  generates  a
  338. system  error  otherwise.  The checks performed are much more rigid than
  339. those during normal execution.  Arity of terms is limited to  100  as  a
  340. kind of heuristic.
  341.  
  342. Note that we expect terms on the global stack.   This  is  true  in  the
  343. interpreter,  but  not everywere in the system (records use terms on the
  344. heap).
  345. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  346.  
  347. #define onGlobal(p) ((char *)p >= (char *)gBase && (char *)p <= (char *)gTop)
  348. #define onLocal(p) ((char *)p >= (char *)lBase && (char *)p <= (char *)lTop)
  349. #define onHeap(  p) ((char *)p >= (char *)hBase && (char *)p <= (char *)hTop)
  350.  
  351. #if TEST
  352. void
  353. checkData(p)
  354. register Word p;
  355. { int arity; int n;
  356.   register Word p2;
  357.  
  358.   if (isVar(*p))
  359.     return;
  360.   while(isRef(*p))
  361.   { p2 = unRef(*p);
  362.     if (p2 > p)
  363.       sysError("Reference to higher address");
  364.     if (!onLocal(p2) && !onGlobal(p2) && !onHeap(p2))
  365.       sysError("Illegal reference pointer: 0x%x", *p);
  366.     return checkData(p2);
  367.   }
  368.   if ((*p & MASK_MASK) == INT_MASK)
  369.     return;
  370.   if ((*p & MASK_MASK) == REAL_MASK)
  371.   { p2 = (Word)unMask(*p);
  372.     if (!onGlobal(p2) && !onHeap(p2))
  373.       sysError("Illegal real: 0x%x", *p);
  374.     return;
  375.   }
  376. #if O_STRING
  377.   if ((*p & MASK_MASK) == STRING_MASK)
  378.   { p2 = (Word)unMask(*p);
  379.     if (!onGlobal(p2) && !onHeap(p2))
  380.       sysError("Illegal string: 0x%x", *p);
  381.     if ( sizeString(*p) != strlen(valString(*p)) )
  382.       sysError("String has inconsistent length: 0x%x", *p);
  383.     return;
  384.   }
  385. #endif /* O_STRING */
  386.   if (onHeap(*p) && !onGlobal(*p))
  387.   { if (((Atom)(*p))->type != ATOM_TYPE)
  388.       sysError("Illegal atom: 0x%x", *p);
  389.     succeed;
  390.   }
  391.   if (!onGlobal(*p))
  392.     warning("Term not on global stack: 0x%x", *p);
  393.   if (functorTerm(*p)->type != FUNCTOR_TYPE)
  394.     sysError("Illegal term: 0x%x", *p);
  395.   arity = functorTerm(*p)->arity;
  396.   if (arity <= 0 || arity > 100)
  397.     sysError("Illegal arity");
  398.   for(n=0; n<arity; n++)
  399.     checkData(argTermP(*p, n));
  400.  
  401.   return;
  402. }
  403. #endif /* TEST */
  404.