API tools faq
paste
logicmoo

lsp_prolog.c

logicmoo
Apr 3rd, 2015
582
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
C 46.46 KB | None | 0 0
raw download clone embed print report
  1. /******************************* INFO ******************************
  2.     Part of Logicmoo
  3.     Author:  Douglas R. Miles
  4.     E-mail: logicmoo@gmail.com, dmiles@users.sourceforge.net
  5.     http://prologmoo.com
  6.     http://logicmoo.sourceforge.net
  7.  
  8.     This library is free software;you can redistribute it and/or
  9.     modify it under the terms of the GNU Lesser General Public
  10.     License as published by the Free Software Foundation;either
  11.     version 2.1 of the License, or (at your option) any later version.
  12.     This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;without even the implied warranty of
  13.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  14.     Lesser General Public License for more details.
  15.     You should have received a copy of the GNU Lesser General Public
  16.     License along with this library;if not, unify to the Free Software
  17.     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  18.  
  19.     Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
  20.     Copyright (c) 1990, Giuseppe Attardi.
  21.     Copyright (c) 2001, Juan Jose Garcia Ripoll.
  22.     Copyright (c) 2006,2015 Douglas R. Miles
  23.  
  24.     ECL is free software; you can redistribute it and/or
  25.     modify it under the terms of the GNU Library General Public
  26.     License as published by the Free Software Foundation; either
  27.     version 2 of the License, or (at your option) any later version.
  28.  
  29.     See file '../Copyright' for full details.
  30.  
  31.  
  32. ;;; ----------------------------------------------------------------------
  33. ;;; Unify instructions
  34.  
  35. (docfun si::dereference function (locative) "
  36. ECL specific.
  37. Given LOCATIVE, it returns the object to which it points. If the
  38. location is unbound, the value returned is OBJNULL.")
  39.  
  40. (docfun si::locativep function (object) "
  41. ECL specific.
  42. Returns true if OBJECT is bound to a locative.")
  43.  
  44. (docfun si::make-variable function (name) "
  45. ECL specific.
  46. Creates a new logical variable with name name implemented as a cons.
  47. Name is used just for printing purposes.")
  48.  
  49. (docfun si::get-constant function (constant object) "
  50. ECL specific.
  51. The value of OBJECT is unified with the constant CONSTANT.
  52. Returns T if successful, otherwise NIL.")
  53.  
  54. (docfun si::get-cons function (object) "
  55. ECL specific.
  56. The value of OBJECT is unified with a CONS cell.
  57. Returns T if successful, otherwise NIL.")
  58.  
  59. (docfun si::get-instance function (object claz arity) "
  60. ECL specific.
  61. The value of OBJECT is unified with an instance of claz CLASS
  62. with ARITY number of slots.
  63. Returns T if successful, otherwise NIL.")
  64.  
  65. (docfun si::get-value function (variable object) "
  66. ECL specific.
  67. The value of VARIABLE and OBJECT are unified.
  68. Returns T if successful, otherwise NIL.")
  69.  
  70. (docfun get-variable macro (variable object) "
  71. ECL specific.
  72. Identical to SETQ: assigns to the variable VARIABLE the value OBJECT.")
  73.  
  74. (docfun si::get-nil function (object) "
  75. ECL specific.
  76. The value of OBJECT is unified with the constant NIL.
  77. Returns T if successful, otherwise NIL.")
  78.  
  79. (docfun si::trail-mark function () "
  80. ECL specific.
  81. Sets up a choice point by putting a mark on the trail stack for
  82. backtracking.")
  83.  
  84. (docfun si::trail-restore function () "
  85. ECL specific.
  86. Unwinds the trail stack up to the latest choice point.")
  87.  
  88. (docfun si::trail-unmark function () "
  89. ECL specific.
  90. Does a TRAIL-RESTORE and also removes the latest choice point.")
  91.  
  92. (docfun si::unboundp function (locative) "
  93. ECL specific.
  94. Returns true if LOCATIVE is bound to OBJNULL.")
  95.  
  96. (docfun si::unify-constant function (constant) "
  97. ECL specific.
  98. Read mode: the next subterm is unified with the constant CONSTANT.
  99. Write mode: the constant constant is stored as the next subterm.")
  100.  
  101. (docfun si::unify-nil function () "
  102. ECL specific.
  103. Read mode: the next subterm is unified with the constant NIL.
  104. Write mode: the constant NIL is stored as the next subterm.")
  105.  
  106. (docfun si::unify-value function (variable) "
  107. ECL specific.
  108. Read mode: the value of VARIABLE is unified with the next subterm.
  109. Write mode: the value of VARIABLE is stored as the next subterm.")
  110.  
  111. (docfun si::unify-variable macro (variable) "
  112. ECL specific.
  113. Read mode: VARIABLE is assigned the next subterm.
  114. Write mode: a new variable is stored in VARIABLE as the next subterm.")
  115.  
  116. */
  117. #ifndef O_LOGICMOO
  118.     #define O_LOGICMOO
  119. #endif
  120. #ifndef ECL_THREADS
  121.     #define ECL_THREADS
  122. #endif
  123.  
  124. /*
  125. //#include "winsock2.h"
  126. //#define EXE "ecls"
  127. //#define O_MULTPLE_ENGINES
  128. #include <errno.h>
  129. #include <limits.h>
  130. #include <stdlib.h>
  131. #include <limits.h>
  132. #undef ulong
  133. #define ulong unsigned long
  134. */
  135.  
  136. #include "SWI-Prolog.h"
  137.  
  138. #include <ecl/ecl.h>
  139.  
  140. #ifdef __cplusplus
  141.     #define CPPSYM "C"
  142. extern void CPPSYM init_LSP(cl_object);
  143. extern void CPPSYM init_CLOS(cl_object);
  144. extern void CPPSYM init_ECL_xS(cl_object);
  145. #else
  146.     #define CPPSYM
  147. #endif
  148.  
  149. void init_LSP(cl_object o) {
  150. }
  151. //void init_CLOS(cl_object o) {}
  152. //void init_ECL_xS(cl_object o) {}
  153.  
  154.  
  155. extern cl_symbol_initializer cl_symbols[];
  156. extern cl_index cl_num_symbols_in_core;
  157. extern struct cl_core_struct cl_core;
  158.  
  159. //#include <pthread.h>
  160. //#define PTHREAD_H
  161. //#include "pl-incl.h"
  162. //#include <ecl/internal.h>
  163. //#include <ecl/external.h>
  164. //#include"pl-logicmoo.h"
  165.  
  166.  
  167. #define ENUM_VAL(name,val) val
  168. #define HAS_VALUE(val) (val!=0 && val!=Cnil && val!=ECL_UNBOUND)
  169.  
  170. #undef LD
  171. #define LD LOCAL_LD
  172.  
  173. #define PL_current_engine_ptr LOCAL_LD
  174.  
  175. #define LOCAL_LD PL_current_local_data()
  176.  
  177. #define GLOBAL_LD   PL_current_engine_ptr
  178.  
  179. #define GET_LD      PL_engine_t __PL_ld = GLOBAL_LD;
  180.  
  181. #define PRED_LD   PL_engine_t __PL_ld = PL__ctx->engine;
  182.  
  183. #define ARG1_LD   PL_engine_t __PL_ld
  184. #define ARG_LD    , ARG1_LD
  185. #define PASS_LD1  __PL_ld
  186. #define PASS_LD   , PASS_LD1
  187.  
  188.  
  189. extern PL_engine_t  PL_current_local_data(void);
  190.  
  191. #ifndef PL_arg
  192.     #define PL_arg _PL_arg
  193. #endif
  194.  
  195. typedef void* Table;        /* (numeric) hash table */
  196. typedef struct symbol *     Symbol;     /* symbol of hash table */
  197. typedef struct table_enum * TableEnum;  /* Enumerate table entries */
  198.  
  199. struct symbol {
  200.     Symbol    next;     /* next in chain */
  201.     void *    name;     /* name entry of symbol */
  202.     void *    value;    /* associated value with name */
  203. };
  204.  
  205. struct table_enum {
  206.     Table     table;    /* Table we are working on */
  207.     int       key;      /* Index of current symbol-chain */
  208.     Symbol    current;  /* The current symbol */
  209.     TableEnum next;     /* More choice points */
  210. };
  211.  
  212. typedef struct foreign_context* context_t;
  213.  
  214. typedef enum {
  215.     FRG_FIRST_CALL = 0,     /* Initial call */
  216.     FRG_CUTTED     = 1,     /* Context was cutted */
  217.     FRG_REDO   = 2      /* Normal redo */
  218. } frg_code;
  219.  
  220. struct foreign_context {
  221.     unsigned long     context;  /* context value */
  222.     frg_code      control;  /* FRG_* action */
  223.     PL_engine_t engine; /* invoking engine */
  224. };
  225.  
  226.  
  227. #define PL_IMPORT(type) extern type
  228.  
  229. PL_IMPORT(Table)        newHTable(int size);
  230. PL_IMPORT(void)         destroyHTable(Table ht);
  231. PL_IMPORT(Symbol)       lookupHTable(Table ht, void *name);
  232. PL_IMPORT(Symbol)       addHTable(Table ht, void *name, void *value);
  233. PL_IMPORT(void)         deleteSymbolHTable(Table ht, Symbol s);
  234. PL_IMPORT(Table)        copyHTable(Table org);
  235. PL_IMPORT(TableEnum)    newTableEnum(Table ht);
  236. PL_IMPORT(void)         freeTableEnum(TableEnum e);
  237. PL_IMPORT(Symbol)       advanceTableEnum(TableEnum e);
  238. PL_IMPORT(void)         clearHTable(Table ht);
  239.  
  240.  
  241. //extern cl_object *alloc_relblock();
  242. // vs_top
  243.  
  244.  
  245. extern bool ecl_booted;
  246.  
  247. /******************************* EXPORTS ******************************/
  248. bool prolog_installed_to_lisp = 0;
  249. bool lisp_installed_to_prolog = 0;
  250.  
  251.  
  252. #define SET_UNIFY_HOOK_BY_NAME(hookname) SET_UNIFY_HOOK(#hookname, t_ ## hookname, unify_object)
  253. #define SET_UNIFY_HOOK(hookchars,tname,cfnct) LPGlobal.type_atom[(int)tname ]=PL_new_atom( hookchars ); addHTable(LPGlobal.typeNameAtoms,(void*)LPGlobal.type_atom[(int)tname ],(void*) tname ); LPGlobal.unify_hook[(int)tname ] = cfnct
  254.  
  255.  
  256.  
  257. typedef struct LPEngine_data* LPEnv;
  258.  
  259. typedef foreign_t (*unify_hook_ptr) (term_t, cl_object* , LPEnv , context_t PL__ctx);
  260.  
  261. #define IMPL_UNIFY(FTYPE) foreign_t unify_ ## FTYPE (term_t plterm, cl_object* slot1  , LPEnv lp  , context_t PL__ctx)
  262. IMPL_UNIFY(object);
  263. #define INIT_ATOM(name) ATOM_ ## name = PL_new_atom(#name)
  264. #define DECL_ATOM(name) static ATOM_ ## name
  265.  
  266. typedef struct LPGlobal_data {
  267.     LPEnv main; // == &LPToplevel means this is contains valid data
  268.     unify_hook_ptr unify_hook[128];
  269.     PL_atomic_t type_atom[128];
  270.     Table typeNameAtoms;
  271.     struct cl_core_struct* lisp_core;
  272.     Table typeSignatures;
  273.     cl_object prolog_package;
  274.     cl_object SLogicmoo;
  275.     cl_object prolog_class;
  276.     cl_object prolog_signature;
  277.     cl_object fsym_prolog_toplevel;
  278. } LPGlobalData;
  279.  
  280. typedef struct LPEngine_data {
  281.     LPGlobalData* global; // == &LPGlobal means this is contains valid data
  282.     // pthread_t *cthread;  // if !=0 then this is the pthread
  283.     struct cl_env_struct* lisp;
  284.     PL_engine_t prolog;
  285.     Table keyToSymbol;      /* termToLisp --> value */
  286.     int   c_keyToSymbol;    /* references to atomToLisp */
  287.     Table symbolToAtom; /* references to varables stored in this list */
  288.     int    c_symbolToAtom;          /* references to symbolToTerm */
  289. } LPEngineData;
  290.  
  291.  
  292. LPGlobalData LPGlobal;
  293. LPEngineData LPToplevel;
  294.  
  295.  
  296. #define LPEngine ((LPEnv)LPGlobal.main)
  297. #ifndef LPEngine
  298. LPEngine_data* LPEngine;
  299.     #define LPEngine ((LPEnv)&LPToplevel);
  300. #endif
  301.  
  302. //static PL_atomic_t ATOM_execute;
  303. //static PL_atomic_t ATOM_read;
  304. static PL_atomic_t ATOM_T;
  305. static PL_atomic_t ATOM_user;
  306. static PL_atomic_t ATOM_ecls;
  307. static PL_atomic_t ATOM_term;
  308. static PL_atomic_t ATOM_true;
  309. static PL_atomic_t ATOM_att;
  310. static PL_atomic_t ATOM_clos;
  311. static PL_atomic_t ATOM_clos_classes;
  312. static PL_atomic_t ATOM_cons;
  313. static PL_atomic_t ATOM_creationType_hash;
  314. static PL_atomic_t ATOM_creationType_link;
  315. static PL_atomic_t ATOM_dot;
  316. static PL_atomic_t ATOM_enumerate_hash;
  317. static PL_atomic_t ATOM_freeze;
  318. static PL_atomic_t ATOM_nil;
  319. static PL_atomic_t ATOM_lisp_object;
  320. static PL_atomic_t ATOM_lisp_slot;
  321. static PL_atomic_t ATOM_lisp_symbol;
  322. static PL_atomic_t ATOM_lisp_type;
  323. static PL_atomic_t ATOM_query_value;
  324. static PL_atomic_t ATOM_unify_value;
  325.  
  326. static functor_t FUNCTOR_lisp_thaw1;
  327. static functor_t FUNCTOR_lisp_error2;
  328. static functor_t FUNCTOR_freeze2;
  329. static functor_t FUNCTOR_att3;
  330. static functor_t FUNCTOR_lisp_slot1;
  331. static functor_t FUNCTOR_clos2;
  332.  
  333. static module_t MODULE_user;
  334. static module_t MODULE_ecls;
  335. static module_t MODULE_system;
  336.  
  337. foreign_t isAssignable(cl_type c1, cl_type c2) {
  338.     if (c1==c2 || c2==(int)t_end)   return 1;
  339.     return -1;
  340. }
  341.  
  342. cl_type atomToType(PL_atomic_t name) {
  343.     Symbol s = lookupHTable((void*)LPGlobal.typeNameAtoms, (void*)name);
  344.     return(s==0?t_end:(cl_type)s->value);
  345. }
  346.  
  347. cl_object  find_package_icase(cl_object pkname) {
  348.     cl_object package = Cnil;
  349.     switch (type_of(pkname)) {
  350.         case t_string:
  351.             return ecl_find_package_nolock(pkname);
  352.         case t_package:
  353.             return pkname;
  354.         case t_symbol:
  355.             {
  356.                 cl_object* pslot = ecl_symbol_slot(pkname);
  357.                 if (pslot) {
  358.                     if (HAS_VALUE(*pslot))  package =  find_package_icase(*pslot);
  359.                     if (HAS_VALUE(package)) return package;
  360.                 }
  361.             }
  362.             if (HAS_VALUE(pkname->symbol.value)) {
  363.                 package =  find_package_icase(pkname->symbol.value);
  364.                 if (HAS_VALUE(package)) return package;
  365.             }
  366.             if (HAS_VALUE(pkname->symbol.hpack)) {
  367.                 package =  find_package_icase(pkname->symbol.hpack);
  368.                 if (HAS_VALUE(package)) return package;
  369.             }
  370.             if (pkname->symbol.name) {
  371.                 package =  ecl_find_package_nolock(pkname->symbol.name);
  372.                 if (HAS_VALUE(package)) return package;
  373.             }
  374.         default:
  375.             return current_package();
  376.     }
  377. }
  378.  
  379. static void* err_goto = NULL;
  380. static term_t err_term = NULL;
  381. static context_t err_cxt = NULL;
  382.  
  383. term_t PL_create_term(context_t PL__ctx, ... ) {
  384.     va_list args;
  385.     term_t t = PL_new_term_ref();
  386.     va_start(args, PL__ctx);
  387.     PL_unify_termv(t, args);
  388.     va_end(args);
  389.     return t;
  390. }
  391.  
  392.  
  393. term_t object_to_term(cl_object obj) {
  394.     term_t var = PL_new_term_ref();
  395.     unify_object(var,&obj,&LPToplevel,err_cxt);
  396.     return var;
  397. }
  398.  
  399. char* strconcat(char* lft,char* rgt) {
  400.     int rlen = strlen(rgt);
  401.     int llen = strlen(lft);
  402.     int len = rlen+llen;
  403.     char* ret = malloc(len+1);
  404.     memcpy(ret,lft,llen);
  405.     memcpy(ret+llen,rgt,rlen);
  406.     ret[len]=0;
  407.     return ret;
  408. }
  409.  
  410. const char* toString(cl_object x) {
  411.     if (x==OBJNULL) return "*OBJNULL*";
  412.     if (x==Ct) return "T";
  413.     if (x==Cnil) return "NIL";
  414.     if (Null(x)) return "NULL";
  415.     switch (type_of(x)) {
  416.         char txtbuf[1024];
  417.         case t_character:
  418.             sprintf(&txtbuf,"%c",CHAR_CODE(x));
  419.             return strdup(txtbuf);
  420.         case t_fixnum:
  421.         case t_bignum:
  422.             sprintf(&txtbuf,"%d",fixint(x));
  423.             return strdup(txtbuf);
  424.         case t_ratio:
  425.             sprintf(&txtbuf,"%g",number_to_double(x));
  426.             return strdup(txtbuf);
  427.         case t_shortfloat:
  428.             sprintf(&txtbuf,"%f",sf(x));
  429.             return strdup(txtbuf);
  430.         case t_longfloat:
  431.             sprintf(&txtbuf,"%f",lf(x));
  432.             return strdup(txtbuf);
  433.         case t_symbol:
  434.             if (!x->symbol.hpack)
  435.                 return strconcat("<?HPACK?>::",(x->symbol.name->string.self));
  436.             if (x->symbol.hpack == cl_core.keyword_package)
  437.                 return strconcat(":",(x->symbol.name->string.self));
  438.             return strconcat(x->symbol.hpack->pack.name->string.self,strconcat("::",(x->symbol.name->string.self)));
  439.         case t_package:
  440.             return strconcat("package:",(x->pack.name->string.self));
  441.         case t_string:
  442.             return strconcat(strconcat("\"",x->string.self),"\"");
  443.         case t_cons:
  444.             return strconcat(strconcat("(",strconcat(toString(x->cons.car),strconcat(" . ",toString(x->cons.cdr)))),")");
  445.         default: {
  446.                 cl_object type = cl_type_of(x);
  447.                 return toString(cl_format(3, Cnil,make_constant_string("~A"),x));
  448.             }
  449.     }
  450. }
  451.  
  452. cl_object throw_error(cl_object correctable, cl_object x, cl_object described,cl_object args) {
  453.     foreign_t retv = 0;
  454.  
  455.  
  456.     if (Null(correctable)) {
  457.         printf("; Error uncorrectable %s: %s\n",toString(x),toString(described));
  458.     } else {
  459.         printf("; Error correctable %s: %s\n",toString(x),toString(described));
  460.     }
  461.  
  462.     retv =  PL_throw(PL_create_term(err_cxt,PL_FUNCTOR,FUNCTOR_lisp_error2,
  463.                                     PL_TERM,err_term,
  464.                                     PL_TERM,PL_create_term(err_cxt,PL_FUNCTOR,FUNCTOR_lisp_error2,
  465.                                                            PL_TERM,object_to_term(x),
  466.                                                            PL_TERM,object_to_term(args))));
  467.     if (err_goto!=NULL) {
  468.         (void*)err_goto;
  469.     }
  470.     return correctable;
  471. }
  472.  
  473. //extern cl_object si_signal_simple_error(cl_narg narg, cl_object x, cl_object correctable, cl_object formatstr, cl_object format_args, ...);
  474. extern cl_object si_signal_simple_error _ARGS((cl_narg narg, cl_object x, cl_object correctable, cl_object formatstr, cl_object format_args, ...)) {     /*__attribute__((noreturn))*/
  475.     cl_object gargs  = Cnil;
  476.     cl_object described = Cnil;
  477.     cl_va_list args;
  478.     cl_va_start(args, format_args, narg, 4);
  479.     gargs = cl_grab_rest_args(args);
  480.     x = make_simple_string(toString(formatstr));
  481.     described = make_simple_string(toString(gargs));
  482. //  described = cl_format(narg-1,Cnil,formatstr,format_args,gargs);
  483.     return throw_error(correctable,x,described,gargs);
  484.     //return cl_apply(6, @'si::signal-simple-error', x, correctable, formatstr, format_args, cl_grab_rest_args(args));
  485. }
  486.  
  487. extern cl_object si_universal_error_handler(cl_narg narg, cl_object correctable, cl_object formatstr, ...) {
  488.     cl_object gargs  = Cnil;
  489.     cl_object described = Cnil;
  490.     cl_object x = Cnil;
  491.     cl_va_list args;
  492.     cl_va_start(args, formatstr, narg, 2);
  493.     gargs = cl_grab_rest_args(args);
  494.  
  495.     x = make_simple_string(toString(formatstr));
  496.     described = make_simple_string(toString(gargs));
  497.     // described = cl_format(3,Cnil,formatstr,gargs);
  498.     return throw_error(correctable,x,described,gargs);
  499. }
  500.  
  501.  
  502. cl_object ecls_eval(cl_object lispcall, context_t PL__ctx) {
  503.     cl_object obj2 = OBJNULL;
  504.     err_cxt = PL__ctx;
  505.     if (!lispcall) return throw_error(Cnil,make_simple_string("ecls_eval"),make_simple_string("null"),Cnil);
  506.     CL_UNWIND_PROTECT_BEGIN {
  507.         printf("EVAL: %s\n",toString(lispcall));
  508.         obj2 = si_eval_with_env(1, lispcall);
  509.     } CL_UNWIND_PROTECT_EXIT {
  510.         /* We do not want to come back here if close_stream fails,
  511.            therefore, first we frs_pop() current jump point, then
  512.            try to close the stream, and then jump to next catch
  513.            point */
  514.         //lispcall = Ct;
  515.         ;;;
  516.         //  printf("CL_UNWIND_PROTECT_EXIT: "); cl_print(1,obj2);
  517.     } CL_UNWIND_PROTECT_END;
  518.     printf("EXIT: %s\n",toString(obj2));
  519.     return obj2;
  520. }
  521. foreign_t lisp_eval(term_t t1,term_t t2,context_t PL__ctx) {
  522.     LPEnv lp = (LPEnv)LPEngine;
  523.     cl_object obj1 = OBJNULL,obj2;
  524.     static void* cehf = NULL;
  525.     //err_goto = error_bail;
  526.     if (!cehf) {
  527.         int intern_flag;    
  528.         cehf = si_universal_error_handler;
  529.         cl_def_c_function_va(ecl_find_symbol_nolock(make_constant_string("UNIVERSAL-ERROR-HANDLER"), cl_core.system_package, &intern_flag), si_universal_error_handler);
  530.         cl_def_c_function_va(ecl_find_symbol_nolock(make_constant_string("SIGNAL-SIMPLE-ERROR"), cl_core.system_package, &intern_flag), si_signal_simple_error);
  531.         cl_def_c_function_va(ecl_find_symbol_nolock(make_constant_string("CERROR"), cl_core.system_package, &intern_flag), si_universal_error_handler);
  532.         cl_def_c_function_va(ecl_find_symbol_nolock(make_constant_string("ERROR"), cl_core.system_package, &intern_flag), si_universal_error_handler);
  533.         cl_def_c_function_va(ecl_find_symbol_nolock(make_constant_string("PROGRAM-ERROR"), cl_core.system_package, &intern_flag), si_universal_error_handler);
  534.     }
  535.     unify_object(t1,&obj1,  lp, PL__ctx );
  536.     err_term = t1;
  537.     obj2 = ecls_eval(obj1,PL__ctx);
  538.  
  539.     return unify_object(t2, &obj2 ,  lp, PL__ctx );
  540. }
  541.  
  542. foreign_t lisp_term(term_t t1,term_t t2,context_t PL__ctx) {
  543.     LPEnv lp = (LPEnv)LPEngine;
  544.     cl_object obj1 = OBJNULL;
  545.     return unify_object(t1,&obj1,  lp, PL__ctx ) && unify_object(t2, &obj1 ,  lp, PL__ctx );
  546. }
  547.  
  548. foreign_t lisp_unify(term_t t1,term_t t2,context_t PL__ctx) {
  549.     LPEnv lp = (LPEnv)LPEngine;
  550.     cl_object obj1 = OBJNULL,obj2=OBJNULL;
  551.     unify_object(t1,&obj1,  lp, PL__ctx );
  552.     unify_object(t2,&obj2,  lp, PL__ctx );
  553.     return unify_locative(&obj1,&obj2,lp,PL__ctx);
  554. }
  555.  
  556. foreign_t lisp_thaw(term_t t1, context_t PL__ctx) {
  557.     LPEnv lp = (LPEnv)LPEngine;
  558.     cl_object obj1 = OBJNULL,obj2=OBJNULL;
  559.     return unify_locative(&obj1,&obj2,lp,PL__ctx);
  560. }
  561.  
  562. typedef struct slot_prop {
  563.     cl_object obj1;
  564.     cl_index index;
  565. } *Slot_prop;
  566.  
  567.  
  568. foreign_t object_property(cl_object* slot1,term_t prop, term_t value, context_t PL__ctx) {
  569.     Symbol s ;
  570.     cl_object obj1 = *slot1;
  571.     cl_object signature;
  572.     cl_object clas = 0;
  573.     cl_type lisp_type = FREE;
  574.     LPEnv lp = (LPEnv)LPEngine;
  575.     PL_atomic_t name = 0;
  576.     int rval = 0;
  577.  
  578.     switch (PL_foreign_control(PL__ctx)) {
  579.         case FRG_CUTTED:
  580.             return TRUE;
  581.         case FRG_FIRST_CALL:
  582.             if (PL_get_atom(prop,&name)) {
  583.                 clas = CLASS_OF(obj1);
  584.                 s = lookupHTable((void*)LPGlobal.typeSignatures, (void*)clas);
  585.                 if (s) {
  586.                     signature = s->value;
  587.                 } else {
  588.                     signature =  CLASS_SLOTS(clas);
  589.                 }
  590.             }
  591.         case FRG_REDO:
  592.             try_again:
  593.             if (Null(signature)) return FALSE;
  594.             {
  595.                 cl_object member = CAR(signature);
  596.                 cl_object memberinfo = CDR(member);
  597.                 cl_object membername = CAR(memberinfo);
  598.                 clas = cl_funcall(2,CAR(member),obj1);
  599.                 rval =  PL_unify_atom_chars(prop,membername->string.self) && unify_object(value,&clas,lp,PL__ctx);
  600.                 if (rval<1) {
  601.                     PL_retry_address(signature);
  602.                     return TRUE;
  603.                 } else {
  604.                     goto try_again;
  605.                 }
  606.                 break;
  607.             }
  608.         default: {
  609.                 break;
  610.             }
  611.     }
  612.     return PL_warning("should not be here");
  613. }
  614.  
  615.  
  616. cl_object* key_to_symbol(PL_atomic_t key) {
  617.     Symbol s = lookupHTable(LPGlobal.main->keyToSymbol,(void*)key);
  618.     if (s) {
  619.         return(cl_object*)&s->value;
  620.     } else {
  621.         s = addHTable(LPGlobal.main->keyToSymbol,(void*)key,(void*)0);
  622.         return(cl_object*)&s->value;
  623.     }
  624. }
  625.  
  626. foreign_t lisp_property(term_t t1,term_t prop,term_t value,context_t PL__ctx) {
  627.     PL_atomic_t key = LM_get_key(t1,0);
  628.     if (key) {
  629.         return object_property(key_to_symbol(key),prop,value,PL__ctx);
  630.     } else {
  631.         LPEnv lp = (LPEnv)LPEngine;
  632.         cl_object *slot1 = 0;
  633.         return object_property(slot1,prop,value,PL__ctx);
  634.     }
  635. }
  636. foreign_t lisp_option(term_t prop,term_t tbefore,term_t tafter,context_t PL__ctx) {
  637. //  PL_atomic_t key = LM_get_key(prop);
  638.     return FALSE;
  639. }
  640.  
  641.  
  642.  
  643. /************************ GLOBAL INITIALIZATION ***********************/
  644.  
  645. install_t uninstall() {
  646.     printf(";*** uninstall()\n");
  647.     //fflush(stdout);
  648. }                                                                            
  649.  
  650. void prologExiting(int status, void *arg) {
  651.     printf(";*** UNLOADING SWI-PROLOG exit(%d)\n",status);
  652. }
  653.  
  654.  
  655. static cl_object cfun_prolog(cl_narg narg, ...) {
  656. //  cl_va_list ARGS;lisp_eval(1,lispcall).\n
  657.     printf(";*** Tests:     set_prolog_flag(double_quotes,string).\n");
  658.     printf(";***            lisp_eval([1],X).\n");
  659.     printf(";***            lisp_eval([+,1,2],X).\n");
  660.     printf(";***            lisp_eval([+,1,2],X).\n");
  661.     printf(";***            lisp_eval([print,\"hi\"],X).\n");
  662.     printf(";***            lisp_eval([pint,\"hi\"],X).\n");
  663.     printf(";***            lisp_eval([1,hi],X).\n");
  664.     printf(";***            lisp_unify([pint,\"hi\"],X).\n");
  665.     printf(";***            lisp_term([pint,\"hi\"],X).\n");
  666.     printf(";***             lisp_term('*features*',X),lisp_eval([symbol-name',X],Y).  lisp_eval('*features*',X).\n");
  667.     printf(";*** Type \"end_of_file.\" to leave prolog\n");
  668.     //fflush(stdout);
  669.     callProlog(MODULE_user,
  670.                PL_create_term(err_cxt,
  671.                               PL_FUNCTOR_CHARS,"use_module",1,
  672.                               PL_FUNCTOR_CHARS,"library",1,PL_ATOM,ATOM_ecls),
  673.                PL_Q_NORMAL, NULL);
  674.     return((cl_object)(Cnil+PL_toplevel()));
  675. }
  676.  
  677.  
  678.  
  679. install_t install() {
  680.     char* iargv[] = {"poplog"};
  681.     int ii=0;
  682.     // called only once
  683.     if (!prolog_installed_to_lisp) {
  684.         ATOM_dot = PL_new_atom(".");
  685.         ATOM_cons = PL_new_atom(".");
  686.         ATOM_nil = PL_new_atom("[]");
  687.         ATOM_freeze = PL_new_atom("freeze$");
  688.         printf("%% installing prolog to lisp\n");
  689.         prolog_installed_to_lisp = 1;
  690.  
  691.         // ATOM_volatile = PL_new_atom("volatile");
  692.         ATOM_T = PL_new_atom("T");
  693.         ATOM_user = PL_new_atom("user");
  694.         INIT_ATOM(ecls);
  695.         ATOM_att = PL_new_atom("att");
  696.         ATOM_clos = PL_new_atom("clos");
  697.         ATOM_clos_classes = PL_new_atom("clos_classes");
  698.         ATOM_creationType_hash = PL_new_atom("creationType_hash");
  699.         ATOM_creationType_link = PL_new_atom("creationType_link");
  700.         ATOM_enumerate_hash = PL_new_atom("enumerate_hash");
  701.         ATOM_lisp_symbol = PL_new_atom("lisp_symbol");
  702.         ATOM_lisp_slot = PL_new_atom("lisp_slot");
  703.         ATOM_lisp_object = PL_new_atom("lisp_object");
  704.         ATOM_lisp_type = PL_new_atom("lisp_type");
  705.         ATOM_query_value = PL_new_atom("query_value");
  706.         ATOM_term = PL_new_atom("term");
  707.         ATOM_true = PL_new_atom("true");
  708.         ATOM_unify_value = PL_new_atom("unify_value");
  709.  
  710.  
  711.         FUNCTOR_att3 = PL_new_functor(PL_new_atom("att"), 3);
  712.         FUNCTOR_clos2 = PL_new_functor(PL_new_atom("clos"), 2);
  713.         FUNCTOR_freeze2 = PL_new_functor(PL_new_atom("$freeze"), 2);
  714.         FUNCTOR_lisp_thaw1 = PL_new_functor(PL_new_atom("lisp_thaw"), 1);
  715.         FUNCTOR_lisp_error2 = PL_new_functor(PL_new_atom("lisp_error"), 2);
  716.         FUNCTOR_lisp_slot1 = PL_new_functor(ATOM_lisp_slot, 1);
  717.         MODULE_user = PL_new_module(ATOM_user);
  718.         MODULE_ecls = PL_new_module(ATOM_ecls);
  719.         // ATOM_unify = PL_new_atom("unify");
  720.         // ATOM_read = PL_new_atom("read");
  721.         // ATOM_execute = PL_new_atom("execute");
  722.  
  723.         if (!ecl_booted) {
  724.             cl_boot(1,iargv);
  725.         }
  726.  
  727.         if (LPGlobal.main!=&LPToplevel) {
  728.             printf("ERROR: initLPBindings did not work the global\n");
  729.             initLPBindings((int)1,(char**)iargv,(struct cl_env_struct*)&cl_env,(struct cl_core_struct*)&cl_core);
  730.         }
  731.  
  732.  
  733.         LPGlobal.typeNameAtoms = newHTable(16);
  734.         LPGlobal.typeSignatures = newHTable(16);
  735.  
  736.         for (ii=0; ii<127 ; ii++) {
  737.             LPGlobal.type_atom[ii]=(PL_atomic_t)NULL;
  738.             LPGlobal.unify_hook[ii]=NULL;
  739.         }
  740.  
  741. // The most specific numeric types come first. Assumed bysome routines); like cl_expt
  742.         SET_UNIFY_HOOK_BY_NAME(fixnum);
  743.         SET_UNIFY_HOOK_BY_NAME(bignum);
  744.         SET_UNIFY_HOOK_BY_NAME(character);
  745.         SET_UNIFY_HOOK_BY_NAME(vector);
  746.         SET_UNIFY_HOOK_BY_NAME(bitvector);
  747.         SET_UNIFY_HOOK_BY_NAME(array);
  748.         SET_UNIFY_HOOK_BY_NAME(symbol);
  749.         SET_UNIFY_HOOK_BY_NAME(string);
  750.         SET_UNIFY_HOOK_BY_NAME(hashtable);
  751.         SET_UNIFY_HOOK_BY_NAME(cons);
  752.         SET_UNIFY_HOOK_BY_NAME(instance);
  753.         SET_UNIFY_HOOK_BY_NAME(cons);
  754.         SET_UNIFY_HOOK_BY_NAME(fixnum);                                                                        
  755.         SET_UNIFY_HOOK_BY_NAME(character);                                                                      
  756.         SET_UNIFY_HOOK_BY_NAME(bignum);                                                                        
  757.         SET_UNIFY_HOOK_BY_NAME(ratio);                                                                          
  758.         SET_UNIFY_HOOK_BY_NAME(shortfloat);                                                                      
  759.         SET_UNIFY_HOOK_BY_NAME(longfloat);                                                                          
  760.         SET_UNIFY_HOOK_BY_NAME(complex);                                                                        
  761.         SET_UNIFY_HOOK_BY_NAME(symbol);                                                                            
  762.         SET_UNIFY_HOOK_BY_NAME(package);                                                                            
  763.         SET_UNIFY_HOOK_BY_NAME(hashtable);                                                                          
  764.         SET_UNIFY_HOOK_BY_NAME(array);                                                                              
  765.         SET_UNIFY_HOOK_BY_NAME(vector);                                                                            
  766.         SET_UNIFY_HOOK_BY_NAME(string);                                                                            
  767.         SET_UNIFY_HOOK_BY_NAME(bitvector);                                                                          
  768.         SET_UNIFY_HOOK_BY_NAME(stream);                                                                            
  769.         SET_UNIFY_HOOK_BY_NAME(random);                                                                                  
  770.         SET_UNIFY_HOOK_BY_NAME(readtable);                                                                              
  771.         SET_UNIFY_HOOK_BY_NAME(pathname);                                                                                
  772.         SET_UNIFY_HOOK_BY_NAME(bytecodes);                                                                              
  773.         SET_UNIFY_HOOK_BY_NAME(cfun);                                                                                
  774.         SET_UNIFY_HOOK_BY_NAME(cclosure);                                                                              
  775. #ifdef CLOS
  776.         SET_UNIFY_HOOK_BY_NAME(instance);                                                                              
  777. #else
  778.         SET_UNIFY_HOOK_BY_NAME(structure);                                                                              
  779. #endif /// CLOS
  780. #ifdef ECL_THREADS
  781.         SET_UNIFY_HOOK_BY_NAME(process);
  782.         SET_UNIFY_HOOK_BY_NAME(lock);
  783. #endif
  784.         SET_UNIFY_HOOK_BY_NAME(codeblock);                                                                          
  785.         SET_UNIFY_HOOK_BY_NAME(foreign);                                                                          
  786.         SET_UNIFY_HOOK_BY_NAME(end);
  787.         SET_UNIFY_HOOK_BY_NAME(other);
  788.         SET_UNIFY_HOOK_BY_NAME(contiguous);                                                                                
  789.         SET_UNIFY_HOOK("FREE",FREE,unify_object);                                                                          
  790.  
  791.         //PL_current_global_data()->debug_level = 9;
  792.  
  793.         //"SI::UNIVERSAL-ERROR-HANDLER"
  794.         PL_register_foreign_in_module("ecls","$lisp_eval", 2, lisp_eval, PL_FA_NONDETERMINISTIC);
  795.         PL_register_foreign_in_module("ecls","$lisp_unify", 2, lisp_unify, PL_FA_NONDETERMINISTIC);
  796.         PL_register_foreign_in_module("ecls","$lisp_term", 2, lisp_term, PL_FA_NONDETERMINISTIC);
  797.         PL_register_foreign_in_module("ecls","$lisp_thaw", 1, lisp_term, PL_FA_NONDETERMINISTIC);
  798. //      PL_register_foreign("lisp_symbol", 2, lisp_symbol, PL_FA_NONDETERMINISTIC);
  799.         PL_register_foreign_in_module("ecls","$lisp_property", 3, lisp_property, PL_FA_NONDETERMINISTIC);
  800.         PL_register_foreign_in_module("ecls","$lisp_option", 3, lisp_option, PL_FA_NONDETERMINISTIC);
  801.         PL_on_halt(prologExiting,NULL);
  802.     } else {
  803.         printf("% poplog alreading installed\n");
  804.     }
  805. }
  806.  
  807.  
  808. int initLPBindings(int narg, char **argv,struct cl_env_struct* env, struct cl_core_struct* core) {
  809.     int iargc = 1;
  810.     int type_i = 0;
  811.     printf(";** initLPBindings(%d,[%s|...],...,...)\n",narg,argv[0]);
  812.     if (LPGlobal.main!=&LPToplevel) {
  813.         printf(";*** INSTALLING GLOBALS\n");
  814.         //fflush(stdout);
  815.         LPGlobal.main = &LPToplevel;
  816.         //LPGlobal.prolog_code = PL_current_code_data();
  817.         //LPGlobal.prolog_core = PL_current_global_data();   
  818.         LPGlobal.main->keyToSymbol = newHTable(64);
  819.         LPGlobal.main->symbolToAtom = newHTable(64);                                                                                                                                             // PL_global_data; //lookupHTable
  820.         LPGlobal.lisp_core = core;
  821.         LPGlobal.prolog_package = make_package(make_simple_string("PROLOG"),Cnil,LPGlobal.lisp_core->packages);
  822.         printf(";**** PACKAGE PROLOG::\n");
  823.         LPGlobal.fsym_prolog_toplevel = _intern("TOPLEVEL", LPGlobal.prolog_package);
  824.         cl_def_c_function_va(LPGlobal.fsym_prolog_toplevel, cfun_prolog);
  825.     }
  826.     if (LPEngine==NULL) {
  827.         LPEngine = &LPToplevel;
  828.         printf(";*** FOUND THREAD\n");
  829.     }
  830.     if (LPEngine->global != &LPGlobal) {
  831.         printf(";*** INSTALLING LP-CURRENT\n");
  832.         //fflush(stdout);
  833.         LPEngine->global = &LPGlobal;
  834.         LPEngine->lisp = env;
  835.         LPEngine->prolog = NULL;
  836.     }
  837.     if (LPEngine->prolog==NULL) {
  838.         char* iargv[] = {"poplog"};
  839.         if (!(iargc = PL_is_initialised(&iargc,(char ***)iargv))) {
  840.             printf(";*** INITALIZING SWI-PROLOG\n");
  841.             if (!(iargc = PL_initialise(narg,argv))) {
  842.                 printf(";* FAILED SWI-PROLOG\n");
  843.             } else {
  844.                 printf(";*** SWI-PROLOG Loaded\n");
  845.             }
  846.         }
  847.     }
  848.  
  849.     LPEngine->prolog = LD;
  850.     if (LPEngine->prolog) {
  851.         printf(";*** FOUND SWI-PROLOG ENGINE\n");
  852.     } else {
  853.         printf(";*** CREATING SWI-PROLOG ENGINE\n");
  854.         LPEngine->prolog = PL_create_engine(NULL);
  855.     }
  856.     if (LPEngine->prolog==NULL) {
  857.         printf(";*** ERROR SWI-PROLOG ENGINE\n");
  858.         return -1;
  859.     } else {
  860.         install();
  861.         printf(";**** Use: (PROLOG::TOPLEVEL)\n");
  862.     }
  863.  
  864. #ifdef O_LOGICMOO
  865.     LPGlobal.SLogicmoo = _intern("LOGICMOO", LPGlobal.prolog_package);
  866.     //register_root(&LOGICMOO);
  867. #endif
  868.     //fflush(stdout);
  869.     return iargc;
  870. }
  871. /*
  872. eclmin.lib(prolog.(*slot1) , lp , PL__ctx) :
  873. error LNK2001:
  874. unresolved external symbol PL_global_data
  875. eclmin.lib(prolog.(*slot1) , lp , PL__ctx) :
  876. error LNK2001:
  877. unresolved external symbol wordToTermRef
  878. eclmin.lib(prolog.(*slot1) , lp , PL__ctx) :
  879. error LNK2001:
  880. unresolved external symbol lookupHTable
  881. eclmin.lib(prolog.(*slot1) , lp , PL__ctx) :
  882. error LNK2001:
  883. unresolved external symbol PL_ldata
  884. eclmin.lib(prolog.(*slot1) , lp , PL__ctx) :
  885. error LNK2001:
  886. unresolved external symbol logicmoo_alloc
  887. eclmin.lib(prolog.(*slot1) , lp , PL__ctx) :
  888. error LNK2001:
  889. unresolved external symbol PL_current_engine
  890. eclmin.lib(prolog.(*slot1) , lp , PL__ctx) :
  891. error LNK2001:
  892. unresolved external symbol PL_code_data
  893. void hookInterpretor() {
  894.     PROCEDURE_garbage_collect0 = lookupProcedure(FUNCTOR_dgarbage_collect1, module);
  895.     PROCEDURE_block3 = lookupProcedure(FUNCTOR_block3, module);
  896.     PROCEDURE_catch3 = lookupProcedure(FUNCTOR_catch3, module);
  897.     PROCEDURE_true0 = lookupProcedure(FUNCTOR_true0, module);
  898.     PROCEDURE_fail0 = lookupProcedure(FUNCTOR_fail0, module);
  899.     PROCEDURE_print_message2 = lookupProcedure(FUNCTOR_print_message2, module);
  900.     PROCEDURE_dcall1 = lookupProcedure(FUNCTOR_dcall1, module);
  901.     PROCEDURE_call_cleanup3 = lookupProcedure(FUNCTOR_call_cleanup3, module);
  902.     PROCEDURE_dthread_init0 = lookupProcedure(FUNCTOR_dthread_init0, module);
  903. #ifdef O_ATTVAR
  904.     PROCEDURE_dwakeup1 = lookupProcedure(FUNCTOR_dwakeup1, module);
  905. #endif
  906.     PROCEDURE_exception_hook4 =
  907.     PL_predicate("prolog_exception_hook", 4,"user");
  908. // allow debugging in call/1
  909.     clear(PROCEDURE_dcall1->definition, HIDE_CHILDS);
  910.     set(PROCEDURE_dcall1->definition, DYNAMIC);
  911.     for (ecell = ext_head;ecell;ecell = ecell->next)
  912.  bindExtensions(ecell->module, ecell->extensions);
  913.     extensions_loaded = TRUE;
  914. */
  915.  
  916.  
  917.  
  918.  
  919. foreign_t unify_locative(cl_object* xP,cl_object* yP ,  LPEnv lp, context_t PL__ctx ) {
  920.     if (xP==yP) return TRUE;
  921.     if (xP==NULL || xP==NULL) return FALSE;
  922.     if (*xP==NULL) {
  923.         *xP=*yP;
  924.         return TRUE;
  925.     }
  926.     if (*yP==NULL) {
  927.         *yP=*xP;
  928.         return TRUE;
  929.     }
  930.     return(*yP==*xP)?TRUE:FALSE;
  931. }
  932.  
  933.  
  934. term_t ensure_attvar(term_t var, context_t PL__ctx) {
  935.     if (PL_is_attvar(var)) return var;
  936.     else {
  937.         static predicate_t pred = NULL;
  938.         term_t a0 = PL_new_term_refs(2);
  939.         if (pred==NULL) pred = PL_predicate("put_attrs",2,NULL);
  940.         PL_unify_term(a0+1,
  941.                       PL_FUNCTOR,FUNCTOR_freeze2,
  942.                       PL_FUNCTOR_CHARS,":",2,PL_ATOM,ATOM_ecls,PL_FUNCTOR,FUNCTOR_lisp_thaw1,PL_TERM,var,
  943.                       PL_ATOM,ATOM_nil);
  944.         PL_put_term(a0,var);
  945.         if (PL_call_predicate(NULL, PL_Q_NORMAL, pred,a0)) {
  946.             return a0;
  947.         }
  948.         return a0;
  949.     }
  950. }
  951.  
  952. fid_t open_gvar_frame(PL_atomic_t name, term_t attribs,context_t PL__ctx) {
  953.     static predicate_t pred = NULL;
  954.     term_t a0 = PL_new_term_refs(2);
  955.     int rval;
  956.     if (pred==NULL) {
  957.         pred = PL_predicate("b_setval",2,NULL);
  958.     }
  959.     PL_put_atom(a0,name);
  960.     PL_put_term(a0+1,attribs);
  961.     rval = PL_call_predicate(NULL, PL_Q_NORMAL, pred,a0);
  962. //  PL_close_foreign_frame(fid);
  963.     return PL_open_foreign_frame();
  964. }
  965.  
  966. foreign_t set_attribute(term_t var,PL_atomic_t name,term_t value,context_t PL__ctx) {
  967.     int rval = 0;
  968.     static predicate_t pred = NULL;
  969.     term_t a0 = PL_new_term_refs(3);
  970.     //ensure_attvar(var,PL__ctx);
  971.     PL_put_term(a0,var);
  972.     rval = PL_is_attvar(var);
  973.     rval = PL_is_attvar(a0);
  974.     PL_put_atom(a0+1,name);
  975.     PL_put_term(a0+2,value);
  976.     if (pred==NULL) pred = PL_predicate("ecls_set_attr",3,NULL);
  977.     rval = PL_call_predicate(NULL, PL_Q_NORMAL, pred,a0);
  978.     return rval;
  979. }
  980. foreign_t get_attribute(term_t var,PL_atomic_t name,term_t value,context_t PL__ctx) {
  981.     int rval = 0;
  982.     static predicate_t pred = NULL;
  983.     term_t a0 = PL_new_term_refs(3);
  984.     //ensure_attvar(var,PL__ctx);
  985.     PL_put_term(a0,var);
  986.     rval = PL_is_attvar(var);
  987.     rval = PL_is_attvar(a0);
  988.     PL_put_atom(a0+1,name);
  989.     PL_put_term(a0+2,value);
  990.     if (pred==NULL) pred = PL_predicate("ecls_get_attr",3,NULL);
  991.     rval = PL_call_predicate(NULL, PL_Q_NORMAL, pred,a0);
  992.     return rval;
  993. }
  994.  
  995. //extern int getval(term_t var, term_t value ARG_LD);
  996.  
  997. foreign_t close_gvar_frame(fid_t fid, PL_atomic_t name, term_t attribs) {
  998.     static predicate_t pred = NULL;
  999.     term_t a0 = PL_new_term_refs(2);
  1000.     foreign_t rval;
  1001.     if (pred==NULL) {
  1002.         pred = PL_predicate("b_getval",2,NULL);
  1003.     }
  1004.     PL_put_atom(a0,name);
  1005.     rval = PL_call_predicate(NULL, PL_Q_NORMAL, pred,a0);
  1006.     PL_close_foreign_frame(fid);
  1007.     return PL_unify(attribs,a0+1);
  1008. }
  1009.  
  1010. int close_attvar_frame(fid_t fid, term_t var, term_t attribs) {
  1011.     int rval;
  1012.     term_t prev = PL_new_term_ref();
  1013.     PL_get_attr(var,prev);
  1014.     rval = PL_unify(attribs,PL_copy_term_ref(prev));
  1015.     PL_put_atom(prev,ATOM_nil);
  1016.     PL_close_foreign_frame(fid);
  1017.     return rval;
  1018. }
  1019.  
  1020.  
  1021.  
  1022. //extern int char_capitalize(int c, bool *bp);
  1023. //extern int char_downcase(int c, bool *bp);
  1024. //extern int char_upcase(int c, bool *bp);
  1025. cl_object  make_ucase_string(const char* s) {
  1026.     switch (cl_core.standard_readtable->readtable.read_case) {
  1027.         case ecl_case_upcase:
  1028.             // return string_case(1, (void*)char_upcase, make_simple_string(s));
  1029.             return make_simple_string(strupr(s));
  1030.         case ecl_case_downcase:
  1031. //          return string_case(1, (void*)char_downcase, make_simple_string(s));
  1032.             return make_simple_string(strlwr(s));
  1033.         case ecl_case_invert:
  1034.             return make_simple_string(strcat("#$",s));
  1035.             //return translate_common_case(make_simple_string(s));
  1036.             //return string_case(1, (void*)char_capitalize, make_simple_string(s));case ecl_case_preserve:
  1037.         default:{
  1038.             }
  1039.     }
  1040.     return make_simple_string(s);
  1041. }
  1042.  
  1043. cl_object  find_package_ichars(const char* s) {
  1044.     return(find_package_icase(make_ucase_string(s)));
  1045. }
  1046.  
  1047. cl_object  find_symbol_icase(const char* s, cl_object pkname, int creationType) {
  1048.     int intern_flag=-1;
  1049.     cl_object package = find_package_icase(pkname);
  1050.     cl_object str = make_constant_string(s);
  1051.     cl_object symb = ecl_find_symbol_nolock(str, package, &intern_flag);
  1052.     if (HAS_VALUE(symb)) return symb;
  1053.     //switch (intern_flag) { // case ENUM_VAL(INTERNAL,1): //   case ENUM_VAL(EXTERNAL,2): //   case ENUM_VAL(INHERITED,3): default:}
  1054.     symb = ecl_find_symbol_nolock(cl_string_upcase(1,str), package, &intern_flag);
  1055.     if (HAS_VALUE(symb)) return symb;
  1056.     //switch (intern_flag) { // case ENUM_VAL(INTERNAL,1): //   case ENUM_VAL(EXTERNAL,2): //   case ENUM_VAL(INHERITED,3): default:}
  1057.     if (!creationType) return symb;
  1058.     symb = intern(str,package,&intern_flag);
  1059.     //switch (intern_flag) { // case ENUM_VAL(INTERNAL,1): //   case ENUM_VAL(EXTERNAL,2): //   case ENUM_VAL(INHERITED,3): default:}
  1060.     cl_import2(symb, package);
  1061.     cl_export2(symb, package);
  1062.     symb->symbol.dynamic = 1;
  1063.     return symb;
  1064. }
  1065.  
  1066. cl_object  find_symbol_ichars(const char* s,cl_object pkname ,int creationType) {
  1067.     return find_symbol_icase(s,find_package_icase(pkname),creationType);
  1068. }
  1069.  
  1070.  
  1071.  
  1072. PL_atomic_t lisp_to_atom(cl_object symb) {
  1073.     PL_atomic_t name =0;
  1074.     Symbol s = lookupHTable(LPGlobal.main->symbolToAtom,(void*)symb);
  1075.     if (s) {
  1076.         name =(PL_atomic_t) s->value;
  1077.         if (name==0) {
  1078.             s->value =(void*) PL_new_atom(symb->symbol.name->string.self);
  1079.         } else {
  1080.             return name;
  1081.         }
  1082.     }
  1083.     name = PL_new_atom(symb->symbol.name->string.self);
  1084.     addHTable(LPGlobal.main->symbolToAtom,(void*)symb,(void*)name);
  1085.     addHTable(LPGlobal.main->keyToSymbol,(void*)name,(void*)symb);
  1086.     return name;
  1087. }
  1088.  
  1089.  
  1090. #define REQUIRE_UNIFY_OBJECT(RETVAL) if ((rval=RETVAL)<1) goto FAILED_UNIFY_OBJECT
  1091. #define RETURN_UNIFY_OBJECT(RETVAL) if ((rval=RETVAL)<1) goto FAILED_UNIFY_OBJECT; else goto SUCCEED_UNIFY_OBJECT
  1092. #define FRAME_UNIFY_OBJECT(RETVAL) RETVAL
  1093.  
  1094. foreign_t unify_object(term_t var, cl_object* slot1, LPEnv lp, context_t PL__ctx ) {
  1095.     cl_type lisp_type = FREE;
  1096.     PL_atomic_t name = (PL_atomic_t)NULL;
  1097.     foreign_t rval = -1;
  1098.     term_t term_object = 0;                                       // PL_new_term_ref();
  1099.     int arity = 0;
  1100.     char* txt;
  1101.     cl_object* slot2 = slot1;
  1102.     if (slot1 == NULL) return LM_throw("unify_object caught null slot1",var);
  1103.     if (*slot1 != OBJNULL) lisp_type = type_of(*slot1);
  1104.     if (LPGlobal.unify_hook[lisp_type]!=NULL && LPGlobal.unify_hook[lisp_type]!=unify_object) {
  1105.         rval = ((unify_hook_ptr)(LPGlobal.unify_hook[lisp_type]))(var, slot1, lp, PL__ctx );
  1106.     }
  1107.     switch (PL_term_type(var)) {
  1108.         case PL_STRING:
  1109.             switch (lisp_type) {
  1110.                 case FREE:
  1111.                     rval = PL_get_string(var,&txt,NULL);
  1112.                     *slot1 = make_simple_string(txt);
  1113.                     return rval;
  1114.                 case t_character:{
  1115.                         const char txt = CHAR_CODE(*slot1);
  1116.                         RETURN_UNIFY_OBJECT(PL_unify_string_nchars(var,1,&txt));
  1117.                     }
  1118.                 case t_string:
  1119.                     RETURN_UNIFY_OBJECT(PL_unify_string_chars(var,(*slot1)->string.self));
  1120.                 case t_shortfloat:
  1121.                 case t_longfloat:
  1122.                 case t_fixnum:
  1123.                 case t_bignum:
  1124.                 case t_ratio:
  1125.                     goto NEVER_UNIFY_OBJECT;
  1126.                 default:
  1127.                     goto FAILED_UNIFY_OBJECT;
  1128.             }
  1129.         case PL_FLOAT:
  1130.             switch (lisp_type) {
  1131.                 case FREE:{
  1132.                         double dval;
  1133.                         rval = PL_get_float(var,&dval);
  1134.                         *slot1 = make_longfloat(dval);
  1135.                         return rval;
  1136.                     }
  1137.                 case t_shortfloat:
  1138.                 case t_longfloat:
  1139.                 case t_fixnum:
  1140.                 case t_bignum:
  1141.                 case t_ratio:
  1142.                     RETURN_UNIFY_OBJECT(PL_unify_float(var,object_to_double(*slot1)));
  1143.                 case t_character:
  1144.                     goto NEVER_UNIFY_OBJECT;
  1145.                 default:
  1146.                     goto FAILED_UNIFY_OBJECT;
  1147.             }
  1148.         case PL_INTEGER:
  1149.             switch (lisp_type) {
  1150.                 case FREE:{
  1151.                         long lng;
  1152.                         rval = PL_get_long(var,&lng);
  1153.                         *slot1 = MAKE_FIXNUM(lng);
  1154.                         return rval;
  1155.                     }
  1156.                 case t_character:
  1157.                     RETURN_UNIFY_OBJECT(PL_unify_integer(var,CHAR_CODE(*slot1)));
  1158.                 case t_shortfloat:
  1159.                 case t_longfloat:
  1160.                 case t_fixnum:
  1161.                 case t_bignum:
  1162.                 case t_ratio:
  1163.                     RETURN_UNIFY_OBJECT(PL_unify_integer(var,object_to_fixnum(*slot1)));
  1164.                 default:
  1165.                     RETURN_UNIFY_OBJECT(PL_unify_pointer(var,(void*)(*slot1)));
  1166.             }
  1167.         case PL_ATOM:
  1168.             PL_get_atom(var,&name);
  1169.             switch (lisp_type) {
  1170.                 case t_character:
  1171.                     RETURN_UNIFY_OBJECT(PL_unify_char(var,CHAR_CODE(*slot1),0                       /*CHAR_MODE*/));
  1172.                 case t_shortfloat:
  1173.                 case t_longfloat:
  1174.                 case t_fixnum:
  1175.                 case t_bignum:
  1176.                 case t_ratio:
  1177.                     goto NEVER_UNIFY_OBJECT;
  1178.                 case t_symbol:
  1179.                     slot2 = key_to_symbol(name);
  1180.                     {
  1181.                         if (HAS_VALUE(*slot2)) RETURN_UNIFY_OBJECT(unify_locative(slot1,slot2 , lp,PL__ctx));
  1182.                         if ((*slot1)->symbol.name) {
  1183.                             if (stricmp(PL_atom_chars(name),(*slot1)->symbol.name->string.self)==0)
  1184.                                 goto SUCCEED_UNIFY_OBJECT;
  1185.                         }
  1186.                     }
  1187.                     goto try_atom_again;
  1188.                 case FREE:
  1189.                     if (name==ATOM_nil && (slot1!=NULL)) {
  1190.                         *slot1 = Cnil;
  1191.                         goto SUCCEED_UNIFY_OBJECT;
  1192.                     }
  1193.                     if (name==ATOM_T && (slot1!=NULL)) {
  1194.                         *slot1 = Ct;
  1195.                         goto SUCCEED_UNIFY_OBJECT;
  1196.                     }
  1197.                     slot2 = key_to_symbol(name);
  1198.                     if (!HAS_VALUE(*slot2)) {
  1199.                         *slot2 = find_symbol_ichars(PL_atom_chars(name),LPGlobal.prolog_package,1);
  1200.                     }
  1201.                     *slot1=*slot2;
  1202.                     goto SUCCEED_UNIFY_OBJECT;
  1203.                 default:
  1204.                     if (name==ATOM_nil && (slot1==NULL || Null(*slot1)))    goto SUCCEED_UNIFY_OBJECT;
  1205.                     if (name==ATOM_true && (slot1==NULL || Null(*slot1)))   goto FAILED_UNIFY_OBJECT;
  1206.                     slot2 = key_to_symbol(name);
  1207.                     if (*slot2!=NULL) RETURN_UNIFY_OBJECT(unify_locative(slot1,slot2 , lp,PL__ctx));
  1208.                     try_atom_again:                
  1209.                     {
  1210.                         term_t newval = PL_new_term_ref();
  1211.                         if (getval(var,newval,PL__ctx->engine)) return unify_object(newval,slot1,lp,PL__ctx);
  1212.                     }
  1213.             }
  1214.             goto FAILED_UNIFY_OBJECT;
  1215.         case PL_TERM:{
  1216.                 PL_get_name_arity(var,&name,&arity);
  1217.                 switch (lisp_type) {
  1218.                     case t_cons:
  1219.                         if (name==ATOM_dot) {
  1220.                             REQUIRE_UNIFY_OBJECT(unify_object(PL_arg(var,1),&((*slot1)->cons.car) , lp,PL__ctx));
  1221.                             REQUIRE_UNIFY_OBJECT(unify_object(PL_arg(var,2),&((*slot1)->cons.cdr) , lp,PL__ctx));
  1222.                             goto SUCCEED_UNIFY_OBJECT;
  1223.                         }
  1224.                     case t_string:
  1225.                         RETURN_UNIFY_OBJECT(PL_unify_list_chars(var,(*slot1)->string.self));
  1226.                     case FREE:
  1227.                         if (name==ATOM_dot) {
  1228.                             if (0 && PL_get_list_chars(var,&txt,NULL)) {
  1229.                                 *slot1 = make_constant_string(txt);
  1230.                                 return TRUE;
  1231.                             } else {
  1232.                                 //PL_get_list_nchars(var,length,
  1233.                                 cl_object car = NULL,cdr = NULL;                            
  1234.                                 REQUIRE_UNIFY_OBJECT(unify_object(PL_arg(var,1),&car , lp,PL__ctx));
  1235.                                 REQUIRE_UNIFY_OBJECT(unify_object(PL_arg(var,2),&cdr, lp,PL__ctx));
  1236.                                 *slot1 = make_cons(car,cdr);
  1237.                                 goto SUCCEED_UNIFY_OBJECT;
  1238.                             }
  1239.                         } else if (name==ATOM_clos) {
  1240.                             if (PL_get_pointer(PL_arg(var,2),(void*)slot2)) {
  1241.                                 *slot1 = *slot2;
  1242.                                 return TRUE;
  1243.                             } else {
  1244.                                 if (PL_get_atom(PL_arg(var,1),&name))
  1245.                                     *slot1 = cl_alloc_object(atomToType(name));
  1246.                             }
  1247.                         } else if (name==ATOM_lisp_slot) {
  1248.                             PL_get_pointer(var,(void*)slot2);
  1249.                             RETURN_UNIFY_OBJECT(unify_locative(slot1,slot2));
  1250.                         }
  1251.                         return TRUE;
  1252.  
  1253.                     default:{
  1254.                             if (name==ATOM_dot) {
  1255.                                 cl_object car = NULL,cdr = NULL;                            
  1256.                                 REQUIRE_UNIFY_OBJECT(unify_object(PL_arg(var,1),&car , lp,PL__ctx));
  1257.                                 REQUIRE_UNIFY_OBJECT(unify_object(PL_arg(var,2),&cdr, lp,PL__ctx));
  1258.                                 *slot1 = make_cons(car,cdr);
  1259.                                 goto SUCCEED_UNIFY_OBJECT;
  1260.                             } else if (name==ATOM_clos) {
  1261.                                 if (PL_get_pointer(PL_arg(var,2),(void*)slot2)) {
  1262.                                     *slot1 = *slot2;
  1263.                                     return TRUE;
  1264.                                 }
  1265.                                 if (PL_get_atom(PL_arg(var,1),&name)) {
  1266.                                     FRAME_UNIFY_OBJECT(set_attribute(var,ATOM_lisp_type,PL_create_term(PL__ctx,PL_POINTER,name),PL__ctx));
  1267.                                 }
  1268.                             } else if (name==ATOM_lisp_slot) {
  1269.                                 PL_get_pointer(var,(void*)slot2);
  1270.                                 RETURN_UNIFY_OBJECT(unify_locative(slot1,slot2 , lp,PL__ctx));
  1271.                             }
  1272.                             return TRUE;
  1273.                         }
  1274.                 }
  1275.             }
  1276.  
  1277.         case PL_VARIABLE:
  1278.             switch (lisp_type) {
  1279.                 case t_string:
  1280.                     RETURN_UNIFY_OBJECT(PL_unify_string_chars(var,(*slot1)->string.self));
  1281.                 case t_character:
  1282.                     RETURN_UNIFY_OBJECT(PL_unify_char(var,CHAR_CODE(*slot1),0                                          /*CHAR_MODE*/));
  1283.                 case t_shortfloat:
  1284.                 case t_longfloat:
  1285.                 case t_ratio:
  1286.                     RETURN_UNIFY_OBJECT(PL_unify_float(var,object_to_double(*slot1)));
  1287.                 case t_fixnum:
  1288.                 case t_bignum:
  1289.                     RETURN_UNIFY_OBJECT(PL_unify_integer(var,object_to_fixnum(*slot1)));
  1290.                 case t_symbol:{
  1291.                         if (*slot1==Cnil) return PL_unify_atom(var,ATOM_nil);
  1292.                         if (*slot1==Ct) return PL_unify_atom(var,ATOM_T);
  1293.                         name = lisp_to_atom(*slot1);{
  1294.                             term_t sym = PL_new_term_ref();
  1295.                             PL_put_atom(sym,name);
  1296.                             //LM_write("symbol name = ",PL_TERM,sym,PL_TERM,var);
  1297.                             FRAME_UNIFY_OBJECT(set_attribute(var,ATOM_lisp_symbol,sym,PL__ctx));
  1298.                         }
  1299.                         rval = PL_is_attvar(var);
  1300.                         return TRUE;
  1301.                     }
  1302.                 case t_cons:{
  1303.                         term_t car=PL_new_term_refs(2),cdr=car+1;
  1304.                         PL_unify_list(var,car,cdr);
  1305.                         FRAME_UNIFY_OBJECT(unify_object(car,&((*slot1)->cons.car),lp,PL__ctx));
  1306.                         return unify_object(cdr,&((*slot1)->cons.cdr),lp,PL__ctx);
  1307.                     }
  1308.                 case FREE: {
  1309.                         term_t value = PL_new_term_ref();
  1310.                         if (get_attribute(var,ATOM_lisp_object,value,PL__ctx))
  1311.                             return PL_get_pointer(value,(void**)slot1);
  1312.                         if (get_attribute(var,ATOM_lisp_slot,value,PL__ctx)) {
  1313.                             if (!PL_get_pointer(value,(void**)&slot2)) return FALSE;
  1314.                             *slot1 = *slot2;       
  1315.                         }
  1316.                         if (get_attribute(var,ATOM_lisp_symbol,value,PL__ctx)) {
  1317.                             if (!PL_get_atom(value,&name)) return FALSE;
  1318.                             *slot1 = *key_to_symbol(name);
  1319.                             return TRUE;
  1320.                         }
  1321.                     }
  1322.                     FRAME_UNIFY_OBJECT(set_attribute(var,ATOM_lisp_slot,PL_create_term(PL__ctx,PL_POINTER,slot1),PL__ctx));
  1323.                 default:{
  1324.                         if (lisp_type!=FREE) {
  1325.                             REQUIRE_UNIFY_OBJECT(
  1326.                                                 set_attribute(var,ATOM_lisp_type,
  1327.                                                               PL_create_term(PL__ctx,PL_ATOM,LPGlobal.type_atom[lisp_type]),PL__ctx));
  1328.                         }
  1329.                         if (slot1==NULL) {
  1330.                             return PL_error("unify_object", 2, "null slot1",2, ATOM_term , var);
  1331.                         }
  1332.                         if (*slot1==OBJNULL) {
  1333.                             FRAME_UNIFY_OBJECT(set_attribute(var,ATOM_lisp_slot,PL_create_term(PL__ctx,PL_POINTER,slot1),PL__ctx));
  1334.                         } else {
  1335.                             FRAME_UNIFY_OBJECT(set_attribute(var,ATOM_lisp_object,PL_create_term(PL__ctx,PL_POINTER,slot1),PL__ctx));
  1336.                         }
  1337.  
  1338.  
  1339.                     }
  1340.             }
  1341.         default:
  1342.             return set_attribute(var,ATOM_lisp_object,PL_create_term(PL__ctx,PL_POINTER,*slot1),PL__ctx);
  1343.             FAILED_UNIFY_OBJECT:
  1344.             NEVER_UNIFY_OBJECT:
  1345.             return FALSE;
  1346.             SUCCEED_UNIFY_OBJECT:
  1347.             return TRUE;
  1348.     }
  1349. }
  1350.  
  1351.  
  1352.  
  1353. extern struct cl_core_struct cl_core;
  1354.  
  1355. int main(int argc, char **args) {
  1356.     cl_object top_level;
  1357.     /* This should be always the first call */
  1358.     cl_boot(argc, args);
  1359.     initLPBindings(argc,args,(struct cl_env_struct*) &cl_env, (struct cl_core_struct*) &cl_core);
  1360.     /* We are computing unnormalized numbers at some point */
  1361.     //si_trap_fpe(Ct, Cnil);
  1362.     top_level = _intern("TOP-LEVEL", cl_core.system_package);
  1363.     cl_def_c_function(top_level, cfun_prolog, 0);
  1364.     funcall(1, top_level);
  1365.     return(0);
  1366. }
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!