← Back to branch summary

~burner/xsb/debianized-xsb

« back to all changes in this revision

Viewing changes to emu/cinterf.c

  • Committer: Michael R. Head
  • Date: 2006-09-06 22:11:55 UTC
  • Revision ID: burner@n23-20060906221155-7e398d23438a7ee4
Add the files from the 3.0.1 release package

Show diffs side-by-side

added added

removed removed

Lines of Context:
emu/cinterf.c
 
1
/* File:      cinterf.c
 
2
** Author(s): Jiyang Xu
 
3
** Contact:   xsb-contact@cs.sunysb.edu
 
4
** 
 
5
** Copyright (C) The Research Foundation of SUNY, 1986, 1993-1999
 
6
** Copyright (C) ECRC, Germany, 1990
 
7
** 
 
8
** XSB is free software; you can redistribute it and/or modify it under the
 
9
** terms of the GNU Library General Public License as published by the Free
 
10
** Software Foundation; either version 2 of the License, or (at your option)
 
11
** any later version.
 
12
** 
 
13
** XSB is distributed in the hope that it will be useful, but WITHOUT ANY
 
14
** WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
 
15
** FOR A PARTICULAR PURPOSE.  See the GNU Library General Public License for
 
16
** more details.
 
17
** 
 
18
** You should have received a copy of the GNU Library General Public License
 
19
** along with XSB; if not, write to the Free Software Foundation,
 
20
** Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
21
**
 
22
** $Id: cinterf.c,v 1.66 2006/05/05 21:38:02 dwarren Exp $
 
23
** 
 
24
*/
 
25
 
 
26
#include "xsb_config.h"
 
27
#include "xsb_debug.h"
 
28
 
 
29
#include <stdio.h>
 
30
#include <string.h>
 
31
#include <stdlib.h>
 
32
#if !defined(WIN_NT) || defined(CYGWIN)
 
33
#include <unistd.h>
 
34
#endif
 
35
#include <errno.h>
 
36
 
 
37
#include "auxlry.h"
 
38
#include "cell_xsb.h"
 
39
#include "memory_xsb.h"
 
40
#include "register.h"
 
41
#include "psc_xsb.h"
 
42
#include "flags_xsb.h"
 
43
#include "deref.h"
 
44
#include "heap_xsb.h"
 
45
#include "binding.h"
 
46
#include "tries.h"
 
47
#include "choice.h"
 
48
#include "subp.h"
 
49
#include "emuloop.h"
 
50
#include "cinterf.h"
 
51
#include "error_xsb.h"
 
52
#include "orient_xsb.h"
 
53
#include "loader_xsb.h"
 
54
#include "context.h"
 
55
 
 
56
/*
 
57
  This was the old test for being a kosher Prolog string
 
58
#define PRINTABLE_OR_ESCAPED_CHAR(Ch) (Ch <= 255 || Ch >= 0)
 
59
*/
 
60
#define PRINTABLE_OR_ESCAPED_CHAR(Ch) \
 
61
  ((Ch >= (int)' ' && Ch <= (int)'~') || (Ch >= (int)'\a' && Ch <= (int)'\r'))
 
62
 
 
63
/* the following really belongs somewhere else */
 
64
extern char *expand_filename(char *);
 
65
extern void xsb_sprint_variable(CTXTdeclc char *sptr, CPtr var);
 
66
 
 
67
 
 
68
char *p_charlist_to_c_string(CTXTdeclc prolog_term term, VarString *buf,
 
69
                             char *in_func, char *where);
 
70
void c_string_to_p_charlist(CTXTdeclc char *name, prolog_term list,
 
71
                            int regs_to_protect, char *in_func, char *where);
 
72
 
 
73
/*======================================================================*/
 
74
/* Low level C interface                                                */
 
75
/*======================================================================*/
 
76
 
 
77
DllExport xsbBool call_conv is_var(prolog_term term)
 
78
{
 
79
    Cell t = (Cell)term;
 
80
    XSB_Deref(t);
 
81
    return isref(t);
 
82
}
 
83
 
 
84
DllExport xsbBool call_conv is_int(prolog_term term)
 
85
{
 
86
    Cell t = (Cell)term;
 
87
    XSB_Deref(t);
 
88
    return (isinteger(t) | isboxedinteger(t));
 
89
}
 
90
 
 
91
DllExport xsbBool call_conv is_float(prolog_term term)
 
92
{
 
93
    Cell t = (Cell)term;
 
94
    XSB_Deref(t);
 
95
    return isofloat(t);
 
96
}
 
97
 
 
98
DllExport xsbBool call_conv is_string(prolog_term term)
 
99
{
 
100
    Cell t = (Cell)term;
 
101
    XSB_Deref(t);
 
102
    return isstring(t);
 
103
}
 
104
 
 
105
DllExport xsbBool call_conv is_atom(prolog_term term)
 
106
{
 
107
    Cell t = (Cell)term;
 
108
    XSB_Deref(t);
 
109
    return isatom(t);
 
110
}
 
111
 
 
112
DllExport xsbBool call_conv is_list(prolog_term term)
 
113
{
 
114
    Cell t = (Cell)term;
 
115
    XSB_Deref(t);
 
116
    return islist(t);
 
117
}
 
118
 
 
119
DllExport xsbBool call_conv is_nil(prolog_term term)
 
120
{
 
121
    Cell t = (Cell)term;
 
122
    XSB_Deref(t);
 
123
    return isnil(t);
 
124
}
 
125
 
 
126
DllExport xsbBool call_conv is_functor(prolog_term term)
 
127
{
 
128
    Cell t = (Cell)term;
 
129
    XSB_Deref(t);
 
130
    return isconstr(t);
 
131
}
 
132
 
 
133
DllExport xsbBool call_conv is_attv(prolog_term term)
 
134
{
 
135
    Cell t = (Cell)term;
 
136
    XSB_Deref(t);
 
137
    return isattv(t);
 
138
}
 
139
 
 
140
DllExport prolog_term call_conv reg_term(CTXTdeclc reg_num regnum)
 
141
{
 
142
    register Cell addr;
 
143
 
 
144
    addr = cell(reg+regnum);
 
145
    XSB_Deref(addr);
 
146
    return (prolog_term)addr;
 
147
}
 
148
 
 
149
DllExport xsbBool call_conv c2p_int(CTXTdeclc Integer val, prolog_term var)
 
150
{
 
151
    Cell v = (Cell)var;
 
152
    if (is_var(v)) {
 
153
      bind_oint(vptr(v), val);
 
154
      return TRUE;
 
155
    } else {
 
156
      xsb_warn("[C2P_INT] Argument 2 must be a variable");
 
157
      return FALSE;
 
158
    }
 
159
}
 
160
 
 
161
DllExport xsbBool call_conv c2p_float(CTXTdeclc double val, prolog_term var)
 
162
{
 
163
    Cell v = (Cell)var;
 
164
    if (is_var(v)) {
 
165
        bind_boxedfloat(vptr(v), (Float)(val));
 
166
        return TRUE;
 
167
    } else {
 
168
        xsb_warn("[C2P_FLOAT] Argument 2 must be a variable");
 
169
        return FALSE;
 
170
    }
 
171
}
 
172
 
 
173
DllExport xsbBool call_conv c2p_string(CTXTdeclc char *val, prolog_term var)
 
174
{
 
175
    Cell v = (Cell)var;
 
176
    if (is_var(v)) {
 
177
        bind_string(vptr(v), (char *)string_find(val, 1));
 
178
        return TRUE;
 
179
    } else {
 
180
        xsb_warn("[C2P_STRING] Argument 2 must be a variable");
 
181
        return FALSE;
 
182
    }
 
183
}
 
184
 
 
185
DllExport xsbBool call_conv c2p_list(CTXTdeclc prolog_term var)
 
186
{
 
187
    Cell v = (Cell)var;
 
188
    if (is_var(v)) {
 
189
        sreg = hreg;
 
190
        new_heap_free(hreg);
 
191
        new_heap_free(hreg);
 
192
        bind_list(vptr(v), sreg);
 
193
        return TRUE;
 
194
    } else {
 
195
        xsb_warn("[C2P_LIST] Argument must be a variable");
 
196
        return FALSE;
 
197
    }
 
198
}
 
199
 
 
200
DllExport xsbBool call_conv c2p_nil(CTXTdeclc prolog_term var)
 
201
{
 
202
    Cell v = (Cell)var;
 
203
    if (is_var(v)) {
 
204
       bind_nil(vptr(v));
 
205
       return TRUE;
 
206
    } else {
 
207
        xsb_warn("[C2P_NIL] Argument must be a variable");
 
208
        return FALSE;
 
209
    }
 
210
}
 
211
 
 
212
DllExport void call_conv c2p_setfree(prolog_term var)
 
213
{
 
214
    CPtr v = (CPtr)var;
 
215
    bld_free(v);
 
216
}
 
217
 
 
218
/* space is space in words required; regcnt is number of registers to protect */
 
