home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / plbin.zip / pl / src / pl-itf.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  11KB  |  640 lines
  1. /*  pl-itf.c,v 1.8 1993/02/23 13:16:35 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: foreign language interface
  8. */
  9.  
  10. #include "pl-incl.h"
  11. #include "pl-itf.h"
  12.  
  13. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  14. This modules  defines  the  functions  available  to  users  of  foreign
  15. language  code.   Most  of  this  module  just is a small function layer
  16. around primitives, normally provided via macros.   This  module  is  not
  17. responsible for loading foreign language code (see pl-load.c). Note that
  18. on  systems  on which pl-load.c is not portable, one can still use these
  19. functions, link the .o files while linking prolog and call  the  foreign
  20. module's initialisation function from main() in pl-main.c.  PCE normally
  21. is linked this way.
  22. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  23.  
  24.         /********************************
  25.         *           ANALYSIS            *
  26.         *********************************/
  27.  
  28. int
  29. PL_is_var(t)
  30. register Word t;
  31. { return isVar(*t);
  32. }
  33.  
  34. int
  35. PL_is_int(t)
  36. register Word t;
  37. { return isInteger(*t);
  38. }
  39.  
  40. int
  41. PL_is_atom(t)
  42. register Word t;
  43. { return isAtom(*t);
  44. }
  45.  
  46. int
  47. PL_is_float(t)
  48. register Word t;
  49. { return isReal(*t);
  50. }
  51.  
  52. int
  53. PL_is_string(t)
  54. register Word t;
  55. { return isString(*t);
  56. }
  57.  
  58. int
  59. PL_is_term(t)
  60. register Word t;
  61. { return isTerm(*t);
  62. }
  63.  
  64. int
  65. PL_type(t)
  66. register Word t;
  67. { if ( isVar(*t) )        return PL_VARIABLE;
  68.   if ( isInteger(*t) )        return PL_INTEGER;
  69.   if ( isReal(*t) )        return PL_FLOAT;
  70. #if O_STRING
  71.   if ( isString(*t) )        return PL_STRING;
  72. #endif /* O_STRING */
  73.   if ( isAtom(*t) )        return PL_ATOM;
  74.   if ( isTerm(*t) )        return PL_TERM;
  75.  
  76.   return sysError("PL_type(): illegal type");
  77. }
  78.  
  79. double                    /* double for standard arg passing */
  80. PL_float_value(t)
  81. register word t;
  82. { return valReal(t);
  83. }
  84.  
  85. #if O_STRING
  86. char *
  87. PL_string_value(t)
  88. register word t;
  89. { return valString(t);
  90. }
  91. #endif /* O_STRING */
  92.  
  93. char *
  94. PL_list_string_value(t)
  95. register Word t;
  96. { deRef(t);
  97.   return listToString(*t);
  98. }
  99.  
  100. long
  101. PL_integer_value(t)
  102. register word t;
  103. { return valNum(t);
  104. }
  105.  
  106. char *
  107. PL_atom_value(t)
  108. register word t;
  109. { return stringAtom(t);
  110. }
  111.  
  112. functor
  113. PL_functor(t)
  114. register Word t;
  115. { return isTerm(*t) ? (functor) functorTerm(*t) : (functor) NULL;
  116. }
  117.  
  118. atomic
  119. PL_functor_name(f)
  120. register FunctorDef f;
  121. { return (atomic) f->name;
  122. }
  123.  
  124. int
  125. PL_functor_arity(f)
  126. register FunctorDef f;
  127. { return f->arity;
  128. }
  129.  
  130. term
  131. PL_arg(t, n)
  132. register Word t;
  133. register int n;
  134. { register Word a = argTermP(*t, n-1);
  135.  
  136.   deRef(a);
  137.  
  138.   return (term) a;
  139. }
  140.  
  141. term
  142. PL_strip_module(t, m)
  143. term t;
  144. Module *m;
  145. { return (term) stripModule(t, m);
  146. }
  147.  
  148.         /********************************
  149.         *         CONSTRUCTION          *
  150.         *********************************/
  151.  
  152. term
  153. PL_new_term()
  154. { register Word var = allocGlobal(sizeof(word));
  155.  
  156.   setVar(*var);
  157.   return var;
  158. }
  159.  
  160. atomic
  161. PL_new_atom(s)
  162. char *s;
  163. { return (atomic) lookupAtom(s);
  164. }
  165.  
  166. atomic
  167. PL_new_integer(i)
  168. int i;
  169. { return (atomic) consNum(i);
  170. }
  171.  
  172. #if O_STRING
  173. atomic
  174. PL_new_string(s)
  175. char *s;
  176. { return (atomic) globalString(s);
  177. }
  178. #endif /* O_STRING */
  179.  
  180. atomic
  181. PL_new_float(f)
  182. double f;
  183. { return (atomic) globalReal(f);
  184. }
  185.  
  186. functor
  187. PL_new_functor(f, a)
  188. register atomic f;
  189. register int a;
  190. { return (functor) lookupFunctorDef((Atom)f, a);
  191. }
  192.  
  193. bool
  194. PL_unify(t1, t2)
  195. register Word t1, t2;
  196. { return (bool) pl_unify(t1, t2);
  197. }
  198.  
  199. bool
  200. PL_unify_atomic(t, w)
  201. register Word t;
  202. register word w;
  203. { return unifyAtomic(t, w);
  204. }
  205.  
  206. bool
  207. PL_unify_functor(t, f)
  208. register Word t;
  209. register FunctorDef f;
  210. { return unifyFunctor(t, f);
  211. }
  212.  
  213.         /********************************
  214.         *   UNDETERMINISTIC FOREIGNS    *
  215.         ********************************/
  216.  
  217. foreign_t
  218. _PL_retry(v)
  219. long v;
  220. { ForeignRedo(v);
  221. }
  222.  
  223.  
  224. long
  225. PL_foreign_context(h)
  226. long h;
  227. { return ForeignContext(h);
  228. }
  229.  
  230. #ifdef __STDC__
  231. void *
  232. #else
  233. char *
  234. #endif
  235. PL_foreign_context_address(h)
  236. long h;
  237. { return ForeignContextAddress(h);
  238. }
  239.  
  240.  
  241. int
  242. PL_foreign_control(h)
  243. long h;
  244. { return ForeignControl(h);
  245. }
  246.  
  247.  
  248.         /********************************
  249.         *      REGISTERING FOREIGNS     *
  250.         *********************************/
  251.  
  252. static bool registerForeign P((char *, int, Func, va_list));
  253.  
  254. static bool
  255. registerForeign(name, arity, f, args)
  256. char *name;
  257. int arity;
  258. Func f;
  259. va_list args;
  260. { static word input;
  261.   SourceFile sf;
  262.   Procedure proc;
  263.   Definition def;
  264.   int n;
  265.   Module m;
  266.   int attribute;
  267.  
  268.   setVar(input);
  269.   pl_seeing(&input);
  270.   sf = lookupSourceFile((Atom)input);
  271.  
  272.   m = (environment_frame ? contextModule(environment_frame)
  273.              : MODULE_system);
  274.  
  275.   proc = lookupProcedure(lookupFunctorDef(lookupAtom(name), arity), m);
  276.   def = proc->definition;
  277.  
  278.   if ( true(def, SYSTEM) )
  279.     return warning("PL_register_foreign(): Attempt to redefine a system predicate: %s",
  280.                             procedureName(proc));
  281.   if ( def->source != (SourceFile) NULL && def->source != sf )
  282.     warning("PL_register_foreign(): redefined %s", procedureName(proc));
  283.   def->source = sf;
  284.  
  285.   if ( false(def, FOREIGN) && def->definition.clauses != (Clause) NULL )
  286.     abolishProcedure(proc, m);
  287.  
  288.   def->definition.function = f;
  289.   def->indexPattern = 0;
  290.   def->indexCardinality = 0;
  291.   def->flags = 0;
  292.   set(def, FOREIGN|TRACE_ME);
  293.   clear(def, NONDETERMINISTIC);
  294.  
  295.   for(n=0; (attribute = va_arg(args, int)) != 0; n++ )
  296.   { switch( attribute )
  297.     { case PL_FA_NOTRACE:       clear(def, TRACE_ME);    break;
  298.       case PL_FA_TRANSPARENT:       set(def, TRANSPARENT);    break;
  299.       case PL_FA_NONDETERMINISTIC: set(def, NONDETERMINISTIC);    break;
  300.     }
  301.     if ( n > 3 )
  302.       return warning("PL_register_foreign(): %s/%d: argument list not closed",
  303.                                 name, arity);
  304.   }
  305.  
  306.   succeed;
  307. }  
  308.  
  309. #if ANSI && !AIX
  310. bool
  311. PL_register_foreign(char *name, int arity, Func f, ...)
  312. { va_list args;
  313.   bool rval;
  314.  
  315.   va_start(args, f);
  316.   rval = registerForeign(name, arity, f, args);
  317.   va_end(args);
  318.  
  319.   return rval;
  320. }
  321.  
  322. #else
  323.  
  324. bool
  325. PL_register_foreign(va_alist)
  326. va_dcl
  327. { va_list args;
  328.   char *name;
  329.   int arity;
  330.   Func f;
  331.   bool rval;
  332.  
  333.   va_start(args);
  334.   name  = va_arg(args, char *);
  335.   arity = va_arg(args, int);
  336.   f     = va_arg(args, Func);
  337.   rval = registerForeign(name, arity, f, args);
  338.   va_end(args);
  339.  
  340.   return rval;
  341. }
  342. #endif
  343.  
  344.         /********************************
  345.         *        CALLING PROLOG         *
  346.         *********************************/
  347.  
  348. void
  349. PL_mark(buf)
  350. register bktrk_buf *buf;
  351. { Mark(*((mark *)buf));
  352. }
  353.  
  354. void
  355. PL_bktrk(buf)
  356. register bktrk_buf *buf;
  357. { Undo(*((mark *)buf));
  358. }
  359.  
  360. bool
  361. PL_call(t, m)
  362. Word t;
  363. Module m;
  364. { LocalFrame lSave   = lTop;
  365.   LocalFrame envSave = environment_frame;
  366.   Word *     aSave   = aTop;
  367.   bool         rval;
  368.  
  369.   deRef(t);
  370.  
  371.   if ( m == (Module) NULL )
  372.     m = contextModule(environment_frame);
  373.  
  374.   lTop = (LocalFrame) addPointer(lTop, sizeof(LocalFrame));
  375.   verifyStack(local);
  376.   varFrame(lTop, -1) = (word) environment_frame;
  377.  
  378.   gc_status.blocked++;
  379.   rval = interpret(m, *t, TRUE);
  380.   gc_status.blocked--;
  381.  
  382.   lTop            = lSave;
  383.   aTop            = aSave;
  384.   environment_frame = envSave;
  385.  
  386.   return rval;
  387. }  
  388.  
  389.         /********************************
  390.         *            MODULES            *
  391.         *********************************/
  392.  
  393. module
  394. PL_context()
  395. { return (module) contextModule(environment_frame);
  396. }
  397.  
  398. atomic
  399. PL_module_name(m)
  400. register Module m;
  401. { return (atomic) m->name;
  402. }
  403.  
  404. module
  405. PL_new_module(name)
  406. register atomic name;
  407. { return (module) lookupModule((Atom) name);
  408. }
  409.  
  410.         /********************************
  411.         *            SIGNALS            *
  412.         *********************************/
  413.  
  414. #if unix || EMX
  415. void
  416. (*PL_signal(sig, func))()
  417. int sig;
  418. void (*func)();
  419. { void (*old)();
  420.  
  421.   if ( sig < 0 || sig >= MAXSIGNAL )
  422.   { fatalError("PL_signal(): illegal signal number: %d", sig);
  423.     return NULL;
  424.   }
  425.  
  426.   if ( signalHandlers[sig].catched == FALSE )
  427.   { old = signal(sig, func);
  428.     signalHandlers[sig].os = func;
  429.     
  430.     return old;
  431.   }
  432.  
  433.   old = signalHandlers[sig].user;
  434.   signalHandlers[sig].user = func;
  435.  
  436.   return old;
  437. }
  438. #endif
  439.  
  440.  
  441.         /********************************
  442.         *         RESET (ABORTS)    *
  443.         ********************************/
  444.  
  445. typedef struct abort_handle * AbortHandle;
  446.  
  447. static struct abort_handle
  448. { AbortHandle    next;            /* Next handle */
  449.   void        (*function)();        /* The handle itself */
  450. } * abort_head = NULL,
  451.   * abort_tail = NULL;
  452.  
  453.  
  454. void
  455. PL_abort_handle(func)
  456. void (*func)();
  457. { AbortHandle h = (AbortHandle) allocHeap(sizeof(struct abort_handle));
  458.  
  459.   h->next = NULL;
  460.   h->function = func;
  461.  
  462.   if ( abort_head == NULL )
  463.   { abort_head = abort_tail = h;
  464.   } else
  465.   { abort_tail->next = h;
  466.     abort_tail = h;
  467.   }
  468. }
  469.  
  470.  
  471. void
  472. resetForeign()
  473. { AbortHandle h = abort_head;
  474.  
  475.   for(; h; h = h->next)
  476.     (*h->function)();
  477. }
  478.  
  479.  
  480.         /********************************
  481.         *           WARNINGS            *
  482.         *********************************/
  483.  
  484. #if ANSI && !AIX
  485. bool
  486. PL_warning(char *fm, ...)
  487. { va_list args;
  488.  
  489.   va_start(args, fm);
  490.   vwarning(fm, args);
  491.   va_end(args);
  492.  
  493.   fail;
  494. }
  495.  
  496. void
  497. PL_fatal_error(char *fm, ...)
  498. { va_list args;
  499.  
  500.   va_start(args, fm);
  501.   vfatalError(fm, args);
  502.   va_end(args);
  503. }
  504.  
  505. #else
  506.  
  507. bool
  508. PL_warning(va_alist)
  509. va_dcl
  510. { char *fm;
  511.   va_list args;
  512.  
  513.   va_start(args);
  514.   fm = va_arg(args, char *);
  515.   vwarning(fm, args);
  516.   va_end(args);
  517.  
  518.   fail;
  519. }
  520.  
  521. void
  522. PL_fatal_error(va_alist)
  523. va_dcl
  524. { char *fm;
  525.   va_list args;
  526.  
  527.   va_start(args);
  528.   fm = va_arg(args, char *);
  529.   vfatalError(fm, args);
  530.   va_end(args);
  531. }
  532. #endif /* ANSI */
  533.  
  534.         /********************************
  535.         *            ACTIONS            *
  536.         *********************************/
  537.  
  538. bool
  539. PL_action(action, arg)
  540. int action;
  541. void * arg;
  542. { switch(action)
  543.   { case PL_ACTION_TRACE:
  544.       return (bool) pl_trace();
  545.     case PL_ACTION_DEBUG:
  546.       return (bool) pl_debug();
  547.     case PL_ACTION_BACKTRACE:
  548.       backTrace(environment_frame, (int) arg);
  549.       succeed;
  550.     case PL_ACTION_BREAK:
  551.       return (bool) pl_break();
  552.     case PL_ACTION_HALT:
  553.       return (bool) pl_halt();
  554.     case PL_ACTION_ABORT:
  555.       return (bool) pl_abort();
  556.     case PL_ACTION_SYMBOLFILE:
  557.       loaderstatus.symbolfile = lookupAtom((char *) arg);
  558.       succeed;
  559.     case PL_ACTION_WRITE:
  560.       Putf("%s", (char *)arg);
  561.       succeed;
  562.     case PL_ACTION_FLUSH:
  563.       pl_flush();
  564.       succeed;
  565.     default:
  566.       sysError("PL_action(): Illegal action: %d", action);
  567.       /*NOTREACHED*/
  568.       fail;
  569.   }
  570. }
  571.  
  572.         /********************************
  573.         *         QUERY PROLOG          *
  574.         *********************************/
  575.  
  576. static int c_argc = -1;
  577. static char **c_argv;
  578.  
  579. static void
  580. init_c_args()
  581. { if ( c_argc == -1 )
  582.   { int i;
  583.  
  584.     c_argv = alloc_heap(mainArgc * sizeof(char *));
  585.     c_argv[0] = mainArgv[0];
  586.     c_argc = 1;
  587.  
  588.     for(i=1; i<mainArgc; i++)
  589.     { if ( mainArgv[i][0] == '-' )
  590.       { switch(mainArgv[i][1])
  591.     { case 'x':
  592.       case 'g':
  593.       case 'd':
  594.       case 'f':
  595.       case 't':
  596.         i++;
  597.         continue;
  598.       case 'B':
  599.       case 'L':
  600.       case 'G':
  601.       case 'O':
  602.       case 'T':
  603.       case 'A':
  604.       case 'P':
  605.         continue;
  606.     }
  607.       }
  608.       c_argv[c_argc++] = mainArgv[i];
  609.     }
  610.   }
  611. }
  612.  
  613.  
  614. long
  615. PL_query(query)
  616. int query;
  617. { switch(query)
  618.   { case PL_QUERY_ARGC:
  619.       init_c_args();
  620.       return (long) c_argc;
  621.     case PL_QUERY_ARGV:
  622.       init_c_args();
  623.       return (long) c_argv;
  624.     case PL_QUERY_SYMBOLFILE:
  625.       if ( getSymbols() == FALSE )
  626.     return (long) NULL;
  627.       return (long) stringAtom(loaderstatus.symbolfile);
  628.     case PL_QUERY_ORGSYMBOLFILE:
  629.       if ( getSymbols() == FALSE )
  630.     return (long) NULL;
  631.       return (long) stringAtom(loaderstatus.orgsymbolfile);
  632.     case PL_QUERY_GETC:
  633.       return (long) GetChar();
  634.     default:
  635.       sysError("PL_query: Illegal query: %d", query);
  636.       /*NOTREACHED*/
  637.       fail;
  638.   }
  639. }
  640.