namespace unification starts working reasonable, buggs remain
[gule-log:guile-log.git] / logic / guile-log / src / unify.c
1 /*
2         Copyright (C) 2009, 2010 Free Software Foundation, Inc.
3  
4  This library is free software; you can redistribute it and/or
5  modify it under the terms of the GNU Lesser General Public
6  License as published by the Free Software Foundation; either
7  version 3 of the License, or (at your option) any later version.
8  
9  This library is distributed in the hope that it will be useful,
10  but WITHOUT ANY WARRANTY; without even the implied warranty of
11  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12  Lesser General Public License for more details.
13  
14  You should have received a copy of the GNU Lesser General Public
15  License along with this library; if not, write to the Free Software
16  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17 */
18
19 #include<libguile.h>
20 #include<stdio.h>
21
22 //#define DB(X) X
23 #include "unify.h"
24
25 #define VECTOR_HEADER_SIZE 2
26
27 SCM tester = SCM_BOOL_F;
28
29 SCM inline get_cs(SCM v);
30
31 SCM gp_current_stack = SCM_BOOL_F;
32
33
34 SCM_DEFINE(gp_get_current_stack, "gp-current-stack-ref", 0, 0, 0, (), 
35            "takes cdr a prolog pair or scheme pair")
36 #define FUNC_NAME s_gp_get_current_stack
37 {
38   return gp_current_stack;
39 }
40 #undef FUNC_NAME
41
42
43 #define check_cs(cs,gp,str)                                             \
44   do                                                                    \
45   {                                                                     \
46     DB(if(cs < gp->gp_cons_stack || cs > gp->gp_cons_stack + 1000)      \
47          {                                                              \
48            scm_misc_error(str,"cs got wrong value",SCM_EOL);            \
49          })                                                             \
50   } while(0)
51
52 scm_t_bits gp_type;
53
54 SCM closure_tag;
55
56 #define gp_format0(str)                         \
57   DB(scm_simple_format(SCM_BOOL_T,              \
58                   scm_from_locale_string(str),  \
59                        SCM_EOL))
60
61 #define gp_format1(str,x)                       \
62   DB(scm_simple_format(SCM_BOOL_T,              \
63                   scm_from_locale_string(str),  \
64                        scm_list_1(x)))
65
66 #define gp_format2(str,x,y)                     \
67   DB(scm_simple_format(SCM_BOOL_T,              \
68                   scm_from_locale_string(str),  \
69                        scm_list_2(x,y)))
70
71 #define gp_format3(str,x,y,z)                   \
72   DB(scm_simple_format(SCM_BOOL_T,              \
73                   scm_from_locale_string(str),  \
74                        scm_list_3(x,y,z)))
75
76
77
78 #define DB(X)
79 #define DS(X) 
80 #define gp_debug0(s)        DB(printf(s)      ; fflush(stdout))
81 #define gp_debug1(s,a)      DB(printf(s,a)    ; fflush(stdout))
82 #define gp_debug2(s,a,b)    DB(printf(s,a,b)  ; fflush(stdout))
83 #define gp_debug3(s,a,b,c)  DB(printf(s,a,b,c); fflush(stdout))
84 #define gp_debug5(s,a,b,c,d,e)  DB(printf(s,a,b,c,d,e); fflush(stdout))
85 #define gp_debus0(s)        DS(printf(s)      ; fflush(stdout))
86 #define gp_debus1(s,a)      DS(printf(s,a)    ; fflush(stdout))
87 #define gp_debus2(s,a,b)    DS(printf(s,a,b)  ; fflush(stdout))
88 #define gp_debus3(s,a,b,c)  DS(printf(s,a,b,c); fflush(stdout))
89
90 // SPECIAL UNIVY VAR GC TIDBITS
91
92
93
94 /*
95    000 - A ref to a new object
96    010 - A cons ref
97    110 - A cons rest
98    100 - A rest
99
100  1x11xx - unbounded
101  1x01xx - eq
102  0x11xx - val
103
104   unbounded is a null reference aka X & 0b000  == 0
105 */
106
107 /*
108   We will work with three stacks.
109   stack  - the variable stack
110   cstack - storage stack to undo setted values
111   wstack - frame stack in order to do batched backtracking
112 */
113
114
115 scm_t_bits gp_smob_t;
116
117 // Assumes stack_a and stack_b are allocated in order they appear
118 #define GP(scm) (SCM_NIMP(scm) && SCM_SMOB_PREDICATE (gp_type, scm))
119 #define GP_STAR(scmp) (GP(GP_UNREF(scmp)))
120 /*
121   Tagging
122   xx00  Pointer
123   xx01  cons
124   xx10  val
125   xx11  unbound
126    1    attr flag
127   1     eq   flag
128   
129  */
130 //TODO: make use of smob flags macros for better stability
131 #define B(c) ((scm_t_bits) c)
132 #define GPM_BASE    B(0x30000)
133 #define GP_CLEAN    B(0x00000)
134 #define GPI_PTR     B(0x00000)
135 #define GPI_CONS    B(0x10000)
136 #define GPI_VAL     B(0x20000)
137 #define GPI_UNBD    B(0x30000)
138
139 #define GPI_ATTR    B(0x100000)
140 #define GPI_TOUCH   B(0x200000)
141 #define GPI_EQ      B(0x80000)
142 #define GPI_THREAD  B(0x40000)
143 #define GPQ_EQ      B(0xa0000)
144
145 #define GPI_SCM_M   B(0x400000)
146 #define GPI_GL_M    B(0x1800000)
147
148 #define GPM_PTR     B(0x0ffff)
149 #define GPM_CONS    B(0x1ffff)
150 #define GPM_VAL     B(0x2ffff)
151 #define GPM_UNBD    B(0x3ffff)
152 #define GPM_EQ      B(0xaffff)
153
154 #define GPI         B(0xf0000)
155 #define GPM         B((unsigned long) 0xfffff)
156
157 #define GPID        B(    0xffff0000000)
158 #define GPHA        B(0xffff00000000000)
159
160
161 #define GP_MARK(x)       (x & GPI_GL_M)
162 #define GP_SET_MARK(x)   (x | GPI_GL_M)
163 #define GP_CLEAR_MARK(x) (x & (~GPI_GL_M))
164
165 #define GP_HASH(x)  ((SCM_UNPACK(x) & GPHA) >> H_BITS)
166 #define GP_ID(x)    ((SCM_UNPACK(x) & GPID) >> N_BITS)
167
168 #define GP_FLAGS(x) ((x)[0])
169 #define GP_SCM(x)   ((x)[1])
170
171 #define GP_IS_EQ(x ) ((SCM_IMP(x) && !SCM_I_INUMP(x)) || scm_is_true(scm_symbol_p(x)))
172
173 #define GP_UNBOUND(ref) ( (SCM_UNPACK(GP_FLAGS(ref)) & GPM_BASE) == GPI_UNBD)
174 #define GP_POINTER(ref) ( (SCM_UNPACK(GP_FLAGS(ref)) & GPM_BASE) == GPI_PTR)
175 #define GP_CONS(ref)    ( (SCM_UNPACK(GP_FLAGS(ref)) & GPM_BASE) == GPI_CONS)
176 #define GP_VAL(ref)     ( (SCM_UNPACK(GP_FLAGS(ref)) & GPM_BASE) == GPI_VAL)
177
178 #define GP_EQ(ref)      ( SCM_UNPACK(GP_FLAGS(ref)) & GPI_EQ)
179 #define GP_ATTR(ref)    ( SCM_UNPACK(GP_FLAGS(ref)) & GPI_ATTR)
180 #define GP_THREAD(x)    (SCM_UNPACK(x) & GPI_THREAD)
181 #define GP_TOUCH(x)     (SCM_UNPACK(x) & GPI_TOUCH)
182
183 #define GP_MK_FRAME_VAL(fr)  ((fr) | GPI_VAL)
184 #define GP_MK_FRAME_PTR(fr)  ((fr) | GPI_PTR)
185 #define GP_MK_FRAME_CONS(fr) ((fr) | GPI_CONS)
186 #define GP_MK_FRAME_UNBD(fr) ((fr) | GPI_UNBD)
187
188 #define GP_MK_FRAME_EQ(fr)   ((fr) | GPQ_EQ)
189
190 #define SCM_TO_FI(x) SCM_I_INUM(x)
191 #define FI_TO_SCM(x) SCM_I_MAKINUM(x)
192
193 #define PTR2NUM(x) SCM_PACK((((scm_t_bits) x) | 2))
194 #define NUM2PTR(x) ((SCM *) (SCM_UNPACK(x) & ~2))
195
196 #define GP_CAR(id)  ((id) - 2)
197 #define GP_CDR(id)  ((id) - 4)
198 #define GP_BUDY(id) ((id) + 2)
199
200 #define GP_GETREF(x) ((SCM *) (x))
201
202 #define GP_UNREF(x)  ((SCM)   (x))
203
204 #define N_BITS 22
205 #define H_BITS 36
206
207 inline static SCM GP_IT(SCM* id)
208 {
209   return GP_UNREF(id);
210 }
211
212
213 static SCM* UN_GP(SCM scm)
214 {
215   return GP_GETREF(scm);
216 }
217
218 inline static void CPLX_TOUCH(SCM *id)
219 {
220   scm_t_bits val = SCM_UNPACK(id[0]);
221   id[0] = SCM_PACK(val | GPI_TOUCH);
222 }
223
224 inline static int IS_CPLX(SCM *id)
225 {
226   scm_t_bits val = SCM_UNPACK(id[0]);
227   return val & GPI_TOUCH;
228 }
229
230 SCM gp_unbound_sym;
231 SCM gp_unbound_str;
232 SCM gp_unwind_fluid;
233 SCM gp_cons_sym;
234 SCM gp_cons_str;
235
236
237 #include "state.c"
238
239 static inline struct gp_stack *get_gp()
240 {
241   SCM gp = scm_fluid_ref(gp_current_stack);
242   if(GP_STACKP(gp))
243     return (struct gp_stack *) SCM_SMOB_DATA(gp);
244
245   
246   scm_misc_error("get_gp","could not find stacks",SCM_EOL);
247   return (struct gp_stack *)0;
248 }
249
250 static inline SCM gp_make_vector(int n, struct gp_stack *gp)
251 {
252   SCM *vec = gp_alloc_data(n + VECTOR_HEADER_SIZE,gp);
253   ((scm_t_bits *) vec)[0] = (n << 8) | scm_tc7_vector;
254   ((scm_t_bits *) vec)[1] = 0;
255   return PTR2SCM(vec);
256 }
257
258 static inline SCM gp_make_closure(int n, SCM **closure, SCM s)
259 {
260   struct gp_stack *gp = get_gp();
261   SCM vec  = gp_make_vector(n,gp);
262   *closure = SCM_I_VECTOR_WELTS(vec);
263   gp_alloc_cons(gp,1);
264   return gpa_cons(closure_tag, vec, gp);
265 }
266
267 static inline SCM gp_make_closure_heap(int n, SCM **closure)
268 {
269   SCM vec  = scm_c_make_vector(n,SCM_BOOL_F);
270   *closure = SCM_I_VECTOR_WELTS(vec);
271   return scm_cons(closure_tag, vec);
272 }
273
274 #include "vlist/vlist-wrap.c"
275 #include "logical.c"
276
277 #define UNPACK_S(l,gp,s,err)                                    \
278   {                                                             \
279     SCM a;                                                      \
280     a = scm_fluid_ref(gp_current_stack);                        \
281     if(!GP_STACKP(a))                                           \
282       scm_misc_error("unpack_s2",err,SCM_EOL);                  \
283     gp = (struct gp_stack *) SCM_SMOB_DATA(a);                  \
284     gp_debug0(err);                                             \
285     if(!SCM_CONSP(s))                                           \
286       {                                                         \
287         l   = SCM_EOL;                                          \
288       }                                                         \
289     else                                                        \
290       {                                                         \
291         l  = SCM_CDR(s);                                        \
292       }                                                         \
293   }
294
295 #define UNPACK_S0(l,s,err)                                      \
296   {                                                             \
297     SCM a;                                                      \
298     a = scm_fluid_ref(gp_current_stack);                        \
299     if(!GP_STACKP(a))                                           \
300       scm_misc_error("unpack_s2",err,SCM_EOL);                  \
301     gp_debug0(err);                                             \
302     if(!SCM_CONSP(s))                                           \
303       {                                                         \
304         l   = SCM_EOL;                                          \
305       }                                                         \
306     else                                                        \
307       {                                                         \
308         l  = SCM_CDR(s);                                        \
309       }                                                         \
310   }
311
312 #define UNPACK_ALL(ci,l,ggp,gp,s,err)                    \
313   {                                                      \
314     ggp = scm_fluid_ref(gp_current_stack);               \
315     if(!GP_STACKP(ggp))                                  \
316       scm_misc_error("unpack_a2",err,SCM_EOL);           \
317     gp  = (struct gp_stack *) SCM_SMOB_DATA(ggp);        \
318     if(!SCM_CONSP(s))                                    \
319       {                                                  \
320         ci  = PTR2NUM(gp->gp_ci);                        \
321         l   = SCM_EOL;                                   \
322       }                                                  \
323     else                                                 \
324       {                                                  \
325         l   = SCM_CDR(s);                                \
326         ci  = SCM_CAR(s);                                \
327       }                                                  \
328   }
329
330 #define UNPACK_ALL0(l,ggp,gp,s,err)                      \
331   {                                                      \
332     ggp = scm_fluid_ref(gp_current_stack);               \
333     if(!GP_STACKP(ggp))                                  \
334       scm_misc_error("unpack_a2",err,SCM_EOL);           \
335     gp  = (struct gp_stack *) SCM_SMOB_DATA(ggp);        \
336     if(!SCM_CONSP(s))                                    \
337       {                                                  \
338         l   = SCM_EOL;                                   \
339       }                                                  \
340     else                                                 \
341       {                                                  \
342         l   = SCM_CDR(s);                                \
343       }                                                  \
344   }
345
346 #define UNPACK_ALL00(ggp,gp,s,err)                       \
347   {                                                      \
348     ggp = scm_fluid_ref(gp_current_stack);               \
349     if(!GP_STACKP(ggp))                                  \
350       scm_misc_error("unpack_a2",err,SCM_EOL);           \
351     gp  = (struct gp_stack *) SCM_SMOB_DATA(ggp);        \
352   }
353
354 #define PACK_ALL(ci,l,lnew,gp,s)                \
355   {                                             \
356     if(!scm_is_eq(l,lnew))                      \
357       s = scm_cons(ci,lnew);                    \
358   }
359
360 inline SCM gp_make_s(SCM ci, SCM *l)
361 {
362   SCM ll;
363   if(vlist_p(l[0]))
364     {
365       ll = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
366     } else
367     {
368       ll = l[0];
369     }
370   return scm_cons(ci,ll);  
371 }
372
373 #define GP_TEST_CSTACK if(gp->gp_ci > gp->gp_nnc) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_nc))
374
375 static inline void gp_store_var_2(SCM *id, int simple, struct gp_stack *gp)
376 {
377   GP_TEST_CSTACK;
378
379   if(!GP(GP_UNREF(id)))
380     scm_misc_error("gp_store_var_2"," got non gp variable to set",SCM_EOL);
381
382   if(GP_UNBOUND(id))
383     {
384       *(gp->gp_ci) = GP_UNREF(id);
385     }
386   else
387     {
388       CPLX_TOUCH(id);
389       *(gp->gp_ci) = scm_cons(GP_UNREF(id),  scm_cons(SCM_I_MAKINUM(id[0]),
390                                                       id[1]));
391     }
392   
393   gp_debug1("stored> %x\n",SCM_UNPACK(gp->gp_ci[0]));
394   gp->gp_ci += 1;
395 }
396
397 static inline void mask_on(int stack_nr, SCM *id, SCM flags)
398 {
399   scm_t_bits nr = ((((scm_t_bits) stack_nr) & 0xffff) << N_BITS);
400   *id =  SCM_PACK((SCM_UNPACK(*id) & GP_CLEAN)| SCM_UNPACK(flags) | nr);
401   gp_debug2("tag> %x %x\n",SCM_UNPACK(*id),nr);
402 }
403
404
405 static inline SCM handle(SCM *id, SCM flags, SCM v, SCM l, struct gp_stack *gp, int k, int bang)
406
407
408   if(!GP(GP_UNREF(id)))
409     scm_misc_error("unify.c: handle"," got non gp variable to set",SCM_EOL);
410
411   if(gp->_logical_) return logical_add2(GP_UNREF(id),v,l);
412
413
414
415   if(GP_THREAD(id[0]))
416     {
417       gp_debug1("id0 = %x\n",SCM_UNPACK(id[0]));
418       gp_debug0("got a thraed variable to set!\n");
419       id = id + gp->thread_id * 2;
420     }
421   
422   if(GP_ID(*id) != gp->id && gp->_thread_safe_)
423     {
424       gp_debug0("logical add\n");
425       return logical_add2(GP_UNREF(id),v,l);
426     }
427  
428   gp_debug1("set var... bang!(%d)",bang);
429   
430   if(!bang) gp_store_var_2(id,k,gp);
431
432   mask_on(gp->id,id,flags);
433   *(id + 1) = v;
434
435   return l;
436 }
437
438 static inline SCM handle_l(SCM *id, SCM flags, SCM v, SCM *l, struct gp_stack *gp, int k, int bang)
439
440
441   if(!GP(GP_UNREF(id)))
442     scm_misc_error("unify.c: handle"," got non gp variable to set",SCM_EOL);
443
444   if(gp->_logical_) return logical_add2_l(GP_UNREF(id),v,l);
445
446
447
448   if(GP_THREAD(id[0]))
449     {
450       gp_debug1("id0 = %x\n",SCM_UNPACK(id[0]));
451       gp_debug0("got a thraed variable to set!\n");
452       id = id + gp->thread_id * 2;
453     }
454   
455   if(GP_ID(*id) != gp->id && gp->_thread_safe_)
456     {
457       gp_debug0("logical add\n");
458       return logical_add2_l(GP_UNREF(id),v,l);
459     }
460
461   gp_debug1("set var... bang!(%d)",bang);
462   
463   if(!bang) gp_store_var_2(id,k,gp);
464
465   mask_on(gp->id,id,flags);
466   *(id + 1) = v;
467
468   return SCM_BOOL_T;
469 }
470
471 static inline void handle_force(SCM *id, SCM flags, SCM v)
472
473
474   if(!GP(GP_UNREF(id)))
475     scm_misc_error("unify.c: handle"," got non gp variable to set",SCM_EOL);
476   int i = SCM_UNPACK(id[0]) >> N_BITS;
477   mask_on(i, id, flags);
478   *(id + 1) = v;
479 }
480
481
482 static inline SCM gp_set_val(SCM *id, SCM v, SCM l, struct gp_stack *gp)
483 {
484   SCM flags;
485   if(GP_IS_EQ(v))
486     flags =  SCM_PACK(GP_MK_FRAME_EQ(gp_type));
487   else
488     flags =  SCM_PACK(GP_MK_FRAME_VAL(gp_type));
489
490   return handle(id, flags, v, l, gp, 0, 0);
491 }
492
493 static inline SCM gp_set_val_l(SCM *id, SCM v, SCM *l, struct gp_stack *gp)
494 {
495   SCM flags;
496   if(GP_IS_EQ(v))
497     flags =  SCM_PACK(GP_MK_FRAME_EQ(gp_type));
498   else
499     flags =  SCM_PACK(GP_MK_FRAME_VAL(gp_type));
500
501   return handle_l(id, flags, v, l, gp, 0, 0);
502 }
503
504 static inline SCM gp_set_val_bang(SCM *id, SCM v, SCM l, struct gp_stack *gp)
505 {
506   SCM flags; 
507
508   if(GP_IS_EQ(v))
509     flags =  SCM_PACK(GP_MK_FRAME_EQ(gp_type));
510   else
511     flags =  SCM_PACK(GP_MK_FRAME_VAL(gp_type));
512   
513   return handle(id, flags, v, l, gp, 0, 1);
514 }
515
516 static inline void gp_set_val_force(SCM *id, SCM v)
517 {
518   SCM flags; 
519
520   if(GP_IS_EQ(v))
521     flags =  SCM_PACK(GP_MK_FRAME_EQ(gp_type));
522   else
523     flags =  SCM_PACK(GP_MK_FRAME_VAL(gp_type));
524   
525   handle_force(id, flags, v);
526 }
527
528 static inline SCM gp_set_ref(SCM *id, SCM ref, SCM l, struct gp_stack *gp)
529 {
530   SCM flags;
531   if(!GP(ref))  return gp_set_val(id,ref,l,gp);
532   
533   CPLX_TOUCH(GP_GETREF(id));
534
535   flags = SCM_PACK(GP_MK_FRAME_PTR(gp_type));
536   
537   return handle(id, flags, ref, l, gp, 0, 0);
538 }
539
540 static inline SCM gp_set_ref_l(SCM *id, SCM ref, SCM *l, struct gp_stack *gp)
541 {
542   SCM flags;
543   if(!GP(ref))  return gp_set_val_l(id,ref,l,gp);
544   
545   CPLX_TOUCH(GP_GETREF(id));
546
547   flags = SCM_PACK(GP_MK_FRAME_PTR(gp_type));
548   
549   return handle_l(id, flags, ref, l, gp, 0, 0);
550 }
551
552 static inline SCM gp_set_ref_bang(SCM *id, SCM ref, SCM l, struct gp_stack *gp)
553 {
554   SCM flags;
555   if(!GP(ref))  return gp_set_val_bang(id,ref,l,gp);
556
557   flags = SCM_PACK(GP_MK_FRAME_PTR(gp_type));
558
559   return handle(id, flags, ref, l, gp, 0, 1);
560 }
561
562 static inline void gp_set_ref_force(SCM *id, SCM ref)
563 {
564   SCM flags;
565   if(!GP(ref))  return gp_set_val_force(id,ref);
566
567   flags = SCM_PACK(GP_MK_FRAME_PTR(gp_type));
568
569   handle_force(id, flags, ref);
570 }
571
572 static inline SCM gp_set_eq(SCM *id, SCM v, SCM l, struct gp_stack *gp)
573 {
574   SCM flags;
575
576   flags = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
577
578   return handle(id, flags, v, l, gp, 0, 0);
579 }
580
581 static inline SCM gp_set_eq_bang(SCM *id, SCM v, SCM l, struct gp_stack *gp)
582 {
583
584   SCM flags;
585
586   flags = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
587
588   return handle(id, flags, v, l, gp, 0, 1);
589 }
590
591
592 static inline SCM gp_set_unbound(SCM *id, SCM l, struct gp_stack *gp)
593 {
594   SCM flags ;
595
596   flags = SCM_PACK(GP_MK_FRAME_UNBD(gp_type));
597
598   return handle(id, flags, SCM_UNBOUND, l, gp, 0, 0);
599 }
600
601 static inline SCM gp_set_unbound_bang(SCM *id, SCM l, struct gp_stack *gp)
602 {
603   SCM flags ;
604
605   flags = SCM_PACK(GP_MK_FRAME_UNBD(gp_type));
606
607   return handle(id, flags, SCM_UNBOUND, l, gp, 0, 1);
608 }
609   
610 #define gp_lookup_l(i1,i2,l)                    \
611 {                                               \
612   if(SCM_UNLIKELY(!scm_is_eq(*l,SCM_EOL)))      \
613     i1 = gp_lookup_ll(i2,l);                    \
614   else                                          \
615     {                                           \
616       while(GP_STAR(i2) && GP_POINTER(i2))      \
617         i2 = GP_GETREF(GP_SCM(i2));             \
618       i1 = i2;                                  \
619     }                                           \
620 }
621
622 static inline SCM * gp_lookup(SCM *id, SCM l)
623  {  
624   gp_debug0("lookup>\n");
625   
626   
627  retry:
628   
629   if(GP_STAR(id) && GP_POINTER(id))
630     {
631       id = GP_GETREF(GP_SCM(id));
632       goto retry;
633     }
634  
635   if(GP_STAR(id) && GP_UNBOUND(id) && !scm_is_eq(l,SCM_EOL)) goto advanced;
636   return id;
637
638
639  advanced:
640   id = GP_GETREF(logical_lookup3(GP_UNREF(id),l));
641   gp_debug0("lookup> /2\n");
642
643   if(!GP_STAR(id)) 
644     {
645       gp_debug0("lookup> no star\n");
646       return id;
647     }
648
649   gp_debug0("lookup> /3\n");
650
651   if(GP_STAR(id) && GP_POINTER(id))
652     {
653       id = GP_GETREF(GP_SCM(id));
654       goto retry;
655     }
656
657   gp_debug2("lookup> %x 0 val = %x\n",id,SCM_UNPACK(*id)) ;
658   return id;
659 }
660
661 static inline SCM * gp_lookup2(SCM *id, SCM l)
662  {  
663   gp_debug0("lookup>\n");
664
665
666   
667  retry:
668   if(GP_POINTER(id))
669     {
670       id = GP_GETREF(GP_SCM(id));
671       goto retry;
672     }
673
674   // if(!scm_is_eq(l,SCM_EOL)) goto advanced;
675  
676   return id;
677
678
679  advanced:
680   id = GP_GETREF(logical_lookup4(GP_UNREF(id),l));
681   gp_debug0("lookup> /2\n");
682   
683   if(!GP_STAR(id)) 
684     {
685       gp_debug0("lookup> no star\n");
686       return id;
687     }
688
689   gp_debug0("lookup> /3\n");
690
691   if(GP_POINTER(id))
692     {
693       id = GP_GETREF(GP_SCM(id));
694       goto advanced;
695     }
696
697
698   gp_debug2("lookup> %x 0 val = %x\n",id,SCM_UNPACK(*id)) ;
699   return id;
700 }
701
702
703 static inline SCM * gp_lookup_ll(SCM *id, SCM *l)
704  {  
705   gp_debug0("lookup>\n");
706   
707   
708  retry:  
709   if(GP_STAR(id) && GP_POINTER(id))
710     {
711       id = GP_GETREF(GP_SCM(id));
712       goto retry;
713     }
714
715   if(!scm_is_eq(*l,SCM_EOL) && GP_STAR(id) && GP_UNBOUND(id)) 
716     goto advanced;
717
718   return id;
719
720
721  advanced:
722   id = GP_GETREF(logical_lookup_l(GP_UNREF(id),l));
723   gp_debug0("lookup> /2\n");
724
725   if(!GP_STAR(id)) 
726     {
727       gp_debug0("lookup> no star\n");
728       return id;
729     }
730
731   gp_debug0("lookup> /3\n");
732
733   if(GP_STAR(id) && GP_POINTER(id))
734     {
735       id = GP_GETREF(GP_SCM(id));
736       goto retry;
737     }
738
739   gp_debug2("lookup> %x 0 val = %x\n",id,SCM_UNPACK(*id)) ;
740   return id;
741 }
742
743 /*
744   This routine stores information about stacks on the 
745   control stack and returns a structure representing the
746   computational state. This routine makes sure to allocate
747   datstructures before storing the state in them meaning that
748   after an unwind the unwind information can be reused.
749  */
750
751 //#define DB(X) X
752 static inline SCM gp_newframe(SCM s)
753 {
754   SCM *ci,l;
755   struct gp_stack *gp = get_gp();
756   SCM tag;
757
758   if(SCM_CONSP(s))
759     {
760       tag = SCM_CAR(s);
761       ci = NUM2PTR(tag);     
762       l  = SCM_CDR(s);
763     }
764   else
765     {
766       s = SCM_PACK(0);
767       ci = gp->gp_ci;
768       l  = SCM_EOL;
769     }
770    
771   {
772     SCM        ha    =            ci[-4];
773     scm_t_bits dyn_n = SCM_UNPACK(ci[-3]);
774     SCM        *si   = NUM2PTR   (ci[-2]);
775     SCM        v     = get_cs    (ci[-1]);
776     SCM        *cs   = NUM2PTR(v);
777       
778     gp_debug0("check\n");
779       
780     DB(if(cs < gp->gp_cons_stack || cs > gp->gp_cons_stack + 1000)    
781          {                                   
782            printf("er %x %x\n",cs - gp->gp_cons_stack,
783                   cs - gp->gp_stack);
784            scm_misc_error("newframe","cs got wrong value ~a",
785                           scm_list_1(ci[-1]));       
786          });                           
787
788     check_cs(cs,gp,"newframe 0");
789
790     gp_debug3("work (%p %p %p)\n",
791               gp->gp_ci - ci,
792               gp->gp_si - si,
793               gp->gp_cs - cs);
794     if(si    == gp->gp_si && 
795        cs    == gp->gp_cs &&
796        dyn_n == gp->dynstack_length &&
797        ha    == gp->handlers &&
798        ci    == gp->gp_ci)
799       {
800         gp_debug0("return same\n");
801         if(s)
802           return s;
803         else
804           return scm_cons(PTR2NUM(gp->gp_ci), l);
805       }
806          
807     {
808       SCM ret;
809
810       gp_debug0("newframe\n");
811       GP_TEST_CSTACK;
812
813       gp->gp_ci   += 4;
814
815       SCM cons = PTR2NUM(gp->gp_ci);        
816
817       l = scm_is_false(l) ? SCM_EOL : l;
818       ret =  scm_cons(cons, l);
819
820       gp->gp_ci[-4] = gp->handlers;
821       gp->gp_ci[-3] = SCM_PACK (gp->dynstack_length);
822       gp->gp_ci[-2] = PTR2NUM  (gp->gp_si);
823       gp->gp_ci[-1] = PTR2NUM  (gp->gp_cs);        
824
825       gp_debug0("return\n");
826       return ret;
827     }    
828   }
829 }
830
831 //#define DB(X)
832
833 #define GP_TEST_STACK if(gp->gp_si > gp->gp_nns) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_ns))
834
835 static inline  SCM* gp_mk_var(SCM s)
836 {
837   SCM *ret;
838   struct gp_stack *gp = get_gp();  
839   gp_debug0("got a gp");
840   if(gp->_logical_) return GP_GETREF(make_logical());
841     
842   GP_TEST_STACK;
843
844   gp_debug1("test stack handled! %x\n",gp->gp_si);
845   ret  = gp->gp_si;
846   gp->gp_si += 2;
847
848   mask_on(gp->id,ret,SCM_PACK(GP_MK_FRAME_UNBD(gp_type))); 
849   *(ret + 1) = SCM_UNBOUND;
850   
851   gp_debug1("returning from mk_var %x\n",ret);
852   return ret;
853 }
854
855
856
857 static inline SCM gp_mk_cons(SCM s) 
858 {
859   SCM *ret;
860   scm_t_bits fi; 
861   struct gp_stack *gp;
862   gp = get_gp();
863
864   if(gp->_logical_) return scm_cons(make_logical(),make_logical());
865
866
867
868   GP_TEST_STACK;
869   GP_TEST_CSTACK;
870
871   ret = gp->gp_si;
872   gp->gp_si += 6;
873
874   gp_debug0("in cons is %x\n");
875
876   fi = GP_MK_FRAME_CONS(gp_type);
877
878   mask_on(gp->id,(ret+4),SCM_PACK(fi));
879   *(ret+5) = SCM_UNDEFINED;  
880   
881   *(gp->gp_ci) = GP_UNREF(ret + 4);
882   gp->gp_ci ++;
883
884   fi = GP_MK_FRAME_UNBD(gp_type);
885   mask_on(gp->id,(ret+2),SCM_PACK(fi));
886   mask_on(gp->id,(ret+0),SCM_PACK(fi));
887
888   *(ret+1) = SCM_UNBOUND;
889   *(ret+3) = SCM_UNBOUND;
890
891   return GP_UNREF(ret + 4);
892 }
893
894 #define gp_struct_ref(scm,i) SCM_PACK(SCM_STRUCT_DATA(scm)[i])
895
896 SCM closure_struct = SCM_BOOL_F;
897 #define GP_MK_CLOSURE(x,y,z,w)                                          \
898   scm_c_make_struct(closure_struct, 0,                                  \
899                     SCM_UNPACK(x),SCM_UNPACK(y),SCM_UNPACK(z),SCM_UNPACK(w));
900
901 #define GP_CLOSURE_P(x) (SCM_STRUCT_VTABLE(x) == closure_struct)
902
903 SCM_DEFINE(gp_set_closure_struct,"set-closure-struct!",1,0,0,(SCM scm),
904            "set the struct variable")
905 #define FUNC_NAME s_gp_set_closure_struct
906 {
907   closure_struct = scm;
908   return SCM_UNSPECIFIED;
909 }
910 #undef FUNC_NAME
911
912 SCM closed_error_fkn = SCM_BOOL_F;
913 SCM throw_closed_p;
914
915 SCM_DEFINE(gp_setup_closed, "setup-closed",1,0,0,(SCM err),
916 "err is the error function called when unifying closures, returns a fluid that controls the throwing of error or not")
917 #define FUNC_NAME s_setup_closed
918 {  
919   closed_error_fkn = err;
920   return throw_closed_p;
921 }
922 #undef FUNC_NAME
923
924 SCM namespace_fkn    = SCM_BOOL_F;
925 SCM namespace_struct = SCM_BOOL_F;
926 #define GP_NAMESPACE_P(x) (SCM_STRUCT_VTABLE(x) == namespace_struct)
927 #define GP_MK_NAMESPACE(x,y,z,w)                                        \
928   scm_c_make_struct(namespace_struct, 0,                                \
929                     SCM_UNPACK(x),SCM_UNPACK(y),SCM_UNPACK(z),SCM_UNPACK(w));
930
931 SCM_DEFINE(gp_setup_namespace, "setup-namespace",2,0,0,(SCM record, SCM nsfkn),
932 "supplies the record for the namespace struct and the name space unification function")
933 #define FUNC_NAME s_setup_namespace
934 {  
935   namespace_fkn   = nsfkn;
936   namespace_struct = record;
937   return SCM_UNSPECIFIED;
938 }
939 #undef FUNC_NAME
940
941 static int gp_recurent(SCM *id1,SCM *id2, SCM *l)
942 {  
943   SCM scm;
944   gp_debug0("recurent>\n");
945
946   if(!GP(GP_UNREF(id2))) goto non_gp;
947
948   gp_lookup_l(id2,id2,l);  
949
950   if(!GP_STAR(id2)) goto non_gp;
951
952   gp_debug0("recurent> looked up data\n");
953   if(id1 == id2  )  
954     {
955       gp_debug0("recurent> Found a recurence!!\n");
956       return 1;  
957     }
958   
959   if(GP_CONS(id2))
960     {
961       gp_debug0("recurent> got a cons\n");
962       return gp_recurent(id1,GP_CAR(id2),l) || gp_recurent(id1,GP_CDR(id2),l);      
963     }
964
965   if(GP_UNBOUND(id2)) return 0;
966
967   scm = GP_SCM(id2);
968   gp_debug0("linked scm\n");
969  retry:
970   if(SCM_CONSP(scm))
971     {
972       gp_debug0("cons\n");
973       return 
974         (gp_recurent(id1,GP_GETREF(SCM_CAR(scm)),l) ||
975          gp_recurent(id1,GP_GETREF(SCM_CDR(scm)),l));
976     }
977
978   if(SCM_I_IS_VECTOR(scm))
979     {
980       gp_debug0("vector\n");
981       scm = scm_vector_to_list(scm);
982       goto retry;
983     }
984
985
986   if(SCM_STRUCTP(scm))
987     {
988       if(GP_CLOSURE_P(scm))
989         {
990           scm = gp_struct_ref(scm,2);
991           goto retry;
992         } 
993       else if (GP_NAMESPACE_P(scm))
994         {
995           scm = gp_struct_ref(scm,0);
996           goto retry;
997         }
998
999       return 0;
1000     }
1001
1002   if(SCM_FLUID_P(scm))
1003     {
1004       scm = scm_fluid_ref(scm);
1005       goto retry;
1006     }
1007
1008
1009   gp_debug0("recurent> atom!\n");
1010   return 0;
1011
1012  non_gp:
1013   {
1014     SCM scm = GP_UNREF(id2);
1015     gp_debug0("non gp\n");
1016   retryII:
1017     if(SCM_CONSP(scm))
1018       {
1019         gp_debug0("cons\n");
1020         return 
1021           gp_recurent(id1,GP_GETREF(SCM_CAR(scm)), l) ||
1022           gp_recurent(id1,GP_GETREF(SCM_CDR(scm)), l);
1023       }
1024
1025     if(SCM_I_IS_VECTOR(scm))
1026       {
1027         gp_debug0("vector\n");
1028         scm = scm_vector_to_list(scm);
1029         goto retryII;
1030       }
1031   }
1032
1033   return 0;
1034 }
1035
1036
1037 static SCM smob2scm_gp(SCM *id, SCM s)
1038 {
1039   SCM scm;
1040  
1041   if(GP_UNBOUND(id))
1042     return GP_UNREF(id);
1043   
1044   scm = GP_SCM(id);
1045   if(SCM_CONSP(scm))
1046     {     
1047       SCM car = smob2scm(SCM_CAR(scm), s);
1048       SCM cdr = smob2scm(SCM_CDR(scm), s);
1049       if(car == SCM_CAR(scm) && cdr == SCM_CDR(scm))
1050         return scm;
1051       return scm_cons(car,cdr);
1052     }
1053   else
1054     return scm;
1055 }
1056
1057 int _gp_2_scm(SCM **spp, int nargs, SCM *cl, SCM *max)
1058 {
1059   SCM *sp = *spp;
1060   if(nargs != 2)
1061     scm_misc_error("gp->scm","wrong number of arguments", SCM_EOL);
1062   
1063   sp[-2] = smob2scm(sp[-1],sp[0]);
1064  
1065   *spp = sp - 2;
1066   return -1;
1067 }
1068
1069
1070 SCM_DEFINE( smob2scm, "gp->scm", 2, 0, 0, (SCM scm, SCM s),
1071             "creates a scheme representation of a gp object")
1072 #define FUNC_NAME s_smob2scm
1073 {
1074   gp_debus0("gp->scm>\n");
1075   if(GP(scm))
1076     {
1077       SCM *id;
1078       id = UN_GP(scm);
1079       
1080       id = GP_GETREF(gp_gp_lookup(scm, s));
1081       if(!GP_STAR(id))
1082         {
1083           scm = GP_UNREF(id);
1084           goto do_scm;
1085         }
1086
1087       if(GP_CONS(id))
1088         {
1089           return scm_cons(smob2scm(SCM_PACK(GP_CAR(id)), s),
1090                           smob2scm(SCM_PACK(GP_CDR(id)), s));
1091         }      
1092       return smob2scm_gp(id, s);
1093     }
1094   else 
1095     {
1096     do_scm:
1097       if(SCM_CONSP(scm))
1098         {         
1099           SCM car = smob2scm(SCM_CAR(scm), s);
1100           SCM cdr = smob2scm(SCM_CDR(scm), s);
1101           if(car == SCM_CAR(scm) && cdr == SCM_CDR(scm))
1102             return scm;
1103           return scm_cons(car,cdr);
1104         }
1105       
1106       if(SCM_STRUCTP(scm))
1107         {
1108           if(GP_CLOSURE_P(scm))
1109             {
1110               SCM args = smob2scm(gp_struct_ref(scm,2), s);
1111               SCM f    = gp_struct_ref(scm,1);
1112                 
1113               return GP_MK_CLOSURE(scm_apply_0(f,args), f, args,
1114                                    gp_struct_ref(scm,3));
1115             }
1116
1117           if(GP_NAMESPACE_P(scm))            
1118             return GP_MK_NAMESPACE(smob2scm(gp_struct_ref(scm,0), s),
1119                                    gp_struct_ref(scm,1),
1120                                    gp_struct_ref(scm,2),
1121                                    gp_struct_ref(scm,3));
1122         }
1123
1124       return scm;
1125     }
1126 }
1127 #undef FUNC_NAME
1128
1129 int len(SCM x, SCM *l)
1130 {
1131   int i = 0;
1132   SCM *id = GP_GETREF(x);
1133
1134  retry:
1135   gp_lookup_l(id,id,l);
1136   
1137   if(GP_STAR(id))
1138     {
1139       if(GP_UNBOUND(id))
1140         return -1;
1141
1142       if(GP_CONS(id))
1143         {
1144           i++;
1145           id = GP_CDR(id);
1146           goto retry;
1147         }
1148     }
1149   else
1150     {
1151       x = GP_UNREF(id);
1152       if(SCM_CONSP(x))
1153         {
1154           i++;
1155           id = GP_GETREF(SCM_CDR(x));          
1156           goto retry;
1157         }
1158     }
1159   
1160   return i;
1161 }
1162
1163 #define QCDR(x)   GP_GETREF(SCM_CDR(GP_UNREF(x))) 
1164 #define QCAR(x)   GP_GETREF(SCM_CAR(GP_UNREF(x))) 
1165 #define QCONSP(x) SCM_CONSP(GP_UNREF(x))
1166
1167 #define DO_NAMESPACE(scm2, id2, id1)                                    \
1168   {                                                                     \
1169     SCM scm2 = GP_STAR(id2)?GP_SCM(id2):GP_UNREF(id2);                  \
1170     gp_format1("(do_ns ~a)~%",scm2);                                    \
1171     if(SCM_STRUCTP(scm2))                                               \
1172       {                                                                 \
1173         if(GP_NAMESPACE_P(scm2))                                        \
1174           {                                                             \
1175             SCM bang = SCM_BOOL_T;                                      \
1176             if(!gp_plus_unify)                                          \
1177               {                                                         \
1178                 bang = SCM_BOOL_F;                                      \
1179               }                                                         \
1180             {                                                           \
1181               SCM s = gp_make_s(ci,l);                                  \
1182               s = scm_call_4(namespace_fkn,s,scm2,GP_UNREF(id1),bang);  \
1183               if(scm_is_false(s))                                       \
1184                 return (SCM) 0;                                         \
1185                                                                         \
1186               SCM ll = SCM_CDR(s);                                      \
1187               if(vlist_p(ll))                                           \
1188                 {                                                       \
1189                   l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(ll,0))));       \
1190                   l[2] = SCM_PACK(my_scm_to_int(S(ll,1)));              \
1191                 }                                                       \
1192               else                                                      \
1193                 l[0] = ll;                                              \
1194             }                                                           \
1195                                                                         \
1196             U_NEXT;                                                     \
1197           }                                                             \
1198       }                                                                 \
1199   }
1200 //#define DB(X) X
1201 // unify under + means unification - means just match
1202 static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, struct gp_stack *gp, SCM ci)
1203
1204   SCM * stack[110];
1205   int   sp;
1206   sp = 0;
1207   gp_format2("(gp-unify! ~a ~a)~%",GP_UNREF(id1),GP_UNREF(id2));
1208 #define U_NEXT                                  \
1209   {                                             \
1210   if(SCM_UNLIKELY(sp==0))                       \
1211     {                                           \
1212       return *l;                                \
1213     }                                           \
1214   else                                          \
1215     {                                           \
1216       id2 = stack[--sp];                        \
1217       id1 = stack[--sp];                        \
1218       goto retry;                               \
1219     }                                           \
1220 }
1221
1222  retry:
1223   gp_debug0("unify>\n");  
1224
1225   if(SCM_CONSP(GP_UNREF(id1)) && SCM_CONSP(GP_UNREF(id2)))
1226     goto uu00;
1227
1228   if(GP_STAR(id1))
1229     {
1230       if(GP_STAR(id2))
1231         {
1232           gp_debug0("11>\n");
1233           gp_lookup_l(id2,id2,l);
1234           gp_lookup_l(id1,id1,l);
1235
1236           if(! (GP_STAR(id1) && GP_STAR(id2))) goto retry;
1237
1238           if(SCM_CONSP(GP_SCM(id1)))
1239             {
1240               id1 = GP_GETREF(GP_SCM(id1));              
1241               if(SCM_CONSP(GP_SCM(id2)))
1242                 {
1243                   id2 = GP_GETREF(GP_SCM(id2));
1244                   goto u00;
1245                 }
1246               else
1247                 {
1248                   DO_NAMESPACE(scm2, id2, id1);
1249                   goto u01;
1250                 }
1251             }
1252           else
1253             {
1254               if(SCM_CONSP(GP_SCM(id2)))
1255                 {
1256                   id2 = GP_GETREF(GP_SCM(id2));
1257                   DO_NAMESPACE(scm1, id1, id2);
1258                   goto u10;
1259                 }
1260               //u11 falls through
1261             }
1262         }
1263       else
1264         {
1265           gp_debug0("10>\n");
1266           gp_lookup_l(id1,id1,l);
1267           if(! (GP_STAR(id1))) goto retry;
1268           gp_debug0("10> lookup__\n");
1269           if(SCM_CONSP(GP_SCM(id1)))
1270             {
1271               id1 = GP_GETREF(GP_SCM(id1));
1272               DO_NAMESPACE(scm2, id2, id1);
1273               goto u00;
1274             }
1275
1276           goto u10;
1277         }
1278     }
1279   else
1280     {
1281       if(GP(GP_UNREF(id2)))
1282         {
1283           gp_debug0("01>\n");
1284           gp_lookup_l(id2,id2,l);
1285           if(!(GP_STAR(id2))) goto retry;
1286
1287           if(SCM_CONSP(GP_SCM(id2)))
1288             {
1289               id2 = GP_GETREF(GP_SCM(id2));
1290               DO_NAMESPACE(scm1, id1, id2);
1291               goto u00;
1292             }
1293
1294           goto u01;
1295         }
1296
1297       gp_debug0("00>\n");     
1298       goto u00;
1299     }
1300   
1301   // u11 Has unbounded variables
1302   gp_debug0("unify> looked up with u11\n");
1303   if(GP_UNBOUND(id1))
1304     {
1305       if(id1 == id2)
1306         {
1307           gp_debug0("unify> var == var");
1308           U_NEXT;
1309         }
1310       else
1311         {
1312           if(gp_plus_unify) 
1313             {
1314               DO_NAMESPACE(scm1, id2, id1);
1315               goto  unbound1;
1316             }
1317           else
1318             return (SCM) 0;
1319         }
1320     }
1321   
1322   if(GP_UNBOUND(id2))
1323     {
1324       if(id1 == id2)
1325         {
1326           gp_debug0("unify> var == var");
1327           U_NEXT;
1328         }
1329       else
1330         {
1331           if(gp_plus_unify)
1332             {
1333               DO_NAMESPACE(scm1, id1, id2);
1334               goto  unbound2;
1335             }
1336           else
1337             return (SCM) 0;
1338         }
1339     }
1340
1341   //any conses?
1342 #define DO_CONS                                         \
1343   {                                                     \
1344     gp_debug0("unify> cons\n");                         \
1345     if(SCM_UNLIKELY(sp >= 100))                         \
1346       {                                                 \
1347         SCM ret = gp_unify(GP_CAR(id1), GP_CAR(id2)           \
1348                            , raw, gp_plus_unify,l,gp,ci);     \
1349         if(!ret) return (SCM) 0;                          \
1350         id1 = GP_CDR(id1);                              \
1351         id2 = GP_CDR(id2);                              \
1352         goto retry;                                     \
1353       }                                                 \
1354     else                                                \
1355       {                                                 \
1356         stack[sp++] = GP_CDR(id1);                      \
1357         stack[sp++] = GP_CDR(id2);                      \
1358         id1 = GP_CAR(id1);                              \
1359         id2 = GP_CAR(id2);                              \
1360         goto retry;                                     \
1361       }                                                 \
1362   }
1363
1364   //Cons check
1365   if(GP_CONS(id1))
1366     {
1367       if(GP_CONS(id2))
1368         {
1369           DO_CONS;
1370         }
1371       else
1372         DO_NAMESPACE(scm2, id2, id1);
1373         return (SCM) 0;
1374     }
1375
1376   if(GP_CONS(id2))
1377     {
1378       DO_NAMESPACE(scm1, id1, id2);
1379       return (SCM) 0;
1380     }
1381
1382   //has to be an equality check
1383   if(GP_EQ(id1) || GP_EQ(id2))
1384     {
1385       gp_debug2("unify> (eq ~x ~x)\n", GP_SCM(id1), GP_SCM(id2));
1386       if(scm_is_eq(GP_SCM(id1), GP_SCM(id2)))
1387         {U_NEXT;}
1388       else
1389         return (SCM) 0;
1390     }
1391     
1392   SCM scm1 = GP_SCM(id1);
1393   SCM scm2 = GP_SCM(id2);
1394
1395  scm_check: 
1396   if(SCM_I_IS_VECTOR(scm1) && SCM_I_IS_VECTOR(scm2))
1397     {
1398       int n = SCM_I_VECTOR_LENGTH(scm1);
1399       if(n == SCM_I_VECTOR_LENGTH(scm2))
1400         {
1401           if(n == 1)
1402             {
1403               int n1 = len(SCM_SIMPLE_VECTOR_REF(scm1,0), l);
1404               int n2 = len(SCM_SIMPLE_VECTOR_REF(scm2,0), l);
1405               if(n1 >= 0 && n2 >= 0 && n1 != n2)
1406                 {
1407                   return (SCM) 0;
1408                 }
1409             }
1410           
1411           if(2*n      > 100) return (SCM) 0;
1412           if(2*n + sp > 100)
1413             {
1414               SCM ret = gp_unify(GP_GETREF(scm1), GP_GETREF(scm2), 
1415                                  raw, gp_plus_unify,l,gp,ci);   
1416               if(!ret) return (SCM) 0;
1417               U_NEXT;
1418             }
1419           
1420           int i = 0;
1421           for(; i<n ; i++)
1422             {
1423               stack[sp++] = GP_GETREF(SCM_SIMPLE_VECTOR_REF(scm1,i));
1424               stack[sp++] = GP_GETREF(SCM_SIMPLE_VECTOR_REF(scm2,i));
1425             }
1426
1427           U_NEXT;
1428         }
1429       else
1430         return (SCM) 0;
1431     }
1432
1433   gp_format2("unify> (equal/= ~a ~a)\n", scm1, scm2);
1434   if(SCM_NUMBERP(scm1))
1435     {      
1436       if(SCM_NUMBERP(scm2))
1437         {
1438           if(SCM_INEXACTP(scm1))
1439             if(SCM_INEXACTP(scm2))
1440               {
1441               num_retry:
1442               if(SCM_REALP(scm1) && SCM_REALP(scm2))
1443                 {
1444                   double r1 = scm_to_double (scm1);
1445                   double r2 = scm_to_double (scm2);
1446
1447                   if(r1 < 0 && r2 < 0)
1448                     {
1449                       r1 = -r1;
1450                       r2 = -r2;
1451                     }
1452
1453                   if (r1 < 1.000000000001 * r2 && r2 < 1.000000000001 * r1)
1454                     {U_NEXT;}
1455                   else
1456                     return
1457                       (SCM) 0;
1458                 }
1459               else
1460                 {
1461                   if(SCM_REALP(scm1) || SCM_REALP(scm2))
1462                     return (SCM) 0;
1463                   
1464                   double r1 = scm_c_real_part(scm1);
1465                   double r2 = scm_c_real_part(scm2);
1466                   double c1 = scm_c_imag_part(scm1);
1467                   double c2 = scm_c_imag_part(scm2);
1468                   if(r1 < 0 && r2 < 0)
1469                     {
1470                       r1 = -r1;
1471                       r2 = -r2;
1472                     }
1473                   if(c1 < 0 && c2 < 0)
1474                     {
1475                       c1 = -c1;
1476                       c2 = -c2;
1477                     }
1478
1479                   if (r1 < 1.000000000001 * r2 && r2 < 1.000000000001 * r1 &&
1480                       c1 < 1.000000000001 * c2 && c2 < 1.000000000001 * c1)
1481                     {U_NEXT;}
1482                   else
1483                     return (SCM) 0;
1484                 }
1485               }
1486             else
1487               if(SCM_FRACTIONP(scm2))
1488                 {
1489                   scm2 = scm_exact_to_inexact (scm2);
1490                   goto num_retry;
1491                 }
1492               else
1493                 return (SCM) 0;
1494           else
1495             if(SCM_INEXACTP(scm2))
1496               if(SCM_FRACTIONP(scm1))
1497                 {
1498                   scm1 = scm_exact_to_inexact (scm1);
1499                   goto num_retry;
1500                 }
1501               else
1502                 return (SCM) 0;
1503             else
1504               if(scm_is_true(scm_num_eq_p(scm1, scm2)))
1505                 {U_NEXT;}
1506               else
1507                 return (SCM) 0;
1508         }
1509       else
1510         return (SCM) 0;
1511     }
1512   
1513   if(scm_is_true(scm_string_p (scm1)))
1514     {
1515       if(scm_is_true(scm_procedure_p (scm2)))
1516         {
1517           scm2 = scm_procedure_name(scm2);
1518           if(scm_is_true (scm2))
1519             {
1520               scm2 = scm_symbol_to_string (scm2);
1521               goto equalp;
1522             }
1523
1524           return (SCM) 0;
1525         }
1526     }
1527   
1528   if(scm_is_true(scm_string_p (scm2)))
1529     {
1530       if(scm_is_true(scm_procedure_p (scm1)))
1531         {
1532           scm1 = scm_procedure_name(scm1);
1533           if(scm_is_true (scm1))
1534             {
1535               scm1 = scm_symbol_to_string (scm1);
1536               goto equalp;
1537             }
1538
1539           return (SCM) 0;
1540         }
1541     }
1542
1543   if(SCM_STRUCTP(scm1))
1544     {
1545       if(GP_CLOSURE_P(scm1))
1546         {
1547           if(SCM_STRUCTP(scm2) && GP_CLOSURE_P(scm2))
1548             {
1549               scm_t_bits *bits1 = SCM_STRUCT_DATA(scm1);
1550               scm_t_bits *bits2 = SCM_STRUCT_DATA(scm2);
1551               if(bits1[1] == bits2[1])
1552                 {
1553                   stack[sp++] = GP_GETREF(SCM_PACK(bits1[2])); 
1554                   stack[sp++] = GP_GETREF(SCM_PACK(bits2[2])); 
1555                   U_NEXT;
1556                 }
1557               else
1558                 {
1559                   if(scm_is_true(GP_UNREF(bits1[3])) || 
1560                      scm_is_true(GP_UNREF(bits2[3])))
1561                     {
1562                       if(scm_is_true(scm_fluid_ref(throw_closed_p)))
1563                         {
1564                           scm_call_2(closed_error_fkn, scm1, scm2);
1565                         }                 
1566                     }
1567                   return (SCM) 0;
1568                 }
1569             }
1570           else
1571             return (SCM) 0;
1572         }
1573       else 
1574         if(GP_NAMESPACE_P(scm1))
1575           {
1576             if(!gp_plus_unify)
1577               {
1578                 scm_t_bits *bits1 = SCM_STRUCT_DATA(scm1);
1579                 scm1 = SCM_PACK(bits1[0]);
1580               goto scm_check;
1581             }
1582             else
1583               {
1584                 SCM s = gp_make_s(ci,l);
1585                 SCM bang = SCM_BOOL_T;                                  
1586                 if(!gp_plus_unify)                                      
1587                   {                                                     
1588                     bang = SCM_BOOL_F;                                  
1589                   }                                                     
1590
1591                 s = scm_call_4(namespace_fkn,s,scm1,scm2,bang);
1592                 if(scm_is_false(s))
1593                   return (SCM) 0;
1594
1595                 {
1596                   SCM ll = SCM_CDR(s);
1597                   if(vlist_p(ll))
1598                     {
1599                       l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(ll,0))));
1600                       l[2] = SCM_PACK(my_scm_to_int(S(ll,1)));
1601                     } 
1602                   else
1603                     l[0] = ll;
1604                 }
1605                 
1606                 U_NEXT;
1607               }
1608           }
1609     }
1610
1611   
1612   if(SCM_STRUCTP(scm2))
1613     {
1614       if(GP_NAMESPACE_P(scm2))
1615           {
1616             if(!gp_plus_unify)
1617               {
1618                 scm_t_bits *bits1 = SCM_STRUCT_DATA(scm1);
1619                 scm1 = SCM_PACK(bits1[0]);
1620                 goto scm_check;
1621               }
1622             else
1623               {
1624                 SCM s = gp_make_s(ci,l);
1625                 s = scm_call_3(namespace_fkn,s,scm2,scm1);
1626                 if(scm_is_false(s))
1627                   return (SCM) 0;
1628
1629                 {
1630                   SCM ll = SCM_CDR(s);
1631                   if(vlist_p(ll))
1632                     {
1633                       l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(ll,0))));
1634                       l[2] = SCM_PACK(my_scm_to_int(S(ll,1)));
1635                     } 
1636                   else
1637                     l[0] = ll;
1638                 }
1639           
1640                 U_NEXT;
1641               }
1642           }
1643     }
1644
1645   
1646   if(SCM_FLUID_P(scm1))
1647     {
1648       if(SCM_FLUID_P(scm2))
1649         {
1650           scm1 = scm_fluid_ref(scm1);
1651           scm2 = scm_fluid_ref(scm2);
1652           goto  scm_check;
1653         }
1654       else
1655         return (SCM) 0;
1656     }
1657
1658  equalp:
1659   if(scm_is_true(scm_equal_p(scm1, scm2)))
1660     {U_NEXT;}
1661   else
1662     return (SCM) 0;
1663  
1664  unbound1: 
1665   gp_debug0("unify> unbound1\n");
1666   if(!raw && GP_CONS(id2) && gp_recurent(id1,id2,l))  return (SCM) 0;    
1667   gp_lookup_l(id2,id2,l);
1668   gp_set_ref_l(id1,GP_UNREF(id2),l,gp);
1669   U_NEXT;
1670
1671  unbound2: 
1672   gp_debug0("unify> unbound2\n");
1673   if(!raw && GP_CONS(id1) && gp_recurent(id2,id1,l)) return (SCM) 0;    
1674   gp_lookup_l(id1,id1,l);
1675   gp_set_ref_l(id2,GP_UNREF(id1),l,gp);
1676   U_NEXT;
1677
1678  u00:
1679   gp_debug0("unify> looked up with u00\n");
1680
1681   //conses!!
1682 #define DO_CONS2                                        \
1683   {                                                     \
1684     gp_debug0("unify> cons\n");                         \
1685     if(SCM_UNLIKELY(sp >= 100))                                         \
1686       {                                                                 \
1687         SCM ret = gp_unify(QCAR(id1),QCAR(id2),raw, gp_plus_unify, l, gp, ci); \
1688         if(!ret)                                                          \
1689           return (SCM) 0;                                               \
1690         id1 = QCDR(id1);                                                \
1691         id2 = QCDR(id2);                                                \
1692         goto retry;                                                     \
1693       }                                                                 \
1694     else                                                                \
1695       {                                                 \
1696         stack[sp++] = QCDR(id1);                        \
1697         stack[sp++] = QCDR(id2);                        \
1698         id1 = QCAR(id1);                                \
1699         id2 = QCAR(id2);                                \
1700         goto retry;                                     \
1701       }                                                 \
1702   }
1703
1704
1705   if(QCONSP(id1))
1706     {
1707       if(QCONSP(id2))
1708         {
1709           //printf("scm cons unify\n");
1710         uu00:
1711           DO_CONS2;
1712         }
1713       else
1714         {
1715           DO_NAMESPACE(scm2, id2, id1);
1716           return (SCM) 0;
1717         }
1718     }
1719
1720   if(QCONSP(id2)) 
1721     {
1722       DO_NAMESPACE(scm2, id1, id2);
1723       return (SCM) 0;
1724     }
1725   
1726   scm1 = GP_UNREF(id1);
1727   scm2 = GP_UNREF(id2);
1728   goto scm_check;
1729   
1730  u01:
1731   {
1732     SCM *x;
1733     gp_debug0("unify> looked up with u01>\n");
1734     x = id1;
1735     id1 = id2;
1736     id2 = x;
1737   }
1738
1739  u10:
1740   gp_debug0("unify> looked up with u10>\n");
1741   if(GP_UNBOUND(id1)) 
1742     {
1743       DO_NAMESPACE(scm2, id2, id1);
1744       goto  unbound_10;
1745     }
1746
1747   //conses!!
1748 #define DO_CONS3                                        \
1749   {                                                     \
1750     gp_debug0("unify> cons\n");                         \
1751     if(SCM_UNLIKELY(sp >= 18))                          \
1752       {                                                 \
1753         SCM ret = gp_unify(GP_CAR(id1), QCAR(id2)               \
1754                            ,raw, gp_plus_unify, l, gp, ci);        \
1755         if(!ret)  return (SCM) 0;                               \
1756         id1 = GP_CDR(id1);                                      \
1757         id2 = QCDR(id2);                                \
1758         goto retry;                                     \
1759       }                                                 \
1760     else                                                \
1761       {                                                 \
1762         stack[sp++] = GP_CDR(id1);                      \
1763         stack[sp++] = QCDR(id2);                        \
1764         id1 = GP_CAR(id1);                              \
1765         id2 = QCAR(id2);                                \
1766         goto retry;                                     \
1767       }                                                 \
1768   }
1769
1770
1771   if(GP_CONS(id1))
1772     {
1773       if(QCONSP(id2))
1774         {
1775           DO_CONS3;
1776         }
1777       else
1778         {
1779           DO_NAMESPACE(scm2, id2, id1);
1780           return (SCM) 0;
1781         }
1782     }
1783   if(QCONSP(id2)) 
1784     {
1785       DO_NAMESPACE(scm2, id1, id2);
1786       return (SCM) 0;
1787     }
1788
1789   
1790   if(GP_EQ(id1))
1791     {
1792       if(scm_is_eq(GP_SCM(id1),GP_UNREF(id2)))
1793         {U_NEXT;}
1794       else
1795         return (SCM) 0;
1796     }
1797
1798   scm1 = GP_SCM(id1);
1799   scm2 = GP_UNREF(id2);
1800   goto scm_check;
1801   
1802  unbound_10: 
1803   gp_debug0("unify> unbound1\n");
1804   if(!raw && (QCONSP(id2) || SCM_I_IS_VECTOR(GP_UNREF(id2)))
1805      && gp_recurent(id1,id2,l)) return (SCM) 0;    
1806   if(GP(GP_UNREF(id2))) 
1807     scm_misc_error ("unify 01 / 10 error", "unify variable at 0 place", 
1808                     scm_list_1 (GP_UNREF(id2)));
1809   if(gp_plus_unify)
1810     {
1811       gp_set_val_l(id1,GP_UNREF(id2),l,gp);
1812       U_NEXT;
1813     }
1814   return (SCM) 0;
1815 }
1816
1817 int _gp_unify(SCM **spp, int nargs, SCM *cl, SCM *max)
1818 {
1819   SCM ci, *sp, s,v1,v2,*vv1, *vv2, ret, l[3], ggp, old, oldi;
1820   struct gp_stack *gp;
1821   
1822   sp = *spp;
1823   s  = sp[0];
1824   v2 = sp[-1];
1825   v1 = sp[-2];
1826
1827   if(SCM_UNLIKELY(nargs != 3))
1828     scm_misc_error("gp-unify!","wrong number of arguments", SCM_EOL);
1829
1830   UNPACK_ALL(ci,l[0],ggp,gp,s,"failed to unpack in gp_gp_unify");
1831
1832   old  = l[0];
1833
1834   if(vlist_p(l[0]))
1835     {
1836       l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(l[0],0))));
1837       l[2] = SCM_PACK(my_scm_to_int(S(l[0],1)));
1838       oldi = l[2];
1839     }
1840   else
1841     oldi = SCM_BOOL_F;
1842
1843   gp_debus0("gp-unify!>\n");
1844   vv1 = UN_GP(v1);
1845   vv2 = UN_GP(v2);
1846   ret = gp_unify(vv1,vv2,0,1,l,gp,ci);
1847
1848   gp_debus0("/gp-unify!>\n");
1849   if(ret)
1850     {
1851       if(vlist_p(l[0]) && oldi != l[2])
1852          l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
1853
1854       PACK_ALL(ci,old,l[0],ggp,s);
1855       sp[-3] = s;
1856       *spp = sp - 3;
1857       return -1;
1858     }
1859   
1860   sp[-3] = SCM_BOOL_F;
1861   *spp = sp - 3;
1862   return -1;  
1863 }
1864
1865 SCM_DEFINE(gp_gp_unify,"gp-unify!",3,0,0,(SCM v1, SCM v2, SCM s),
1866            "unifies two gp variables")
1867 #define FUNC_NAME s_gp_gp_unify
1868 {
1869   SCM ci, *vv1, *vv2, ret, l[3], ggp, old, oldi;
1870   struct gp_stack *gp;
1871   UNPACK_ALL(ci, (l[0]),ggp,gp,s,"failed to unpack in gp_gp_unify");
1872   gp_debus0("gp-unify!>\n");
1873
1874   vv1  = UN_GP(v1);
1875   vv2  = UN_GP(v2);
1876   old  = l[0];
1877  
1878   if(vlist_p(l[0]))
1879     {
1880       l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(l[0],0))));
1881       l[2] = SCM_PACK(my_scm_to_int(S(l[0],1)));
1882       oldi = l[2];
1883     }
1884   else
1885     oldi = SCM_BOOL_F;
1886
1887   ret = gp_unify(vv1,vv2,0,1,l,gp,ci);
1888   gp_debus0("/gp-unify!>\n");
1889
1890   if(ret)
1891     {
1892       if(vlist_p(l[0]) && oldi != l[2])
1893          l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
1894       PACK_ALL(ci, old, l[0], ggp,s);
1895
1896       return s;
1897     }
1898   return SCM_BOOL_F;
1899 }
1900 #undef FUNC_NAME
1901 //#define DB(X) 
1902
1903 int _gp_unify_raw(SCM **spp, int nargs, SCM *cl, SCM *max)
1904 {
1905   SCM ci, *sp, s,v1,v2,*vv1, *vv2, ret, l[3], ggp, old, oldi;
1906   struct gp_stack *gp;
1907   
1908   sp = *spp;
1909   s  = sp[0];
1910   v2 = sp[-1];
1911   v1 = sp[-2];
1912
1913   if(SCM_UNLIKELY(nargs != 3))
1914     scm_misc_error("gp-unify-raw!","wrong number of arguments", SCM_EOL);
1915   
1916   UNPACK_ALL(ci, l[0],ggp,gp,s,"failed to unpack in gp_gp_unify");
1917
1918   old  = l[0];
1919
1920   if(vlist_p(l[0]))
1921     {
1922       l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(l[0],0))));
1923       l[2] = SCM_PACK(my_scm_to_int(S(l[0],1)));
1924       oldi = l[2];
1925     }
1926   else
1927     oldi = SCM_BOOL_F;
1928
1929   gp_debus0("gp-unify!>\n");
1930   vv1 = UN_GP(v1);
1931   vv2 = UN_GP(v2);
1932   ret = gp_unify(vv1,vv2,1,1,l,gp,ci);
1933
1934   gp_debus0("/gp-unify!>\n");
1935   if(ret)
1936     {
1937       if(vlist_p(l[0]) && oldi != l[2])
1938          l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
1939
1940       PACK_ALL(ci, old, l[0], ggp,s);
1941       sp[-3] = s;
1942       *spp = sp - 3;
1943       return -1;
1944     }
1945   
1946   sp[-3] = SCM_BOOL_F;
1947   *spp = sp - 3;
1948   return -1;  
1949 }
1950
1951 SCM_DEFINE(gp_gp_unify_raw,"gp-unify-raw!",3,0,0,(SCM v1, SCM v2, SCM s),
1952            "unifies two gp variables")
1953 #define FUNC_NAME s_gp_gp_unify
1954 {
1955   SCM ci,*vv1, *vv2, ret, l[3], ggp, old, oldi;
1956   struct gp_stack *gp;
1957   UNPACK_ALL(ci,l[0],ggp, gp,s,"failed to unpack in gp_gp_unify_raw");
1958   gp_debus0("gp-unify-raw!>\n");
1959
1960   old  = l[0];
1961
1962   vv1 = UN_GP(v1);
1963   vv2 = UN_GP(v2);
1964   if(vlist_p(l[0]))
1965     {
1966       l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(l[0],0))));
1967       l[2] = SCM_PACK(my_scm_to_int(S(l[0],1)));
1968       oldi = l[2];
1969     }
1970   else
1971     oldi = SCM_BOOL_F;
1972
1973   ret =  gp_unify(vv1,vv2,1,1,l,gp,ci);
1974   gp_debus0("/gp-unify-raw!>\n");
1975   if(ret)
1976     {
1977       if(vlist_p(l[0]) && oldi != l[2])
1978          l[0] = make_vlist(S(l[0],0),SCM_UNPACK(l[2]));
1979
1980       PACK_ALL(ci,old,l[0],ggp,s);
1981       return s;
1982     }
1983   return SCM_BOOL_F;
1984 }
1985 #undef FUNC_NAME
1986
1987 SCM_DEFINE(gp_next_budy, "gp-budy", 1, 0, 0, (SCM x),
1988            "Assumes that v1 and v2 is allocated consecutively returns v2 when feeded by v1")
1989 #define FUNC_NAME s_gp_next_budy
1990 {
1991   SCM *id;
1992   if(!GP(x)) goto not_a_budy_error;
1993   id = UN_GP(x);
1994   return SCM_PACK(GP_BUDY(id));
1995   
1996  not_a_budy_error:
1997   scm_misc_error ("budy error", "cannot budy a non GP element", 
1998                   scm_list_1 (x));              \
1999   return SCM_BOOL_F;
2000 }
2001
2002 #undef FUNC_NAME
2003
2004 int _gp_mkvar(SCM **spp, int nargs, SCM *cl, SCM *max)
2005 {
2006   SCM *sp = *spp;
2007   if(nargs != 1)
2008     scm_misc_error("gp-var!","wrong number of arguments", SCM_EOL);
2009   
2010   sp[-1] = GP_IT(gp_mk_var(sp[0]));
2011  
2012   *spp = sp - 1;
2013   return -1;
2014 }
2015
2016 SCM_DEFINE(gp_mkvar, "gp-var!", 1, 0, 0, (SCM s),
2017            "makes a unbounded gp variable")
2018 #define FUNC_NAME s_gp_mkvar
2019 {
2020   return GP_IT(gp_mk_var(s));
2021 }
2022 #undef FUNC_NAME
2023
2024 SCM_DEFINE(gp_varp,"gp-var?",2,0,0,(SCM x, SCM s),
2025            "Test for an unbound variable.")
2026 #define FUNC_NAME s_gp_varp
2027 {  
2028   SCM *id;
2029   if(GP(x))
2030     {
2031       id = GP_GETREF(gp_gp_lookup(x, s));
2032       return (GP_STAR(id) && GP_UNBOUND(id)) ? SCM_BOOL_T : SCM_BOOL_F;
2033     }
2034   return SCM_BOOL_F;
2035 }
2036 #undef FUNC_NAME
2037
2038
2039 SCM_DEFINE(gp_atomicp,"gp-atomic?",2,0,0,(SCM x, SCM s),
2040            "Test for a atomic gp")
2041 #define FUNC_NAME s_gp_atomicp
2042 {
2043   SCM *id;
2044   if(GP(x))
2045     {
2046       id = GP_GETREF(gp_gp_lookup(x,s));
2047       if(GP_STAR(id))
2048         return (GP_VAL(id) && !SCM_CONSP(GP_SCM(id)))
2049           ? SCM_BOOL_T : SCM_BOOL_F;
2050       
2051       return SCM_CONSP(GP_UNREF(id)) ? SCM_BOOL_F : SCM_BOOL_T;
2052     }
2053   return scm_is_pair(x) ? SCM_BOOL_F : SCM_BOOL_T;
2054 }
2055 #undef FUNC_NAME
2056
2057 static inline void gp_unwind0(SCM *ci, SCM *sim, SCM *cs, struct gp_stack *gp);
2058 void gp_unwind_dynstack(struct gp_stack *gp, scm_t_bits dyn_n);
2059
2060 SCM_DEFINE(gp_clear, "gp-clear", 1, 0, 0, (SCM s),
2061            "resets the unifyier stacks")
2062 #define FUNC_NAME s_gp_clear
2063 {
2064   struct gp_stack *gp = get_gp();
2065   gp_debug0("clear\n");
2066   gp_unwind0(gp->gp_cstack + 4,gp->gp_stack, gp->gp_cons_stack, gp);
2067   gp_unwind_dynstack(gp, 2);
2068   gp->rguards  = SCM_EOL;
2069   gp->dynstack = SCM_EOL;
2070   gp->handlers = SCM_EOL;
2071   gp->_logical_ = 0;
2072   return SCM_BOOL_T;
2073 }
2074 #undef FUNC_NAME
2075
2076
2077
2078 SCM_DEFINE(gp_gp, "gp?", 1, 0, 0, (SCM scm), "")
2079 #define FUNC_NAME s_gp_gp
2080 {
2081   return GP(scm) ? SCM_BOOL_T : SCM_BOOL_F;
2082 }
2083 #undef FUNC_NAME
2084
2085
2086 static inline SCM ggp_set(SCM var, SCM val, SCM s)
2087 {
2088   SCM *id,l,ret,ggp,ci;
2089   struct gp_stack *gp;
2090   UNPACK_ALL(ci,l,ggp,gp,s,"failed to unpack s in ggp_set");
2091
2092   if(GP(var))
2093     {
2094       id = GP_GETREF(var);
2095
2096       id = gp_lookup2(id,l);
2097       
2098       if(GP_STAR(id))
2099         {
2100           if(GP(val))
2101             {
2102               ret = gp_set_ref(id,GP_UNREF(gp_gp_lookup(val,s)),l,gp);
2103               PACK_ALL(ci, l ,ret, ggp, s);
2104               return s;
2105             }
2106           else
2107             {
2108               ret = gp_set_val(id,val, l, gp);
2109               PACK_ALL(ci, l ,ret, ggp, s);
2110               return s;
2111             }
2112         }
2113     }    
2114   scm_misc_error("gp-set!","wrong type of the variable to set",SCM_EOL);
2115   return SCM_BOOL_F;
2116 }
2117
2118
2119
2120 int _gp_newframe(SCM **spp, int nargs, SCM *cl, SCM *max)
2121 {
2122   SCM *sp = *spp;
2123   if(nargs != 1)
2124     scm_misc_error("gp-newframe","wrong number of arguments", SCM_EOL);
2125   
2126   sp[-1] = gp_newframe(sp[0]);
2127    
2128   *spp = sp - 1;
2129   return -1;
2130 }
2131
2132 SCM_DEFINE (gp_gp_newframe, "gp-newframe",1,0,0,(SCM s),
2133             "Created a prolog frame to backtrack from")
2134 #define FUNC_NAME s_gp_gp_newframe
2135 {
2136   return gp_newframe(s);
2137 }
2138 #undef FUNC_NAME
2139
2140 SCM_DEFINE(gp_set, "gp-set!", 3, 0, 0, (SCM var, SCM val, SCM s), 
2141            "set gp var var to val")
2142 #define FUNC_NAME s_gp_set
2143 {
2144   return ggp_set(var,val,s);
2145 }
2146 #undef FUNC_NAME
2147
2148
2149 SCM_DEFINE(gp_print, "gp-print", 1, 0, 0, (SCM pr), 
2150            "print a val")
2151 #define FUNC_NAME s_gp_print
2152 {
2153   if(GP(pr))
2154     printf("GP_SCM> %p,%p\n",
2155            (void *) SCM_UNPACK(*GP_GETREF(pr)),
2156            (void *) SCM_UNPACK(*(GP_GETREF(pr) + 1)));
2157   else
2158     printf("NO GP!\n");
2159
2160   return SCM_BOOL_T;
2161 }
2162 #undef FUNC_NAME
2163
2164 SCM_DEFINE(gp_print_stack, "gp-print-stack", 1, 0, 0, (SCM s), 
2165            "print info about supplied gp stack")
2166 #define FUNC_NAME s_gp_print
2167 {
2168   SCM *i;
2169   struct gp_stack *gp = get_gp();
2170   printf("\nci: %ld\nsi: %ld\ncs: %ld\nlogical: %d\n"
2171          ,gp->gp_ci - gp->gp_cstack
2172          ,gp->gp_si - gp->gp_stack
2173          ,gp->gp_cs - gp->gp_cons_stack
2174          ,gp->_logical_);  
2175   for(i = gp->gp_cstack; i < gp->gp_ci; i++)
2176     {
2177       printf("%ld c %lx\n",i - gp->gp_cstack,SCM_UNPACK(*i));
2178     }
2179
2180   for(i = gp->gp_stack; i < gp->gp_si; i++)
2181     {
2182       printf("%ld v %lx\n",i - gp->gp_stack,SCM_UNPACK(*i));
2183     }
2184   return SCM_UNSPECIFIED;
2185 }
2186 #undef FUNC_NAME
2187
2188 SCM_DEFINE(gp_ref_set, "gp-ref-set!", 3, 0, 0, (SCM var, SCM val, SCM s), 
2189            "set gp var reference to val")
2190 #define FUNC_NAME s_gp_ref_set
2191 {
2192   SCM *id,l;
2193   struct gp_stack *gp;
2194   if(GP(var))
2195     {
2196       if(GP(val))
2197         {
2198           UNPACK_S(l,gp,s,"cannot unpack s in gp_ref_set");
2199           return gp_set_ref(GP_GETREF(var),val,l,gp);
2200         }
2201       else
2202         {
2203           UNPACK_S(l,gp,s,"cannot unpack s in gp_ref_set");
2204           id = gp_lookup(GP_GETREF(var), l);
2205           return gp_set_val(id,val,l,gp);
2206         }
2207       return SCM_BOOL_T;
2208     }
2209   scm_misc_error("gp-ref-set!", "wrong type to set", SCM_EOL);
2210   return SCM_BOOL_F;
2211 }
2212 #undef FUNC_NAME
2213
2214 /* new api so that pure ffi will work */
2215 SCM_DEFINE(gp_cons_bang, "gp-cons!", 3, 0, 0, (SCM car, SCM cdr, SCM s), 
2216            "crates a prolog variable cons pair")
2217 #define FUNC_NAME s_gp_cons_bang
2218 {
2219   SCM *cons;
2220   SCM *id;
2221   struct gp_stack *gp = get_gp();
2222   
2223   if(gp->_logical_) return scm_cons(car,cdr);
2224
2225   gp_debus0("gp-cons>\n");
2226   cons = GP_GETREF(gp_mk_cons(s));
2227   DS(smob2scm(car, s));
2228   DS(smob2scm(cdr, s));
2229   SCM EOL = SCM_EOL;
2230   if(GP(car))    
2231     { 
2232       SCM *idd = GP_GETREF(car);
2233       gp_lookup_l(id, idd, &EOL);      
2234       gp_set_ref(GP_CAR(cons),GP_UNREF(id), SCM_EOL, gp);
2235     }
2236   else
2237     {
2238       gp_debus0("atom car>\n");
2239       gp_set_val(GP_CAR(cons),car, EOL, gp);
2240     }
2241
2242   if(GP(cdr))    
2243     { 
2244       SCM *idd = GP_GETREF(cdr);
2245       gp_lookup_l(id, idd, &EOL);
2246       gp_set_ref(GP_CDR(cons),GP_UNREF(id), EOL, gp);
2247     }
2248   else
2249     {
2250       gp_debus0("atom cdr>\n");
2251       gp_set_val(GP_CDR(cons),cdr, EOL, gp);
2252     }
2253
2254   return GP_UNREF(cons);
2255 }
2256 #undef FUNC_NAME
2257
2258
2259 int _gp_pair_bang(SCM **spp, int nargs, SCM *cl, SCM *max)
2260 {
2261   SCM *sp = *spp;
2262   if(nargs != 2)
2263     scm_misc_error("gp-unwind","wrong number of arguments", SCM_EOL);
2264   
2265   sp[-2] = gp_pair_bang(sp[-1],sp[0]);
2266  
2267   *spp = sp - 2;
2268   return -1;
2269 }
2270
2271
2272 SCM_DEFINE(gp_pair_bang, "gp-pair!?", 2, 0, 0, (SCM x, SCM s), 
2273            "checks for a prolog or scheme pair and if a prolog variable creates a cons")
2274 #define FUNC_NAME s_gp_pair_bang
2275 {  
2276   SCM * y,l,ret,ggp,ci;
2277   struct gp_stack *gp;
2278
2279   UNPACK_ALL(ci, l,ggp,gp,s,"failed to unpack s in gp_pair_bang");
2280   gp_debus0("gp-pair!?>\n");
2281  retry:
2282   if(GP(x))
2283     x = gp_gp_lookup(x,s);
2284   if(GP(x))
2285     {
2286       if(SCM_UNLIKELY(gp->_logical_))
2287         {
2288           SCM cons = scm_cons(make_logical(),make_logical());
2289           SCM lnew = logical_add2(x, cons, l);
2290           PACK_ALL(ci,l,lnew,ggp,s);
2291           return s;
2292         }
2293       else
2294         {
2295           y = GP_GETREF(x);
2296           if(GP_UNBOUND(y))
2297             {
2298               SCM *cons = GP_GETREF(gp_mk_cons(s));
2299               ret = gp_set_ref(y,GP_UNREF(cons),l,gp);
2300               PACK_ALL(ci,l,ret,ggp,s);
2301               return s;
2302             }
2303           else
2304             {
2305               if(GP_CONS(y))
2306                 {
2307                   return s;
2308                 }
2309             }      
2310         }
2311       
2312       return SCM_BOOL_F;
2313     }
2314
2315   if(SCM_STRUCTP(x) && GP_NAMESPACE_P(x))
2316     {
2317       x = gp_struct_ref(x,0);
2318       goto retry;
2319     }
2320
2321   return SCM_CONSP(x) ? s : SCM_BOOL_F;
2322 }
2323 #undef FUNC_NAME
2324
2325
2326 int _gp_pair(SCM **spp, int nargs, SCM *cl, SCM *max)
2327 {
2328   SCM *sp = *spp;
2329   if(nargs != 2)
2330     scm_misc_error("gp-pair?","wrong number of arguments", SCM_EOL);
2331   
2332   sp[-2] = gp_pair(sp[-1],sp[0]);
2333  
2334   *spp = sp - 2;
2335   return -1;
2336 }
2337
2338 SCM_DEFINE(gp_pair, "gp-pair?", 2, 0, 0, (SCM x, SCM s), 
2339            "checks for a prolog pair or scheme pair")
2340 #define FUNC_NAME s_gp_pair
2341 {
2342   gp_debus0("gp-pair?>\n");
2343
2344  retry:
2345   if(GP(x))
2346     x = gp_gp_lookup(x,s);
2347
2348   if(GP(x))
2349     {
2350       //printf("pair gp-addr %x, val %x\n",SCM_UNPACK(x),SCM_UNPACK(*GP_GETREF(x)));
2351       if(GP_CONS(GP_GETREF(x)))
2352         {
2353           return s;
2354         }
2355       return SCM_BOOL_F;
2356     }
2357
2358   if(SCM_STRUCTP(x) && GP_NAMESPACE_P(x))
2359     {
2360       x = gp_struct_ref(x,0);
2361       goto retry;
2362     }
2363
2364   return SCM_CONSP(x) ? s : SCM_BOOL_F;
2365 }
2366 #undef FUNC_NAME
2367
2368 int _gp_null(SCM **spp, int nargs, SCM *cl, SCM *max)
2369 {
2370   SCM *sp = *spp;
2371   if(nargs != 2)
2372     scm_misc_error("gp-null?","wrong number of arguments", SCM_EOL);
2373   
2374   sp[-2] = gp_null(sp[-1],sp[0]);
2375  
2376   *spp = sp - 2;
2377   return -1;
2378 }
2379
2380 SCM_DEFINE(gp_null, "gp-null?", 2, 0, 0, (SCM x, SCM s), 
2381            "checks for a prolog pair or scheme pair")
2382 #define FUNC_NAME s_gp_null
2383 {
2384   gp_debus0("gp-null?>\n");
2385
2386  retry:
2387   if(GP(x))
2388     x = gp_gp_lookup(x,s);
2389
2390   if(GP(x))
2391     {
2392       SCM *id = GP_GETREF(x);
2393       if(GP_VAL(id))
2394         {
2395           return SCM_NULLP(GP_SCM(id)) ? s : SCM_BOOL_F;
2396         }
2397       return SCM_BOOL_F;
2398     }
2399
2400   if(SCM_STRUCTP(x) && GP_NAMESPACE_P(x))
2401     {
2402       x = gp_struct_ref(x,0);
2403       goto retry;
2404     }
2405
2406   return SCM_NULLP(x) ? s : SCM_BOOL_F;
2407 }
2408 #undef FUNC_NAME
2409
2410 int _gp_null_bang(SCM **spp, int nargs, SCM *cl, SCM *max)
2411 {
2412   SCM *sp = *spp;
2413   if(nargs != 2)
2414     scm_misc_error("gp_null!?","wrong number of arguments", SCM_EOL);
2415   
2416   sp[-2] = gp_null_bang(sp[-1],sp[0]);
2417  
2418   *spp = sp - 2;
2419   return -1;
2420 }
2421
2422 SCM_DEFINE(gp_null_bang, "gp-null!?", 2, 0, 0, (SCM x, SCM s), 
2423            "checks for a prolog pair or scheme pair")
2424 #define FUNC_NAME s_gp_null_bang
2425 {
2426   SCM * y,l,ggp,ret,ci;
2427   struct gp_stack *gp;
2428
2429   UNPACK_ALL(ci,l,ggp,gp,s,"failed to unpack s in gp_null_bang");
2430   gp_debus0("gp-null!?>\n");
2431
2432  retry:
2433   if(GP(x))
2434     x = gp_gp_lookup(x,s);
2435
2436   if(GP(x))
2437     {
2438       y = GP_GETREF(x);
2439       if (GP_UNBOUND(y))
2440         {
2441           ret = gp_set_eq(y,SCM_EOL,l,gp);
2442           PACK_ALL(ci,l,ret,ggp,s);
2443           return s;
2444         }
2445       else 
2446         if(GP_VAL(y))
2447           {
2448             return SCM_NULLP(GP_SCM(y)) ? s : SCM_BOOL_F;
2449           }
2450       return SCM_BOOL_F;
2451     }
2452   
2453   if(SCM_STRUCTP(x) && GP_NAMESPACE_P(x))
2454     {
2455       x = gp_struct_ref(x,0);
2456       goto retry;
2457     }
2458
2459   return SCM_NULLP(x) ? s : SCM_BOOL_F;
2460 }
2461 #undef FUNC_NAME
2462
2463 int _gp_lookup(SCM **spp, int nargs, SCM *cl, SCM *max)
2464 {
2465   SCM *sp = *spp;
2466   if(nargs != 2)
2467     scm_misc_error("gp-lookup","wrong number of arguments", SCM_EOL);
2468   
2469   sp[-2] = gp_gp_lookup(sp[-1],sp[0]);
2470  
2471   *spp = sp - 2;
2472   return -1;
2473 }
2474
2475
2476 SCM_DEFINE(gp_gp_lookup, "gp-lookup", 2, 0, 0, (SCM x, SCM s), 
2477            "lookup a  chain fro a prolog variable")
2478 #define FUNC_NAME s_gp_gp_null_bang
2479 {
2480   SCM * id,l;
2481
2482   UNPACK_S0(l,s,"failed to unpack s in gp_gp_lookup");
2483   if(GP(x))
2484     {
2485       //printf("lookup> gp\n");
2486       gp_debug0("gp-lookup\n");
2487       id = gp_lookup(GP_GETREF(x),l);
2488       if(!GP_STAR(id)) return GP_UNREF(id);
2489       if(GP_UNBOUND(id) || GP_CONS(id))
2490         return GP_UNREF(id);
2491       else
2492         return GP_SCM(id);
2493     }
2494   //printf("lookup> scm\n");
2495   return x;
2496 }
2497
2498
2499 SCM_DEFINE(gp_gp_lookup_clean, "gp-lookup-clean", 2, 0, 0, (SCM x, SCM s), 
2500            "lookup a chain from a prolog variable")
2501 #define FUNC_NAME s_gp_gp_null_bang
2502 {
2503   SCM *id,*pt,l,out,ggp;
2504   scm_t_bits ix;
2505   struct gp_stack *gp;
2506   int i; 
2507   UNPACK_ALL0(l,ggp,gp,s,"failed to unpack in gp_gp_lookup_clean");
2508   if(GP(x))
2509     {
2510       //printf("lookup> gp\n");
2511       gp_debug0("gp-lookup\n");
2512       id = gp_lookup(GP_GETREF(x),l);
2513       if(!GP_STAR(id))
2514         {
2515           out = GP_UNREF(id);
2516         }
2517       else if(GP_UNBOUND(id) || GP_CONS(id))
2518         {
2519           out = GP_UNREF(id);
2520         }
2521       else
2522         {
2523           out = GP_SCM(id);
2524         }
2525       //printf("test cplx\n");
2526       ix = (scm_t_bits) GP_GETREF(x);
2527       if(!IS_CPLX(id))
2528         {
2529           //printf("not cplx\n");
2530           for(pt = gp->gp_ci - 1, i = 0              ; 
2531               i < 10                             && 
2532               pt >= gp->gp_cstack                && 
2533                 (GP(*pt) || (2 | SCM_UNPACK(*pt)))   ;
2534               pt--,i++)
2535             {
2536               scm_t_bits ipt = SCM_UNPACK(*pt);
2537               //printf("%d\n",i);
2538               if (ipt == ix)
2539               {
2540                 for(;pt<gp->gp_ci - 1;pt++)
2541                   {
2542                     pt[0] = pt[1];
2543                   }
2544                 gp->gp_ci--;
2545                 return scm_values(scm_list_2(out,s));
2546               }
2547             }
2548           {
2549             if(SCM_CONSP(l))
2550               if(SCM_CAAR(l) == x)
2551                 return 
2552                   scm_values(
2553                              scm_list_2(out,
2554                                         scm_cons(ggp, SCM_CDR(l))));
2555           }
2556         }     
2557     }
2558   //printf("lookup> scm\n");
2559   return scm_values(scm_list_2(x,s));
2560 }
2561
2562 #undef FUNC_NAME
2563
2564 int _gp_m_unify(SCM **spp, int nargs, SCM *cl, SCM *max)
2565 {
2566   SCM *sp, s,v1,v2,*vv1, *vv2, ret, l[3], ggp, ci;
2567   struct gp_stack *gp;
2568   
2569   sp = *spp;
2570   s  = sp[0];
2571   v2 = sp[-1];
2572   v1 = sp[-2];
2573
2574   if(SCM_UNLIKELY(nargs != 3))
2575     scm_misc_error("gp-m-unify","wrong number of arguments", SCM_EOL);
2576   
2577   UNPACK_ALL(ci,l[0],ggp,gp,s,"failed to unpack in gp_gp_unify");
2578   if(vlist_p(l[0]))
2579     {
2580       l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(l[0],0))));
2581       l[2] = SCM_PACK(my_scm_to_int(S(l[0],1)));
2582     }
2583
2584   gp_debus0("gp-unify!>\n");
2585   vv1 = UN_GP(v1);
2586   vv2 = UN_GP(v2);
2587   ret = gp_unify(vv1,vv2,1,0,l,gp,ci);
2588   gp_debus0("/gp-unify!>\n");
2589   if(ret)
2590     {
2591       PACK_ALL(ci,l[0],ret,ggp,s);
2592       sp[-3] = s;
2593       *spp = sp - 3;
2594       return -1;
2595     }
2596   
2597   sp[-3] = SCM_BOOL_F;
2598   *spp = sp - 3;
2599   return -1;  
2600 }
2601
2602 SCM_DEFINE(gp_m_unify, "gp-m-unify!", 3, 0, 0, (SCM x, SCM y, SCM s), 
2603            "checks for a prolog pair or scheme pair")
2604 #define FUNC_NAME s_gp_m_unify
2605 {
2606   SCM ret, l[3], ggp, ci;
2607   struct gp_stack *gp;
2608   UNPACK_ALL(ci,l[0],ggp,gp,s,"failed to unpack in gp_m_unify");
2609   if(vlist_p(l[0]))
2610     {
2611       l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(l[0],0))));
2612       l[2] = SCM_PACK(my_scm_to_int(S(l[0],1)));
2613     }
2614
2615   //Todo this is a ugly hack.
2616   ret = gp_unify(GP_GETREF(x),GP_GETREF(y),1,0,l,gp,ci);
2617   
2618   if(ret)
2619     {
2620       PACK_ALL(ci,l[0],ret,ggp,s);
2621       return s;
2622     }
2623   return SCM_BOOL_F;
2624 }
2625 #undef FUNC_NAME
2626
2627
2628 int _gp_car(SCM **spp, int nargs, SCM *cl, SCM *max)
2629 {
2630   SCM *sp = *spp;
2631   if(nargs != 2)
2632     scm_misc_error("gp-car","wrong number of arguments", SCM_EOL);
2633   
2634   sp[-2] = gp_car(sp[-1],sp[0]);
2635  
2636   *spp = sp - 2;
2637   return -1;
2638 }
2639
2640 SCM_DEFINE(gp_car, "gp-car", 2, 0, 0, (SCM x, SCM s), 
2641            "takes car a prolog pair or scheme pair")
2642 #define FUNC_NAME s_gp_car
2643 {
2644   gp_debus0("gp-car?>\n");
2645   if(GP(x))
2646     x = gp_gp_lookup(x,s);
2647
2648   if(GP(x))
2649     {
2650       return GP_UNREF(GP_CAR(GP_GETREF(x)));
2651     }
2652   else
2653     {
2654       return SCM_CAR(x);
2655     }
2656 }
2657 #undef FUNC_NAME
2658
2659 int _gp_cdr(SCM **spp, int nargs, SCM *cl, SCM *max)
2660 {
2661   SCM *sp = *spp;
2662   if(nargs != 2)
2663     scm_misc_error("gp-cdr","wrong number of arguments", SCM_EOL);
2664   
2665   sp[-2] = gp_gp_cdr(sp[-1],sp[0]);
2666  
2667   *spp = sp - 2;
2668   return -1;
2669 }
2670
2671 SCM_DEFINE(gp_gp_cdr, "gp-cdr", 2, 0, 0, (SCM x, SCM s), 
2672            "takes cdr a prolog pair or scheme pair")
2673 #define FUNC_NAME s_gp_gp_cdr
2674 {
2675   gp_debus0("gp-cdr>\n");
2676
2677   if(GP(x))
2678     x = gp_gp_lookup(x,s);
2679
2680   if(GP(x))
2681     {
2682       return GP_UNREF(GP_CDR(GP_GETREF(x)));
2683     }
2684   else
2685     return SCM_CDR(x);
2686 }
2687 #undef FUNC_NAME
2688
2689 SCM_DEFINE(gp_var_number, "gp-var-number", 2 , 0, 0, (SCM x, SCM s), 
2690            "calculates var id number")
2691 #define FUNC_NAME s_gp_gp_cdr
2692 {
2693   struct gp_stack *gp = get_gp();
2694
2695   if(GP(x))
2696     {
2697       SCM i,sid;
2698       scm_t_bits n = (scm_t_bits) GP_GETREF(x);
2699       if(n >= (scm_t_bits) gp->gp_stack && n <= (scm_t_bits) gp->gp_nns)
2700         {
2701           i   = SCM_I_MAKINUM((n - (scm_t_bits) gp->gp_stack)/16);
2702         }
2703       else
2704         i = SCM_I_MAKINUM(((unsigned long) GP_GETREF(x))/16);
2705       
2706       sid  = SCM_I_MAKINUM(GP_ID(*GP_GETREF(x)));
2707
2708       return scm_cons(sid,i);
2709     }
2710   else
2711     return scm_cons(SCM_I_MAKINUM(-1),SCM_I_MAKINUM(-1));
2712 }
2713 #undef FUNC_NAME
2714
2715 SCM gp_save_mark_sym;
2716
2717 #include "unify-undo-redo.c"
2718
2719 static SCM gp_type_mark(SCM obj)
2720 {
2721   SCM *v = GP_GETREF(obj);
2722   scm_gc_mark(v[1]);
2723   return SCM_BOOL_T;
2724 }
2725
2726 SCM unify_env_smob;
2727 scm_t_bits unify_env_smob_t;
2728
2729 SCM this_module;
2730 static int gp_printer(SCM x, SCM port, scm_print_state *spec)
2731 {
2732   scm_call_2 (scm_variable_ref  
2733               (scm_c_module_lookup 
2734                (this_module, "gp-printer")), 
2735               port, x);
2736   return 0;
2737 }
2738
2739 SCM_DEFINE(gp_soft_init, "gp-module-init", 0, 0, 0, (), 
2740            "makes sure to record current module")
2741 #define FUNC_NAME s_gp_soft_init
2742 {
2743
2744   this_module = scm_current_module ();
2745  
2746   return SCM_UNSPECIFIED;
2747 }
2748 #undef FUNC_NAME
2749
2750 SCM_DEFINE(gp_make_fluid, "gp-make-var", 0, 0, 0, (), 
2751            "makes a gp fluid variable")
2752 #define FUNC_NAME s_gp_make_fluid
2753 {
2754   SCM ret,l=SCM_BOOL_F;
2755   struct gp_stack *gp = get_gp();
2756
2757   int old = gp->_logical_;
2758   gp->_logical_ = 0;
2759   SCM_NEWSMOB(ret,GP_MK_FRAME_UNBD(gp_type),(void *)0);
2760   gp_set_unbound_bang(GP_GETREF(ret), l, gp);
2761   gp->_logical_ = old;
2762   return ret;
2763 }
2764 #undef FUNC_NAME
2765
2766
2767 SCM_DEFINE(gp_fluid_force_bang, "gp-var-set!", 3, 0, 0, 
2768            (SCM f, SCM v, SCM s), 
2769            "set! a gp fluid variable")
2770 #define FUNC_NAME s_gp_fluid_set_bang
2771 {
2772   SCM *id, l;
2773   struct gp_stack *gp;
2774   
2775   UNPACK_S(l,gp,s,"failed to unpack s in gp_fluid_set_bang");
2776   int old = gp->_logical_;
2777   gp->_logical_ = 0;
2778
2779   if(!GP(f))
2780     {
2781       gp->_logical_ = old;
2782       scm_misc_error ("gp fluid error", "variable is not a fluid, ~a", 
2783                       scm_list_1 (f));
2784     }
2785   
2786   id = gp_lookup2(GP_GETREF(f),l);
2787   if(GP(v))
2788     gp_set_ref_bang(id,v,l,gp);
2789   else
2790     gp_set_val_bang(id,v,l,gp);
2791   
2792   gp->_logical_ = old;
2793   return SCM_UNSPECIFIED;
2794 }
2795 #undef FUNC_NAME
2796
2797 SCM_DEFINE(gp_fluid_set_bang, "gp-var-set", 3, 0, 0, (SCM f, SCM v, SCM s), 
2798            "set! a gp fluid variable in a backtracked way")
2799 #define FUNC_NAME s_gp_fluid_set_bang
2800 {
2801   SCM *id, l;
2802   struct gp_stack *gp;
2803   
2804   UNPACK_S(l,gp,s,"failed to unpack s in gp_fluid_set_bang");
2805   int old = gp->_logical_;
2806   gp->_logical_ = 0;
2807
2808   if(!GP(f))
2809     {
2810       gp->_logical_ = old;
2811       scm_misc_error ("gp fluid error", "variable is not a fluid, ~a", 
2812                       scm_list_1 (f));
2813     }
2814   
2815   id = GP_GETREF(f);
2816   if(GP(v))
2817     gp_set_ref(id,v,l,gp);
2818   else
2819     gp_set_val(id,v,l,gp);
2820   
2821   gp->_logical_ = old;
2822   return SCM_UNSPECIFIED;
2823 }
2824 #undef FUNC_NAME
2825
2826 SCM_DEFINE(gp_dynwind, "gp-dynwind", 3, 0, 0, (SCM in, SCM out, SCM s), 
2827            "ad a dynwind to the action stack")
2828 #define FUNC_NAME s_gp_dynwind
2829 {
2830   gp_debug0("dynwind...");  
2831   struct gp_stack *gp = get_gp();
2832   
2833   if(scm_is_false( scm_procedure_p(in))
2834      || !(scm_is_true(scm_procedure_p(out)) || scm_is_false(out)))
2835     {
2836       scm_misc_error("gp-dynwind error",
2837         "Wrong type of argument (in, out, s)) in gp-dynwind got ~a,~a,s", 
2838         scm_list_2(in,out));
2839     }
2840   gp->gp_ci[0] = scm_cons(in,out);
2841   gp->gp_ci ++;
2842   return SCM_UNSPECIFIED;
2843 }
2844 #undef FUNC_NAME
2845
2846 SCM_DEFINE(gp_prompt, "gp-prompt", 2, 0, 0, (SCM tag, SCM lam), 
2847            "Add a prompt (fkn . tag) pair in the stack")
2848 #define FUNC_NAME s_gp_prompt
2849 {
2850   struct gp_stack *gp = get_gp();
2851   if (scm_is_false(tag) 
2852       || scm_is_true(scm_procedure_p(tag))
2853       || scm_is_false(scm_procedure_p(lam)))
2854     {
2855       scm_misc_error("gp-prompt error",
2856       "Wrong type of argument (tag, lam) in gp_prompt got ~a,~a",
2857       scm_list_2(tag,lam));
2858     }
2859
2860   gp->gp_ci[0] = scm_cons(lam,tag);
2861   gp->gp_ci ++;
2862
2863   return SCM_UNSPECIFIED;
2864 }
2865 #undef FUNC_NAME
2866
2867 SCM_DEFINE(gp_handlers_ref, "gp-handlers-ref", 0, 0, 0, (), 
2868            "Get handlers reference")
2869 #define FUNC_NAME s_gp_handlers_ref
2870 {
2871   struct gp_stack *gp = get_gp();
2872   
2873   return gp->handlers;
2874 }
2875 #undef FUNC_NAME
2876
2877 SCM_DEFINE(gp_handlers_set_x, "gp-handlers-set!", 1, 0, 0, (SCM h), 
2878            "Get handlers reference")
2879 #define FUNC_NAME s_gp_handlers_set_x
2880 {
2881   struct gp_stack *gp = get_gp();
2882   gp->handlers = h;
2883   return SCM_UNSPECIFIED;
2884 }
2885 #undef FUNC_NAME
2886
2887 /*
2888 SCM_DEFINE(gp_copy,"gp-copy",1,0,0, (SCM x),