219
DllExport void call_conv ensure_heap_space(CTXTdeclc int space, int regcnt) {
 
220
  check_glstack_overflow(regcnt,pcreg,space);
 
221
}
 
222
 
 
223
DllExport xsbBool call_conv c2p_functor(CTXTdeclc char *functor, int arity, 
 
224
                                        prolog_term var)
 
225
{
 
226
    Cell v = (Cell)var;
 
227
    Pair sym;
 
228
    int i;
 
229
    if (is_var(v)) {
 
230
        sym = (Pair)insert(functor, (byte)arity, (Psc)flags[CURRENT_MODULE], &i);
 
231
        sreg = hreg;
 
232
        hreg += arity + 1;
 
233
        bind_cs(vptr(v), sreg);
 
234
        new_heap_functor(sreg, sym->psc_ptr);
 
235
        for (i=0; i<arity; sreg++,i++) { bld_free(sreg); }
 
236
        return TRUE;
 
237
    } else {
 
238
        xsb_warn("[C2P_FUNCTOR] Argument 3 must be a variable");
 
239
        return FALSE;
 
240
    }
 
241
}
 
242
 
 
243
DllExport Integer call_conv p2c_int(prolog_term term)
 
244
{
 
245
    Cell t = (Cell)term;
 
246
    return oint_val(t);
 
247
}
 
248
 
 
249
DllExport double call_conv p2c_float(prolog_term term)
 
250
{
 
251
    Cell t = (Cell)term;
 
252
    return (double)(ofloat_val(t));
 
253
}
 
254
 
 
255
DllExport char* call_conv p2c_string(prolog_term term)
 
256
{
 
257
    Cell t = (Cell)term;
 
258
    return string_val(t);
 
259
}
 
260
 
 
261
DllExport char* call_conv p2c_functor(prolog_term term)
 
262
{
 
263
    Cell t = (Cell)term;
 
264
    return get_name(get_str_psc(t));
 
265
}
 
266
 
 
267
DllExport int call_conv p2c_arity(prolog_term term)
 
268
{
 
269
    Cell t = (Cell)term;
 
270
    return get_arity(get_str_psc(t));
 
271
}
 
272
 
 
273
DllExport prolog_term call_conv p2p_arg(prolog_term term, int argno)
 
274
{
 
275
    Cell t = (Cell)term;
 
276
    XSB_Deref(t);
 
277
    t = cell(clref_val(t)+argno);
 
278
    XSB_Deref(t);
 
279
    return (prolog_term)t;
 
280
}
 
281
 
 
282
DllExport prolog_term call_conv p2p_car(prolog_term term)
 
283
{
 
284
    Cell t = (Cell)term;
 
285
    XSB_Deref(t);
 
286
    t = cell(clref_val(t));
 
287
    XSB_Deref(t);
 
288
    return (prolog_term)t;
 
289
}
 
290
 
 
291
DllExport prolog_term call_conv p2p_cdr(prolog_term term)
 
292
{
 
293
    Cell t = (Cell)term;
 
294
    XSB_Deref(t);
 
295
    t = cell(clref_val(t)+1);
 
296
    XSB_Deref(t);
 
297
    return (prolog_term)t;
 
298
}
 
299
 
 
300
DllExport prolog_term call_conv p2p_new(CTXTdecl)
 
301
{
 
302
    CPtr t = hreg;
 
303
    new_heap_free(hreg);
 
304
    return (prolog_term)(cell(t));
 
305
}
 
306
 
 
307
DllExport xsbBool call_conv p2p_unify(CTXTdeclc prolog_term term1, prolog_term term2)
 
308
{
 
309
    return unify(CTXTc term1, term2);
 
310
}
 
311
 
 
312
DllExport prolog_term call_conv p2p_deref(prolog_term term)
 
313
{
 
314
    Cell t = (Cell)term;
 
315
    XSB_Deref(t);
 
316
    return (prolog_term)t;
 
317
}
 
318
 
 
319
 
 
320
/* convert Arg 1 -- prolog list of characters (a.k.a. prolog string) into C
 
321
   string and return this string. A character is an integer 1 through 255
 
322
   (i.e., not necessarily printable)
 
323
   Arg 2: ptr to string buffer where the result is to be returned.
 
324
          Space for this buffer must already be allocated.
 
325
   Arg 3: which function was called from.
 
326
   Arg 4: where in the call this happened.
 
327
   Args 3 and 4 are used for error reporting.
 
328
   This function converts escape sequences in the Prolog string
 
329
   (except octal/hexadecimal escapes) into the corresponding real characters.
 
330
*/
 
331
char *p_charlist_to_c_string(CTXTdeclc prolog_term term, VarString *buf,
 
332
                             char *in_func, char *where)
 
333
{
 
334
  Integer head_val;
 
335
  char head_char[1];
 
336
  int escape_mode=FALSE;
 
337
  prolog_term list = term, list_head;
 
338
 
 
339
  if (!is_list(list) && !is_nil(list)) {
 
340
    xsb_abort("[%s] %s is not a list of characters", in_func, where);
 
341
  }
 
342
 
 
343
  XSB_StrSet(buf, "");
 
344
 
 
345
  while (is_list(list)) {
 
346
    if (is_nil(list)) break;
 
347
    list_head = p2p_car(list);
 
348
    if (!is_int(list_head)) {
 
349
      xsb_abort("[%s] A Prolog string (a character list) expected, %s",
 
350
                in_func, where);
 
351
    }
 
352
    head_val = int_val(list_head);
 
353
    if (! PRINTABLE_OR_ESCAPED_CHAR(head_val) ) {
 
354
      xsb_abort("[%s] A Prolog string (a character list) expected, %s",
 
355
                in_func, where);
 
356
    }
 
357
 
 
358
    *head_char = (char) head_val;
 
359
    /* convert ecape sequences */
 
360
    if (escape_mode)
 
361
      switch (*head_char) {
 
362
      case 'a':
 
363
        XSB_StrAppendBlk(buf, "\a", 1);
 
364
        break;
 
365
      case 'b':
 
366
        XSB_StrAppendBlk(buf, "\b", 1);
 
367
        break;
 
368
      case 'f':
 
369
        XSB_StrAppendBlk(buf, "\f", 1);
 
370
        break;
 
371
      case 'n':
 
372
        XSB_StrAppendBlk(buf, "\n", 1);
 
373
        break;
 
374
      case 'r':
 
375
        XSB_StrAppendBlk(buf, "\r", 1);
 
376
        break;
 
377
      case 't':
 
378
        XSB_StrAppendBlk(buf, "\t", 1);
 
379
        break;
 
380
      case 'v':
 
381
        XSB_StrAppendBlk(buf, "\v", 1);
 
382
        break;
 
383
      default:
 
384
        XSB_StrAppendBlk(buf, head_char, 1);
 
385
      }
 
386
    else
 
387
      XSB_StrAppendBlk(buf, head_char, 1);
 
388
 
 
389
    if (*head_char == '\\' && !escape_mode) {
 
390
      escape_mode = TRUE;
 
391
      buf->length--; /* backout the last char */
 
392
    }
 
393
    else {
 
394
      escape_mode = FALSE;
 
395
    }
 
396
    list = p2p_cdr(list);
 
397
  } /* while */
 
398
 
 
399
  XSB_StrNullTerminate(buf);
 
400
 
 
401
  return (buf->string);
 
402
}
 
403
 
 
404
 
 
405
/* convert a C string into a prolog list of characters. 
 
406
   (codelist might be a better suffix.)
 
407
   LIST must be a Prolog variable. IN_FUNC is a string that should indicate the
 
408
   high-level function from this c_string_to_p_charlist was called.
 
409
   regs_to_protect is the number of registers with values (needed for stack expansion)
 
410
   WHERE is another string with additional info. These two are used to provide
 
411
   informative error messages to the user. */
 
412
void c_string_to_p_charlist(CTXTdeclc char *name, prolog_term list,
 
413
                            int regs_to_protect, char *in_func, char *where)
 
414
{
 
415
  Cell new_list;
 
416
  CPtr top = 0;
 
417
  int len=strlen(name), i;
 
418
 
 
419
  if (isnonvar(list)) {
 
420
    xsb_abort("[%s] A variable expected, %s", in_func, where);
 
421
  }
 
422
  if (len == 0) {
 
423
    bind_nil((CPtr)(list));
 
424
  } else {
 
425
    check_glstack_overflow(regs_to_protect, pcreg, 2*len*sizeof(Cell));
 
426
    new_list = makelist(hreg);
 
427
    for (i = 0; i < len; i++) {
 
428
      follow(hreg++) = makeint(*(unsigned char *)name);
 
429
      name++;
 
430
      top = hreg++;
 
431
      follow(top) = makelist(hreg);
 
432
    } follow(top) = makenil;
 
433
    unify(CTXTc list, new_list);
 
434
  } 
 
435
}
 
436
 
 
437
 
 
438
/* The following function checks if a given term is a prolog string of
 
439
   printable characters.
 
440
   It also counts the size of the list.
 
441
   It deals with the same escape sequences as p_charlist_to_c_string.
 
442
*/
 
443
 
 
444
DllExport xsbBool call_conv is_charlist(prolog_term term, int *size)
 
445
{
 
446
  int escape_mode=FALSE, head_char;
 
447
  prolog_term list, head;
 
448
 
 
449
  list = term;
 
450
  *size = 0;
 
451
  
 
452
  /* apparently, is_nil can be true and is_list false?? */
 
453
  if(is_nil(list))
 
454
    return TRUE;
 
455
 
 
456
  if (!is_list(list)) 
 
457
    return FALSE;
 
458
 
 
459
  while (is_list(list)) {
 
460
    if (is_nil(list)) break;
 
461
 
 
462
    head = p2p_car(list);
 
463
    if (!is_int(head)) 
 
464
      return FALSE;
 
465
    
 
466
    head_char = (char) int_val(head);
 
467
    /* ' ' is the lowest printable ascii and '~' is the highest */
 
468
    if (! PRINTABLE_OR_ESCAPED_CHAR(head_char) )
 
469
      return FALSE;
 
470
 
 
471
    if (escape_mode)
 
472
      switch (head_char) {
 
473
      case 'a':
 
474
      case 'b':
 
475
      case 'f':
 
476
      case 'n':
 
477
      case 'r':
 
478
      case 't':
 
479
      case 'v':
 
480
        (*size)++;
 
481
        escape_mode=FALSE;
 
482
        break;
 
483
      default:
 
484
        (*size) += 2;
 
485
      }
 
486
    else
 
487
      if (head_char == '\\') 
 
488
        escape_mode = TRUE;
 
489
      else
 
490
        (*size)++;
 
491
    list = p2p_cdr(list);
 
492
  }
 
493
  return TRUE;
 
494
}
 
495
 
 
496
/* the following two functions were introduced by Luis Castro */
 
497
/* they extend the c interface to allow for an easy interface for 
 
498
lists of characters */
 
499
 
 
500
DllExport char *call_conv p2c_chars(CTXTdeclc prolog_term term, char *buf, int bsize)
 
501
{
 
502
  XSB_StrDefine(bufvar);
 
503
 
 
504
  p_charlist_to_c_string(CTXTc term, &bufvar, "p2c_chars", "list -> char*");
 
505
  
 
506
  if (strlen(bufvar.string) > (size_t) bsize) {
 
507
    xsb_abort("Buffer overflow in p2c_chars");
 
508
  }
 
509
 
 
510
  return strcpy(buf,bufvar.string);
 
511
}
 
512
 
 
513
DllExport void call_conv c2p_chars(CTXTdeclc char *str, int regs_to_protect, prolog_term term)
 
514
{
 
515
  c_string_to_p_charlist(CTXTc str,term,regs_to_protect,"c2p_chars", "char* -> list");
 
516
}
 
517
 
 
518
 
 
519
/*
 
520
** Constaints and internal data structures
 
521
**
 
522
*/
 
523
 
 
524
#include "setjmp_xsb.h"
 
525
 
 
526
static char *c_dataptr_rest;
 
527
 
 
528
#ifndef MULTI_THREAD
 
529
static jmp_buf cinterf_env;
 
530
#endif
 
531
 
 
532
/*
 
533
** procedure cppc_error
 
534
**
 
535
*/
 
536
 
 
537
static void cppc_error(CTXTdeclc int num)
 
538
{
 
539
    longjmp(cinterf_env, num);
 
540
}
 
541
 
 
542
/*
 
543
** procedure skip_subfmt
 
544
**
 
545
*/
 
546
 
 
547
static char *skip_subfmt(CTXTdeclc char *ptr, char quote)
 
548
{
 
549
    while (*ptr) {
 
550
        if (*ptr == quote) return ++ptr;
 
551
        else if (*ptr == '[') ptr = skip_subfmt(CTXTc ++ptr, ']');
 
552
        else if (*ptr == '(') ptr = skip_subfmt(CTXTc ++ptr, ')');
 
553
        else ptr++;
 
554
    }
 
555
    cppc_error(CTXTc 6);
 
556
    return ptr; /* never reach here */
 
557
}
 
558
 
 
559
/*
 
560
** procedure count_arity
 
561
**
 
562
** count Prolog term size (arity). Ignored fields are not counted
 
563
*/
 
564
 
 
565
static int count_arity(CTXTdeclc char *ptr, int quote)
 
566
{
 
567
    int arity = 0;
 
568
 
 
569
    while (*ptr && arity <= MAX_ARITY) {
 
570
        if (*ptr == quote) return arity;
 
571
        else if (*ptr == '%') {
 
572
            if (*(++ptr)!='*') arity++;
 
573
        } else if (*ptr == '[') ptr = skip_subfmt(CTXTc ++ptr, ']');
 
574
        else if (*ptr == '(') ptr = skip_subfmt(CTXTc ++ptr, ')');
 
575
        else ptr++;
 
576
    }
 
577
    cppc_error(CTXTc 5);
 
578
    return -1;  /* never reach here */
 
579
}
 
580
 
 
581
/*
 
582
** procedure count_fields
 
583
**
 
584
** count number of fields in the primary structure.
 
585
** should be the same as arity + ignored fields.
 
586
*/
 
587
 
 
588
static int count_fields(CTXTdeclc char *ptr, int quote)
 
589
{
 
590
    int fields = 0;
 
591
 
 
592
    while (*ptr && fields <= MAX_ARITY) {
 
593
        if (*ptr == quote) return fields;
 
594
        else if (*ptr == '%') { fields++; ptr++; }
 
595
        else if (*ptr == '[') ptr = skip_subfmt(CTXTc ++ptr, ']');
 
596
        else if (*ptr == '(') ptr = skip_subfmt(CTXTc ++ptr, ')');
 
597
        else ptr++;
 
598
    }
 
599
    cppc_error(CTXTc 5);
 
600
    return -1;  /* never reach here */
 
601
}
 
602
 
 
603
/*
 
604
** procedure count_csize
 
605
**
 
606
** count C struct size (number of bytes). Ignored fields are also counted
 
607
*/
 
608
 
 
609
static int count_csize(CTXTdeclc char *ptr, int quote)
 
610
{
 
611
    int size = 0;
 
612
 
 
613
    while (*ptr) {
 
614
        if (*ptr == quote) return size;
 
615
        else if (*ptr == '%') {
 
616
            if (*(++ptr)=='*') ptr++;
 
617
            switch (*ptr) {
 
618
                case 'f': size += sizeof(float); ptr++; break;
 
619
                case 'd': size += sizeof(double); ptr++; break;
 
620
                case 'i': size += sizeof(int); ptr++; break;
 
621
                case 'c': size += 1; ptr++; break;
 
622
                case 's': size += sizeof(char *); ptr++; break;
 
623
                case 'z': ptr++; size += 4 * (*ptr-'0'); ptr++; break;
 
624
                case 't': size += sizeof(int *);
 
625
                    ptr += 2;
 
626
                    skip_subfmt(CTXTc ptr, ')');
 
627
                    break;
 
628
                case 'l': size += sizeof(int *);
 
629
                    ptr += 2;
 
630
                    skip_subfmt(CTXTc ptr, ')');
 
631
                    break;
 
632
                case '[': 
 
633
                    size += count_csize(CTXTc ++ptr, ']');
 
634
                    skip_subfmt(CTXTc ptr, ']');
 
635
                    break;
 
636
                case '0':
 
637
                case '1':
 
638
                case '2':
 
639
                case '3':
 
640
                case '4':
 
641
                case '5':
 
642
                case '6':
 
643
                case '7':
 
644
                case '8':
 
645
                case '9':
 
646
                    size += sizeof(int *); ptr++; break;
 
647
                default: cppc_error(CTXTc 7); break;
 
648
            }
 
649
        }
 
650
    }
 
651
    cppc_error(CTXTc 8);
 
652
    return -1;  /* never reach here */
 
653
}
 
654
 
 
655
/*
 
656
** procedure ctop_term0
 
657
**
 
658
*/
 
659
 
 
660
static char *ctop_term0(CTXTdeclc char *ptr, char *c_dataptr, char **subformat,
 
661
                        prolog_term variable, int ignore)
 
662
{
 
663
    char ch;
 
664
    int fmtnum;
 
665
    char *cdptr2;
 
666
    int  argno, fields, i;
 
667
    int ignore1;
 
668
 
 
669
    if (*ptr++!= '%') cppc_error(CTXTc 1);
 
670
    ch = *ptr++;
 
671
    if (ch=='*') ch = *ptr++;
 
672
    switch (ch) {
 
673
        case 'i':                       /* int */
 
674
        
 
675
        if (!ignore) c2p_int(CTXTc *((int *)(c_dataptr)), variable);
 
676
        c_dataptr_rest = c_dataptr + sizeof(int);
 
677
        break;
 
678
 
 
679
        case 'c':
 
680
 
 
681
        if (!ignore) c2p_int(CTXTc (int)(*(char *)(c_dataptr)), variable);
 
682
        c_dataptr_rest = c_dataptr + 1;
 
683
        break;
 
684
 
 
685
        case 's':
 
686
 
 
687
        if (!ignore) c2p_string(CTXTc *(char **)(c_dataptr), variable);
 
688
        c_dataptr_rest = c_dataptr + sizeof(char*);
 
689
        break;
 
690
 
 
691
        case 'z':
 
692
 
 
693
        if (!ignore) c2p_string(CTXTc c_dataptr, variable);
 
694
        ch = *ptr++;
 
695
        c_dataptr_rest = c_dataptr + (ch -'0')*4;
 
696
        break;
 
697
 
 
698
        case 'f':
 
699
 
 
700
        if (!ignore) c2p_float(CTXTc (double)(*((float *)(c_dataptr))), variable);
 
701
        c_dataptr_rest = c_dataptr + sizeof(float);
 
702
        break;
 
703
 
 
704
        case 'd':
 
705
 
 
706
        if (!ignore) c2p_float(CTXTc *((double *)(c_dataptr)), variable);
 
707
        c_dataptr_rest = c_dataptr + sizeof(double);
 
708
        break;
 
709
 
 
710
        case '[':
 
711
 
 
712
        fields = count_fields(CTXTc ptr, ']');
 
713
        if (!ignore) {
 
714
            argno = count_arity(CTXTc ptr, ']');
 
715
            if (!is_functor(variable)) c2p_functor(CTXTc "c2p", argno, variable);
 
716
        }
 
717
        argno = 0;
 
718
        for (i = 1; i <= fields; i++) {
 
719
            if (*(ptr+1)=='*') ignore1 = 1;
 
720
            else { ignore1 = ignore; argno++; }
 
721
            ptr = ctop_term0(CTXTc ptr,c_dataptr,subformat,p2p_arg(variable,argno),ignore1);
 
722
            c_dataptr = c_dataptr_rest;
 
723
        }
 
724
        ptr = skip_subfmt(CTXTc ptr, ']');
 
725
        break;
 
726
 
 
727
        case 't':
 
728
 
 
729
        if (!ignore) {
 
730
            if (*(char **)(c_dataptr)) {
 
731
                fmtnum = (int)(*ptr-'0');
 
732
                subformat[fmtnum] = ptr-2;
 
733
                ptr++;
 
734
                if (*(ptr++) !='(') cppc_error(CTXTc 2);
 
735
                argno = count_arity(CTXTc ptr, ')');
 
736
                fields = count_fields(CTXTc ptr, ')');
 
737
                if (!is_functor(variable)) c2p_functor(CTXTc "c2p", argno, variable);
 
738
                cdptr2 = * (char **)(c_dataptr);
 
739
                argno = 0;
 
740
                for (i = 1; i <= fields; i++) {
 
741
                    if (*(ptr+1)=='*') ignore = 1;
 
742
                    else { ignore = 0; argno++; }
 
743
                    ptr = ctop_term0(CTXTc ptr,cdptr2,subformat,p2p_arg(variable,argno),ignore);
 
744
                    cdptr2 = c_dataptr_rest;
 
745
                }
 
746
            } else c2p_nil(CTXTc variable);
 
747
        }
 
748
        ptr = skip_subfmt(CTXTc ptr, ')');
 
749
        c_dataptr_rest = c_dataptr + 4;
 
750
        break;
 
751
 
 
752
        case 'l':
 
753
        if (!ignore) {
 
754
            if (*(char **)(c_dataptr)) {
 
755
                fmtnum = (int)(*ptr-'0');
 
756
                subformat[fmtnum] = ptr-2;
 
757
                ptr++;
 
758
                if (*(ptr++) != '(') cppc_error(CTXTc 3);
 
759
                argno = count_arity(CTXTc ptr, ')');
 
760
                fields = count_fields(CTXTc ptr, ')');
 
761
                if (!is_list(variable)) c2p_list(CTXTc variable);
 
762
                cdptr2 = * (char **)(c_dataptr);
 
763
                argno = 0;
 
764
                for (i = 1; i <= fields; i++) {
 
765
                    if (*(ptr+1)=='*') ignore = 1;
 
766
                    else { ignore = 0; argno++; }
 
767
                    if (argno==1) 
 
768
                       ptr = ctop_term0(CTXTc ptr,cdptr2,subformat,p2p_car(variable),ignore);
 
769
                    else if (argno==2)
 
770
                       ptr = ctop_term0(CTXTc ptr,cdptr2,subformat,p2p_cdr(variable),ignore);
 
771
                    else if (argno==0)
 
772
                       ptr = ctop_term0(CTXTc ptr,cdptr2,subformat,p2p_car(variable),ignore);
 
773
                       /* always ignored */
 
774
                    else cppc_error(CTXTc 30);
 
775
                    cdptr2 = c_dataptr_rest;
 
776
                }
 
777
            } else c2p_nil(CTXTc variable);
 
778
        }
 
779
        ptr = skip_subfmt(CTXTc ptr, ')');
 
780
        c_dataptr_rest = c_dataptr + 4;
 
781
        break;
 
782
 
 
783
        case '0':
 
784
        case '1':
 
785
        case '2':
 
786
        case '3':
 
787
        case '4':
 
788
        case '5':
 
789
        case '6':
 
790
        case '7':
 
791
        case '8':
 
792
        case '9':
 
793
 
 
794
        if (!ignore) {
 
795
            if (*(char **)(c_dataptr)) {
 
796
                ctop_term0(CTXTc subformat[ch-'0'], c_dataptr, subformat,variable, 0);
 
797
            } else c2p_nil(CTXTc variable);
 
798
        }
 
799
        c_dataptr_rest = c_dataptr + 4;
 
800
        break;
 
801
 
 
802
        default: cppc_error(CTXTc 4);
 
803
    }
 
804
    return ptr;
 
805
}
 
806
 
 
807
/*
 
808
** procedure ptoc_term0
 
809
**
 
810
*/
 
811
 
 
812
static char *ptoc_term0(CTXTdeclc char *ptr, char *c_dataptr, char **subformat,
 
813
                        prolog_term variable, int ignore)
 
814
{
 
815
    char ch;
 
816
    int fmtnum;
 
817
    char *cdptr2;
 
818
    int  argno, fields, i, size;
 
819
    int ignore1;
 
820
 
 
821
    if (*ptr++!= '%') cppc_error(CTXTc 9);
 
822
    ch = *ptr++;
 
823
    if (ch=='*') ch = *ptr++;
 
824
    switch (ch) {
 
825
        case 'i':                       /* int */
 
826
 
 
827
        if (!ignore) {
 
828
            if (is_int(variable)) *((int *)(c_dataptr)) = p2c_int(variable);
 
829
            else cppc_error(CTXTc 10);
 
830
        }
 
831
        c_dataptr_rest = c_dataptr + sizeof(int);
 
832
        break;
 
833
 
 
834
        case 'c':
 
835
 
 
836
        if (!ignore) {
 
837
            if (is_int(variable)) *((char *)(c_dataptr)) = 
 
838
               (char)p2c_int(variable);
 
839
            else cppc_error(CTXTc 11);
 
840
        }
 
841
        c_dataptr_rest = c_dataptr + 1;
 
842
        break;
 
843
 
 
844
        case 's':
 
845
 
 
846
        if (!ignore) {
 
847
            if (is_string(variable)) *((char **)(c_dataptr)) =
 
848
               p2c_string(variable);            /* should make a copy??? */
 
849
            else cppc_error(CTXTc 12);
 
850
        }
 
851
        c_dataptr_rest = c_dataptr + 4;
 
852
        break;
 
853
 
 
854
        case 'z':
 
855
 
 
856
        ch = *ptr++;
 
857
        size = 4 * (ch - '0');
 
858
        if (!ignore) {
 
859
            if (is_string(variable)) 
 
860
               strncpy(c_dataptr, p2c_string(variable), size);
 
861
            else cppc_error(CTXTc 12);
 
862
        }
 
863
        c_dataptr_rest = c_dataptr + size;
 
864
        break;
 
865
 
 
866
        case 'f':
 
867
 
 
868
        if (!ignore) {
 
869
            if (is_float(variable)) 
 
870
              *((float *)(c_dataptr)) = (float)p2c_float(variable);
 
871
            else cppc_error(CTXTc 13);
 
872
        }
 
873
        c_dataptr_rest = c_dataptr + sizeof(float);
 
874
        break;
 
875
 
 
876
        case 'd':
 
877
 
 
878
        if (!ignore) {
 
879
            if (is_float(variable)) *((double *)(c_dataptr)) =
 
880
               p2c_float(variable);
 
881
            else cppc_error(CTXTc 14);
 
882
        }
 
883
        c_dataptr_rest = c_dataptr + sizeof(double);
 
884
        break;
 
885
 
 
886
        case '[':
 
887
 
 
888
        fields = count_fields(CTXTc ptr, ']');
 
889
        argno = 0;
 
890
        for (i = 1; i <= fields; i++) {
 
891
            if (*(ptr+1)=='*') ignore1 = 1;
 
892
            else { ignore1 = ignore; argno++; }
 
893
            ptr = ptoc_term0(CTXTc ptr, c_dataptr,subformat,p2p_arg(variable,argno),ignore1);
 
894
            c_dataptr = c_dataptr_rest;
 
895
        }
 
896
        ptr = skip_subfmt(CTXTc ptr, ']');
 
897
        break;
 
898
 
 
899
        case 't':
 
900
 
 
901
        if (!ignore) {
 
902
            fmtnum = (int)(*ptr-'0');
 
903
            subformat[fmtnum] = ptr-2;
 
904
            ptr++;
 
905
            if (*(ptr++) != '(') cppc_error(CTXTc 15);
 
906
            fields = count_fields(CTXTc ptr, ')');
 
907
            size = count_csize(CTXTc ptr, ')');
 
908
            cdptr2 = (char *)mem_alloc(size,OTHER_SPACE);  /* leak */
 
909
            *((char **)c_dataptr) = cdptr2;
 
910
            argno = 0;
 
911
            for (i = 1; i <= fields; i++) {
 
912
                if (*(ptr+1)=='*') ignore = 1;
 
913
                else { ignore = 0; argno++; }
 
914
                ptr = ptoc_term0(CTXTc ptr,cdptr2,subformat,p2p_arg(variable,argno),ignore);
 
915
                cdptr2 = c_dataptr_rest;
 
916
            }
 
917
        }
 
918
        ptr = skip_subfmt(CTXTc ptr, ')');
 
919
        c_dataptr_rest = c_dataptr + 4;
 
920
        break;
 
921
 
 
922
        case 'l':
 
923
        if (!ignore) {
 
924
            fmtnum = (int)(*ptr-'0');
 
925
            subformat[fmtnum] = ptr-2;
 
926
            ptr++;
 
927
            if (*(ptr++)!='(') cppc_error(CTXTc 16);
 
928
            fields = count_fields(CTXTc ptr, ')');
 
929
            size = count_csize(CTXTc ptr, ')');
 
930
            cdptr2 = (char *)mem_alloc(size,OTHER_SPACE);  /* leak */
 
931
            *((char **)c_dataptr) = cdptr2;
 
932
            argno = 0;
 
933
            for (i = 1; i <= fields; i++) {
 
934
                if (*(ptr+1)=='*') ignore = 1;
 
935
                else { ignore = 0; argno++; }
 
936
                if (argno==1)
 
937
                   ptr = ptoc_term0(CTXTc ptr,cdptr2,subformat,p2p_car(variable),ignore);
 
938
                else if (argno==2)
 
939
                   ptr = ptoc_term0(CTXTc ptr,cdptr2,subformat,p2p_cdr(variable),ignore);
 
940
                else cppc_error(CTXTc 31);
 
941
                cdptr2 = c_dataptr_rest;
 
942
            }
 
943
        }
 
944
        ptr = skip_subfmt(CTXTc ptr, ')');
 
945
        c_dataptr_rest = c_dataptr + 4;
 
946
        break;
 
947
 
 
948
        case '0':
 
949
        case '1':
 
950
        case '2':
 
951
        case '3':
 
952
        case '4':
 
953
        case '5':
 
954
        case '6':
 
955
        case '7':
 
956
        case '8':
 
957
        case '9':
 
958
 
 
959
        if (!ignore) {
 
960
            if (!is_nil(variable)) {
 
961
                ptoc_term0(CTXTc subformat[ch-'0'], c_dataptr, subformat, variable, 0);
 
962
            } else *(int *)(c_dataptr) = 0;
 
963
        }
 
964
        c_dataptr_rest = c_dataptr + 4;
 
965
        break;
 
966
 
 
967
        default: cppc_error(CTXTc 17);
 
968
    }
 
969
    return ptr;
 
970
}
 
971
 
 
972
/*
 
973
** procedure ctop_term
 
974
**
 
975
*/
 
976
 
 
977
int ctop_term(CTXTdeclc char *fmt, char *c_dataptr, reg_num regnum)
 
978
{
 
979
    prolog_term variable;
 
980
    int my_errno;
 
981
    char *subformat[10];
 
982
 
 
983
    variable = reg_term(CTXTc regnum);
 
984
    if ((my_errno = setjmp(cinterf_env))) return my_errno;  /* catch an exception */
 
985
    ctop_term0(CTXTc fmt, c_dataptr, subformat, variable, 0);
 
986
    return 0;
 
987
}
 
988
 
 
989
/*
 
990
** procedure ptoc_term
 
991
**
 
992
*/
 
993
 
 
994
int ptoc_term(CTXTdeclc char *fmt, char *c_dataptr, reg_num regnum)
 
995
{
 
996
    prolog_term variable;
 
997
    int my_errno;
 
998
    char *subformat[10];
 
999
 
 
1000
    variable = reg_term(CTXTc regnum);
 
1001
    if ((my_errno = setjmp(cinterf_env))) return my_errno;  /* catch an exception */
 
1002
    ptoc_term0(CTXTc fmt, c_dataptr, subformat, variable, 0);
 
1003
    return 0;
 
1004
}
 
1005
 
 
1006
/*
 
1007
** procedure c2p_term
 
1008
**
 
1009
*/
 
1010
 
 
1011
int c2p_term(CTXTdeclc char *fmt, char *c_dataptr, prolog_term variable)
 
1012
{
 
1013
    int my_errno;
 
1014
    char *subformat[10];
 
1015
 
 
1016
    if ((my_errno = setjmp(cinterf_env))) return my_errno;  /* catch an exception */
 
1017
    ctop_term0(CTXTc fmt, c_dataptr, subformat, variable, 0);
 
1018
    return 0;
 
1019
}
 
1020
 
 
1021
/*
 
1022
** procedure p2c_term
 
1023
**
 
1024
*/
 
1025
 
 
1026
int p2c_term(CTXTdeclc char *fmt, char *c_dataptr, prolog_term variable)
 
1027
{
 
1028
    int my_errno;
 
1029
    char *subformat[10];
 
1030
 
 
1031
    if ((my_errno = setjmp(cinterf_env))) return my_errno;  /* catch an exception */
 
1032
    ptoc_term0(CTXTc fmt, c_dataptr, subformat, variable, 0);
 
1033
    return 0;
 
1034
}
 
1035
/* quick test to see whether atom must be quoted */
 
1036
int mustquote(char *atom)
 
1037
{
 
1038
    int i;
 
1039
 
 
1040
    if (!(atom[0] >= 'a' && atom[0] <= 'z')) return TRUE;
 
1041
    for (i=1; atom[i] != '\0'; i++) {
 
1042
        if (!((atom[i] >= 'a' && atom[i] <= 'z') ||
 
1043
             (atom[i] >= 'A' && atom[i] <= 'Z') ||
 
1044
             (atom[i] == '_') ||
 
1045
             (atom[i] >= '0' && atom[i] <= '9')
 
1046
             )) return TRUE;
 
1047
    }
 
1048
    return FALSE;
 
1049
}
 
1050
 
 
1051
/* copy a string (quoted if !toplevel and necessary) into a buffer.  */
 
1052
void printpstring(char *atom, int toplevel, VarString *straddr)
 
1053
{
 
1054
    int i;
 
1055
   
 
1056
    if (toplevel || !mustquote(atom)) {
 
1057
      XSB_StrAppend(straddr,atom);
 
1058
    } else {
 
1059
      XSB_StrAppendBlk(straddr, "'", 1);
 
1060
      for (i = 0; atom[i] != '\0'; i++) {
 
1061
        XSB_StrAppendBlk(straddr, atom+i, 1);
 
1062
        if (atom[i] == '\'')
 
1063
          /* double the quotes in a quoted string */
 
1064
          XSB_StrAppendBlk(straddr, "'", 1);
 
1065
      }
 
1066
      XSB_StrAppend(straddr, "'");
 
1067
    }
 
1068
}
 
1069
    
 
1070
/* calculate approximate length of a printed term.  For space alloc. */
 
1071
int clenpterm(prolog_term term)
 
1072
{
 
1073
  int i, clen;
 
1074
 
 
1075
  if (is_var(term)) return 11;
 
1076
  else if (is_int(term)) return 12;
 
1077
  else if (is_float(term)) return 12;
 
1078
  else if (is_nil(term)) return 2;
 
1079
  else if (is_string(term)) return strlen(p2c_string(term))+5;
 
1080
  else if (is_list(term)) {
 
1081
      clen = 1;
 
1082
      clen += clenpterm(p2p_car(term)) + 1;
 
1083
      while (is_list(term)) {
 
1084
          clen += clenpterm(p2p_car(term)) + 1;
 
1085
          term = p2p_cdr(term);
 
1086
      }
 
1087
      if (!is_nil(term)) {
 
1088
          clen += clenpterm(term) + 1;
 
1089
      }
 
1090
      return clen+1;
 
1091
  } else if (is_functor(term)) {
 
1092
      clen = strlen(p2c_functor(term))+5;
 
1093
      if (p2c_arity(term) > 0) {
 
1094
          clen += clenpterm(p2p_arg(term,1)) + 1;
 
1095
          for (i = 2; i <= p2c_arity(term); i++) {
 
1096
              clen += clenpterm(p2p_arg(term,i)) + 1;
 
1097
          }
 
1098
          return clen + 1;
 
1099
      } else return clen;
 
1100
  } else {
 
1101
      xsb_warn("Unrecognized prolog term type");
 
1102
      return 0;
 
1103
  }
 
1104
}
 
1105
 
 
1106
char tempstring[MAXBUFSIZE];
 
1107
 
 
1108
/* print a prolog_term into a buffer.
 
1109
   Atoms are quoted if !toplevel -- necessary for Prolog reading 
 
1110
   Buffer is a VarString. If the VarString is non-empty, the term is appended
 
1111
   to the current contents of the VarString.
 
1112
*/
 
1113
DllExport void call_conv print_pterm(CTXTdeclc prolog_term term, int toplevel, 
 
1114
                                     VarString *straddr)
 
1115
{
 
1116
  int i;
 
1117
 
 
1118
  if (is_var(term)) {
 
1119
    xsb_sprint_variable(CTXTc tempstring, (CPtr) term);
 
1120
    XSB_StrAppend(straddr,tempstring);
 
1121
  } else if (is_attv(term)) {
 
1122
    xsb_sprint_variable(CTXTc tempstring, (CPtr) dec_addr(term));
 
1123
    XSB_StrAppend(straddr,tempstring);
 
1124
  } else if (is_int(term)) {
 
1125
    sprintf(tempstring,"%d", (int) p2c_int(term));
 
1126
    XSB_StrAppend(straddr,tempstring);
 
1127
  } else if (is_float(term)) {
 
1128
    sprintf(tempstring,"%f", (float) p2c_float(term));
 
1129
    XSB_StrAppend(straddr,tempstring);
 
1130
  } else if (is_nil(term)) {
 
1131
    XSB_StrAppend(straddr,"[]");
 
1132
  } else if (is_string(term)) {
 
1133
    printpstring(p2c_string(term),toplevel,straddr);
 
1134
  } else if (is_list(term)) {
 
1135
    XSB_StrAppend(straddr, "[");
 
1136
    print_pterm(CTXTc p2p_car(term),FALSE,straddr);
 
1137
    term = p2p_cdr(term);
 
1138
    while (is_list(term)) {
 
1139
      XSB_StrAppend(straddr, ",");
 
1140
      print_pterm(CTXTc p2p_car(term),FALSE,straddr);
 
1141
      term = p2p_cdr(term);
 
1142
    }
 
1143
    if (!is_nil(term)) {
 
1144
      XSB_StrAppend(straddr, "|");
 
1145
      print_pterm(CTXTc term,FALSE,straddr);
 
1146
    }
 
1147
    XSB_StrAppend(straddr, "]");
 
1148
  } else if (is_functor(term)) {
 
1149
    printpstring(p2c_functor(term),FALSE,straddr);
 
1150
    if (p2c_arity(term) > 0) {
 
1151
      XSB_StrAppend(straddr, "(");
 
1152
      print_pterm(CTXTc p2p_arg(term,1),FALSE,straddr);
 
1153
      for (i = 2; i <= p2c_arity(term); i++) {
 
1154
        XSB_StrAppend(straddr, ",");
 
1155
        print_pterm(CTXTc p2p_arg(term,i),FALSE,straddr);
 
1156
      }
 
1157
      XSB_StrAppend(straddr, ")");
 
1158
    }
 
1159
  } else xsb_warn("[PRINT_PTERM] Unrecognized prolog term type");
 
1160
}
 
1161
 
 
1162
/************************************************************************/
 
1163
/*                                                                      */
 
1164
/*      xsb_answer_string copies an answer from reg 2 into ans.         */
 
1165
/*                                                                      */
 
1166
/************************************************************************/
 
1167
int xsb_answer_string(CTXTdeclc VarString *ans, char *sep) 
 
1168
{
 
1169
  int i;
 
1170
  
 
1171
  if (!is_string(reg_term(CTXTc 2))) {
 
1172
    for (i=1; i<p2c_arity(reg_term(CTXTc 2)); i++) {
 
1173
      print_pterm(CTXTc p2p_arg(reg_term(CTXTc 2),i),TRUE,ans);
 
1174
      XSB_StrAppend(ans,sep);
 
1175
    }
 
1176
    print_pterm(CTXTc p2p_arg(reg_term(CTXTc 2),p2c_arity(reg_term(CTXTc 2))),TRUE,ans);
 
1177
  }
 
1178
  return 0;
 
1179
}
 
1180
 
 
1181
 
 
1182
static long lastWarningStart = 0L;
 
1183
static inline void updateWarningStart(void)
 
1184
{
 
1185
  if(flags[STDERR_BUFFERED])
 
1186
        lastWarningStart = ftell(stderr);
 
1187
}
 
1188
 
 
1189
/************************************************************************/
 
1190
/*                                                                      */
 
1191
/* xsb_init(argc,argv) initializes XSB to be called from C.             */
 
1192
/* argc and argv are the arg count and arg vector as passed from the    */
 
1193
/* command line.  The parameters are used to set space sizes in xsb.    */
 
1194
/* The parameters MUST include -i, which indicates that the main        */
 
1195
/* interpreter is to be loaded, AND -n, which indicates that the        */
 
1196
/* interpreter should not enter the usual read-eval-print loop, but     */
 
1197
/* instead support the interface to the C caller.                       */
 
1198
/*   If xsb has been previously initialized, nothing is done and 1 is   */
 
1199
/* returned.                                                            */
 
1200
/*                                                                      */
 
1201
/************************************************************************/
 
1202
 
 
1203
static int xsb_initted_gl = 0;   /* if xsb has been called */
 
1204
static int xsb_inquery_gl = 0;   
 
1205
 
 
1206
DllExport int call_conv xsb_init(CTXTdeclc int argc, char *argv[])
 
1207
{
 
1208
int rc = 1;
 
1209
char executable1[MAXPATHLEN];
 
1210
 char *expfilename;
 
1211
 
 
1212
updateWarningStart();
 
1213
if (!xsb_initted_gl)
 
1214
        {
 
1215
        /* we rely on the caller to tell us in argv[0]
 
1216
        the absolute or relative path name to the XSB installation directory */
 
1217
        sprintf(executable1, "%s%cconfig%c%s%cbin%cxsb",
 
1218
        argv[0], SLASH, SLASH, FULL_CONFIG_NAME, SLASH, SLASH);
 
1219
        expfilename = expand_filename(executable1);
 
1220
        strcpy(executable_path_gl, expfilename);
 
1221
        mem_dealloc(expfilename,MAXPATHLEN,OTHER_SPACE);
 
1222
 
 
1223
        if (0 == (rc = xsb(CTXTc 0,argc,argv)))     /* initialize xsb */
 
1224
                {
 
1225
                if (0 == (rc = xsb(CTXTc 1,0,0)))       /* enter xsb to set up regs */
 
1226
                xsb_initted_gl = 1;
 
1227
                }
 
1228
        }
 
1229
return(rc);
 
1230
}
 
1231
 
 
1232
/************************************************************************/
 
1233
/*                                                                      */
 
1234
/*  int xsb_cmd_string(char *cmdline, char **argv) takes a              */
 
1235
/*  command line string in cmdline, and parses it to return an argv     */
 
1236
/*  vector in its second argument, and the argc count as the value of   */
 
1237
/*      the function.  (Will handle a max of 19 args.)                  */
 
1238
/*                                                                      */
 
1239
/************************************************************************/
 
1240
/*FILE *stream_err, *stream_out;*/
 
1241
 
 
1242
DllExport int call_conv xsb_init_string(CTXTdeclc char *cmdline_param) {
 
1243
        int i = 0, argc = 0;
 
1244
        char **argv, delim;
 
1245
        char cmdline[2*MAXPATHLEN+1];
 
1246
 
 
1247
  updateWarningStart();
 
1248
 
 
1249
        /*stream_err = freopen("XSB_errlog", "w", stderr);
 
1250
          stream_out = freopen("XSB_outlog", "w", stdout);*/
 
1251
 
 
1252
        if (strlen(cmdline_param) > 2*MAXPATHLEN) {
 
1253
            xsb_warn("**************************************************************************");
 
1254
            xsb_warn("[XSB_INIT_STRING] %18s...: command used to call XSB server is too long",
 
1255
                    cmdline_param);
 
1256
            xsb_warn("**************************************************************************");
 
1257
            exit(1);
 
1258
        }
 
1259
        strncpy(cmdline, cmdline_param, 2*MAXPATHLEN - 1);
 
1260
        argv = (char **) mem_alloc(20*sizeof(char *),OTHER_SPACE);  /* count space even if never released */
 
1261
 
 
1262
        while (cmdline[i] == ' ') i++;
 
1263
        while (cmdline[i] != '\0') {
 
1264
                if ((cmdline[i] == '"') || (cmdline[i] == '\'')) {
 
1265
                        delim = cmdline[i];
 
1266
                        i++;
 
1267
                } else delim = ' ';
 
1268
                argv[argc] = &(cmdline[i]);
 
1269
                argc++;
 
1270
                if (argc >= 19) {argc--; break;}
 
1271
                while ((cmdline[i] != delim) && (cmdline[i] != '\0')) i++;
 
1272
                if (cmdline[i] == '\0') break;
 
1273
                cmdline[i] = '\0';
 
1274
                i++;
 
1275
                while (cmdline[i] == ' ') i++;
 
1276
        }
 
1277
        argv[argc] = 0;
 
1278
        return xsb_init(CTXTc argc,argv);
 
1279
}
 
1280
 
 
1281
/************************************************************************/
 
1282
/*                                                                      */
 
1283
/* xsb_command() passes the command (i.e. query with no variables) to   */
 
1284
/* xsb.  The command must be put into xsb's register 1 as a term, by    */
 
1285
/* the caller who uses the c2p_* (and perhaps p2p_*) functions.         */
 
1286
/*   It returns 0 if it succeeds, 1 if it fails, in either case         */
 
1287
/* resetting register 1 back to a free variable.  It returns 2 if there */
 
1288
/* is an error.                                                         */
 
1289
/*                                                                      */
 
1290
/************************************************************************/
 
1291
 
 
1292
DllExport int call_conv xsb_command(CTXTdecl)
 
1293
{
 
1294
  if (xsb_inquery_gl) return(2);  /* error */
 
1295
  updateWarningStart();
 
1296
  c2p_int(CTXTc 0,reg_term(CTXTc 3));  /* command for calling a goal */
 
1297
  xsb(CTXTc 1,0,0);
 
1298
  if (is_var(reg_term(CTXTc 1))) return(1);  /* goal failed, so return 1 */
 
1299
  c2p_int(CTXTc 1,reg_term(CTXTc 3));  /* command for next answer */
 
1300
  xsb(CTXTc 1,0,0);
 
1301
  if (is_var(reg_term(CTXTc 1))) return(0);  /* goal succeeded */
 
1302
  (void) xsb_close_query(CTXT);
 
1303
  return(2);
 
1304
}
 
1305
 
 
1306
/************************************************************************/
 
1307
/*                                                                      */
 
1308
/* xsb_command_string(char *goal) passes the command (e.g. a query      */
 
1309
/* which only succeeds or fails) to xsb.  The command must a string     */
 
1310
/* passed in the argument.  It returns 0 if it succeeds, 1 if it        */
 
1311
/* fails, in either case resetting register 1 back to a free            */
 
1312
/* variable.  It returns 2 if there is an error.                        */
 
1313
/*                                                                      */
 
1314
/************************************************************************/
 
1315
 
 
1316
DllExport int call_conv xsb_command_string(CTXTdeclc char *goal)
 
1317
{
 
1318
  if (xsb_inquery_gl) return(2);  /* error */
 
1319
  updateWarningStart();
 
1320
  c2p_string(CTXTc goal,reg_term(CTXTc 1));
 
1321
  c2p_int(CTXTc 2,reg_term(CTXTc 3));  /* command for calling a string goal */
 
1322
  xsb(CTXTc 1,0,0);
 
1323
  if (is_var(reg_term(CTXTc 1))) return(1);  /* goal failed, so return 1 */
 
1324
  c2p_int(CTXTc 1,reg_term(CTXTc 3));  /* command for next answer */
 
1325
  xsb(CTXTc 1,0,0);
 
1326
  if (is_var(reg_term(CTXTc 1))) return(0);  /* goal succeeded */
 
1327
  (void) xsb_close_query(CTXT);
 
1328
  return(2);
 
1329
}
 
1330
 
 
1331
/************************************************************************/
 
1332
/*                                                                      */ 
 
1333
/* xsb_query() submits a query to xsb. The query must have been put into*/
 
1334
/* xsb's register 1 by the caller, using p2c_* (and perhaps p2p_*).  Xsb*/
 
1335
/* will evaluate the query and return with the variables in the query   */
 
1336
/* bound to the first answer.  In addition, register 2 will contain a   */
 
1337
/* Prolog term of the form ret(V1,V2,..,Vn) with as many Vi's as        */
 
1338
/* variables in the original query and with Vi bound to the value for   */
 
1339
/* that variable in the first answer.  If the query fails, it returns 1.*/
 
1340
/* If the query succeeds, it returns 0. If there is an error, it returns*/
 
1341
/* 2.                                                                   */
 
1342
/*                                                                      */
 
1343
/************************************************************************/
 
1344
 
 
1345
DllExport int call_conv xsb_query(CTXTdecl)
 
1346
{
 
1347
  if (xsb_inquery_gl) return(2);
 
1348
  updateWarningStart();
 
1349
  c2p_int(CTXTc 0,reg_term(CTXTc 3));  /* set command for calling a goal */
 
1350
  xsb(CTXTc 1,0,0);
 
1351
  if (is_var(reg_term(CTXTc 1))) return(1);
 
1352
  xsb_inquery_gl = 1;
 
1353
  return(0);
 
1354
}
 
1355
 
 
1356
/************************************************************************/
 
1357
/*                                                                      */ 
 
1358
/* xsb_query_string(char *) submits a query to xsb.  The string must
 
1359
   be a goal that will be correctly read by xsb's reader, and it must
 
1360
   be terminated with a period (.).  Register 2 may be a variable or
 
1361
   it may be a term of the form ret(X1,X2,...,Xn), where n is the
 
1362
   number of variables in the query.  The query will be parsed, and an
 
1363
   answer term of the form ret(Y1,Y2,...,Yn) will be constructed where
 
1364
   Y1, .... Yn are the variables in the parsed goal (in left-to-right
 
1365
   order).  This answer term is unified with the argument in register
 
1366
   2.  Then the goal is called.  If the goal succeeds,
 
1367
   xsb_query_string returns 0 and the first answer is in register 2.
 
1368
   If it fails, xsb_query_string returns 1.                             */
 
1369
/*                                                                      */
 
1370
/************************************************************************/
 
1371
 
 
1372
DllExport int call_conv xsb_query_string(CTXTdeclc char *goal)
 
1373
{
 
1374
  if (xsb_inquery_gl) return(2);
 
1375
  updateWarningStart();
 
1376
  c2p_chars(CTXTc goal,2,reg_term(CTXTc 1));
 
1377
  c2p_int(CTXTc 2,reg_term(CTXTc 3));  /* set command for calling a string goal */
 
1378
  xsb(CTXTc 1,0,0);
 
1379
  if (is_var(reg_term(CTXTc 1))) return(1);
 
1380
  xsb_inquery_gl = 1;
 
1381
  return(0);
 
1382
}
 
1383
 
 
1384
/************************************************************************/
 
1385
/*                                                                      */
 
1386
/*  xsb_query_string_string calls xsb_query_string and returns          */
 
1387
/*      the answer in a string.  The answer is copied into ans,         */
 
1388
/*      a VarString provided by the caller.  Variable                   */
 
1389
/*      values are separated by the string sep.                         */
 
1390
/*                                                                      */
 
1391
/************************************************************************/
 
1392
 
 
1393
int call_conv xsb_query_string_string(CTXTdeclc char *goal, 
 
1394
                                      VarString *ans, char *sep) 
 
1395
{
 
1396
  int rc;
 
1397
  
 
1398
  rc = xsb_query_string(CTXTc goal);
 
1399
  if (rc > 0) return rc;
 
1400
  return xsb_answer_string(CTXTc ans,sep);
 
1401
}
 
1402
 
 
1403
/************************************************************************/
 
1404
/*                                                                      */
 
1405
/*  xsb_query_string_string_b calls xsb_query_string and returns        */
 
1406
/*      the answer in a string.  The caller provides a buffer and its   */
 
1407
/*      length.  If the answer fits in the buffer, it is returned       */
 
1408
/*      there, and its length is returned.  If not, then the length is  */ 
 
1409
/*      returned, and the answer can be obtained by calling             */
 
1410
/*      xsb_get_last_answer.                                            */
 
1411
/*                                                                      */
 
1412
/************************************************************************/
 
1413
#ifndef MULTI_THREAD
 
1414
static XSB_StrDefine(last_answer_lc);
 
1415
#define last_answer (&last_answer_lc)
 
1416
#endif
 
1417
 
 
1418
int call_conv xsb_query_string_string_b(CTXTdeclc
 
1419
             char *goal, char *buff, int buflen, int *anslen, char *sep) 
 
1420
{
 
1421
  int rc;
 
1422
  
 
1423
  XSB_StrSet(last_answer,"");
 
1424
  rc = xsb_query_string_string(CTXTc goal,last_answer,sep); 
 
1425
  if (rc > 0) return rc;
 
1426
  *anslen = last_answer->length;
 
1427
  XSB_StrNullTerminate(last_answer);
 
1428
  if (last_answer->length < buflen) {
 
1429
    strcpy(buff,last_answer->string);
 
1430
    return rc;
 
1431
  } else return(3);
 
1432
}
 
1433
 
 
1434
/************************************************************************/
 
1435
/*                                                                      */
 
1436
/*      xsb_get_last_answer_string returns previous answer.             */
 
1437
/*                                                                      */
 
1438
/************************************************************************/
 
1439
DllExport int call_conv 
 
1440
   xsb_get_last_answer_string(CTXTdeclc char *buff, int buflen, int *anslen) {
 
1441
 
 
1442
 *anslen = last_answer->length;
 
1443
  if (last_answer->length < buflen) {
 
1444
    strcpy(buff,last_answer->string);
 
1445
    return 0;
 
1446
  } else 
 
1447
    return(3);
 
1448
}    
 
1449
 
 
1450
/************************************************************************/
 
1451
/*                                                                      */
 
1452
/* xsb_next() causes xsb to return the next answer.  It (or             */
 
1453
/* xsb_close_query) must be called after xsb_query.  If there is        */
 
1454
/* another answer, xsb_next returns 0 and the variables in goal term    */
 
1455
/* (in xsb register 1) are bound to the answer values.  In addition     */
 
1456
/* xsb register 2 will contain a term of the form ret(V1,V2,...,Vn)     */
 
1457
/* where the Vi's are the values for the variables for the next         */
 
1458
/* answer.                                                              */
 
1459
/* xsb_next returns 0 if the next is found, 1 if there are no more      */
 
1460
/* answers, and 3 if an error is encountered. If 1 is returned, then    */
 
1461
/* the query is automatically closed.                                   */
 
1462
/*                                                                      */
 
1463
/************************************************************************/
 
1464
 
 
1465
DllExport int call_conv xsb_next(CTXTdecl)
 
1466
{
 
1467
  if (!xsb_inquery_gl) return(2);
 
1468
  updateWarningStart();
 
1469
  c2p_int(CTXTc 0,reg_term(CTXTc 3));  /* set command for next answer */
 
1470
  xsb(CTXTc 1,0,0);
 
1471
  if (is_var(reg_term(CTXTc 1))) {
 
1472
    xsb_inquery_gl = 0;
 
1473
    return(1);
 
1474
  } else return(0);
 
1475
}
 
1476
 
 
1477
/************************************************************************/
 
1478
/*                                                                      */
 
1479
/*      xsb_next_string(ans,sep) calls xsb_next() and returns the       */
 
1480
/*      answer in the VarString ans, provided by the caller.            */
 
1481
/*      sep is a separator for the fields of the answer.                */
 
1482
/*                                                                      */
 
1483
/************************************************************************/
 
1484
 
 
1485
DllExport int call_conv xsb_next_string(CTXTdeclc VarString *ans, char *sep) 
 
1486
{
 
1487
  int rc = xsb_next(CTXT);
 
1488
  if (rc > 0) return rc;
 
1489
  return xsb_answer_string(CTXTc ans,sep);
 
1490
}
 
1491
 
 
1492
/************************************************************************/
 
1493
/*                                                                      */
 
1494
/*      xsb_next_string_b(buff,buflen,anslen,sep) calls xsb_next() and  */
 
1495
/*      returns the answer in buff, provided by the caller.  The length */
 
1496
/*      of buff is buflen.  The length of the answer is put in anslen.  */
 
1497
/*      If the buffer is too small for the answer, nothing is put in    */
 
1498
/*      the buffer.  In this case the caller can allocate a larger      */
 
1499
/*      and retrieve the buffer using xsb_get_last_answer.              */
 
1500
/*                                                                      */
 
1501
/************************************************************************/
 
1502
 
 
1503
DllExport int call_conv xsb_next_string_b(CTXTdeclc
 
1504
                     char *buff, int buflen, int *anslen, char *sep) 
 
1505
{
 
1506
  int rc;
 
1507
 
 
1508
  XSB_StrSet(last_answer,"");
 
1509
  rc = xsb_next_string(CTXTc last_answer,sep);
 
1510
  if (rc > 0) return rc;
 
1511
  *anslen = last_answer->length;
 
1512
  XSB_StrNullTerminate(last_answer);
 
1513
  if (last_answer->length < buflen) {
 
1514
    strcpy(buff,last_answer->string);
 
1515
    return rc;
 
1516
  } else return(3);
 
1517
}
 
1518
 
 
1519
/************************************************************************/
 
1520
/*                                                                      */
 
1521
/* xsb_close_query() closes the current query, so that no more answers  */
 
1522
/* will be returned, and another query can be opened.                   */
 
1523
/* If the query was correctly closed, it resets xsb registers 1 and 2   */
 
1524
/* to be variables, and returns 0.  If there is some error, it returns  */
 
1525
/* 2.                                                                   */
 
1526
/*                                                                      */
 
1527
/************************************************************************/
 
1528
 
 
1529
DllExport int call_conv xsb_close_query(CTXTdecl)
 
1530
{
 
1531
  updateWarningStart();
 
1532
  if (!xsb_inquery_gl) return(2);
 
1533
  c2p_int(CTXTc 1,reg_term(CTXTc 3));  /* set command for cut */
 
1534
  xsb(CTXTc 1,0,0);
 
1535
  if (is_var(reg_term(CTXTc 1))) {
 
1536
    xsb_inquery_gl = 0;
 
1537
    return(0);
 
1538
  } else return(2);
 
1539
}
 
1540
 
 
1541
/************************************************************************/
 
1542
/*                                                                      */
 
1543
/*  xsb_close() is currently just a noop, since it doesn't clean        */
 
1544
/*  anything up, to allow a re-init.                                    */
 
1545
/*                                                                      */
 
1546
/************************************************************************/
 
1547
 
 
1548
DllExport int call_conv xsb_close(CTXTdecl)
 
1549
{
 
1550
  updateWarningStart();
 
1551
  if (xsb_initted_gl) return(0);
 
1552
  else return(1);
 
1553
}
 
1554
 
 
1555
#if defined(WIN_NT)
 
1556
//
 
1557
// From: UNIX Application Migration Guide
 
1558
// http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnucmg/html/UCMGch10.asp
 
1559
//
 
1560
// The version there won't compile as is, but it can be fixed...
 
1561
//
 
1562
#include <io.h>
 
1563
#include <Basetsd.h>
 
1564
#if !defined(CYGWIN)
 
1565
typedef SSIZE_T ssize_t;
 
1566
#endif
 
1567
static inline ssize_t pread(int fd, void *buf, size_t count, long offset)
 
1568
{
 
1569
if (-1 == lseek(fd,offset,SEEK_SET))
 
1570
        return(-1);
 
1571
return(read(fd,buf,count));
 
1572
}
 
1573
#else
 
1574
//
 
1575
// For concurrent access to a file (required for asynchronous I/O (AIO) support)
 
1576
// requires the pread() and pwrite() system calls to actually work
 
1577
// so let's use the real thing that way we can safely be multi-threaded.
 
1578
//
 
1579
#include <unistd.h>
 
1580
#endif
 
1581
 
 
1582
/************************************************************************/
 
1583
/*                                                                      */
 
1584
/*      xsb_get_last_error_string returns previous answer.             */
 
1585
/*                                                                      */
 
1586
/************************************************************************/
 
1587
DllExport int call_conv xsb_get_last_error_string(char *buff, int buflen, int *anslen)
 
1588
{
 
1589
int rc = 2;
 
1590
ssize_t bytesRead = 1;
 
1591
ssize_t totalBytesRead = 0;
 
1592
 
 
1593
if(!flags[STDERR_BUFFERED])
 
1594
        xsb_warn("[xsb_get_last_error_string] This feature must be activated with the -q option");
 
1595
else
 
1596
        {
 
1597
        rc = 1;                         // Assume failure on the ftell or read
 
1598
        errno = 0;                      // Setup to detect error in ftell
 
1599
        *anslen = (int)(ftell(stderr) - lastWarningStart);
 
1600
        if((0 == errno) && (-1 < *anslen))
 
1601
                {                               // ftell worked
 
1602
                if (*anslen >= buflen)
 
1603
                        rc = 3;         // Not enough room in the target buffer
 
1604
                else
 
1605
                        {
 
1606
                        while ((totalBytesRead < *anslen) && (0 < bytesRead) && !ferror(stderr))
 
1607
                                {
 
1608
                                bytesRead = pread(fileno(stderr),&buff[totalBytesRead],(*anslen - totalBytesRead),(lastWarningStart + totalBytesRead));
 
1609
                                totalBytesRead += bytesRead;
 
1610
                                }
 
1611
                        if (!ferror(stderr))
 
1612
                                {
 
1613
                                rc = 0;
 
1614
                                if (-1 == bytesRead)
 
1615
                                        *anslen = totalBytesRead + 1;
 
1616
                                else
 
1617
                                        *anslen = totalBytesRead;
 
1618
                                buff[*anslen] = 0x00;
 
1619
                                }
 
1620
                        }
 
1621
                }
 
1622
        }
 
1623
return(rc);
 
1624
}