prolog_term intern_rec(CTXTdeclc prolog_term term) {
int areaindex, reclen, i, j;
CPtr hc_term;
Cell dterm[255];
Cell arg;
// printf("intern_rec\n");
// create term-record with all fields dereffed in dterm
XSB_Deref(term);
if (isinternstr(term)) {printf("old\n"); return term;}
if (isconstr(term)) {
areaindex = get_arity(get_str_psc(term));
reclen = areaindex + 1;
cell(dterm) = (Cell)get_str_psc(term); // copy psc ptr
j=1;
} else if (islist(term)) {
areaindex = LIST_INDEX;
reclen = 2;
j=0;
} else return 0;
for (i=j; i<reclen; i++) {
arg = get_str_arg(term,i); // works for lists and strs
XSB_Deref(arg);
if (isref(arg) || (isstr(arg) && !isinternstr(arg)) || isattv(arg)) {
return 0;
}
cell(dterm+i) = arg;
}
hc_term = insert_interned_rec(reclen, areaindex, dterm);
if (islist(term)) return makelist(hc_term); else return makecs(hc_term);
}
void unify(char x[],char y[])
{char a[100],b[100];
if(strcmp(theta,"FAILURE")==0)
return;
if(strcmp(x,y)==0)
return;
else if(isvariable(x))
unify_var(x,y);
else if(isvariable(y))
unify_var(x,y);
else if(iscompound(x) && iscompound(y))
{
strcpy(a,arg(x));
strcpy(b,arg(y));
unify(a,b);
strcpy(a,op(x));
strcpy(b,op(y));
unify(a,b);
}
else if(islist(x) && islist(y))
{
strcpy(a,rest(x));
strcpy(b,rest(y));
unify(a,b);
strcpy(a,first(x));
strcpy(b,first(y));
unify(a,b);
}
else
sprintf(theta,"FAILURE",theta);
return;
}
static DL intern_delay_list(CPtr dlist) /* assumes that dlist != NULL */
{
DE head = NULL, de;
DL dl = NULL;
while (islist(dlist)) {
dlist = clref_val(dlist);
if ((de = intern_delay_element(cell(dlist))) != NULL) {
de_next(de) = head;
head = de;
}
dlist = (CPtr) cell(dlist+1);
}
if (head) {
new_entry(dl,
released_dls,
next_free_dl,
current_dl_block,
current_dl_block_top,
dl_next,
DL,
dl_block_size,
"Not enough memory to expand DL space");
dl_de_list(dl) = head;
dl_asl(dl) = NULL;
return dl;
}
else return NULL;
}
static inline expr *eval_varargs(scope *scope, expr *e) {
assert(islist(e));
if (e == NULL)
return NULL;
else
return create_cell(eval(scope, e->head), eval_varargs(scope, e->tail));
}
static Line *
enumerated_block(Paragraph *top, int clip, MMIOT *f, int list_class)
{
ParagraphRoot d = { 0, 0 };
Paragraph *p;
Line *q = top->text, *text;
int para = 0, z;
while (( text = q )) {
p = Pp(&d, text, LISTITEM);
text = listitem(p, clip, f->flags, 0);
p->down = compile(p->text, 0, f);
p->text = 0;
if ( para && p->down ) p->down->align = PARA;
if ( (q = skipempty(text)) == 0
|| islist(q, &clip, f->flags, &z) != list_class )
break;
if ( para = (q != text) ) {
Line anchor;
anchor.next = text;
___mkd_freeLineRange(&anchor, q);
if ( p->down ) p->down->align = PARA;
}
}
top->text = 0;
top->down = T(d);
return text;
}
/*
* pull in a list block. A list block starts with a list marker and
* runs until the next list marker, the next non-indented paragraph,
* or EOF. You do not have to indent nonblank lines after the list
* marker, but multiple paragraphs need to start with a 4-space indent.
*/
static Line *
listitem(Paragraph *p, int indent, DWORD flags, linefn check)
{
Line *t, *q;
int clip = indent;
int z;
for ( t = p->text; t ; t = q) {
CLIP(t->text, 0, clip);
UNCHECK(t);
t->dle = mkd_firstnonblank(t);
/* even though we had to trim a long leader off this item,
* the indent for trailing paragraphs is still 4...
*/
if (indent > 4) {
indent = 4;
}
if ( (q = skipempty(t->next)) == 0 ) {
___mkd_freeLineRange(t,q);
return 0;
}
/* after a blank line, the next block needs to start with a line
* that's indented 4(? -- reference implementation allows a 1
* character indent, but that has unfortunate side effects here)
* spaces, but after that the line doesn't need any indentation
*/
if ( q != t->next ) {
if (q->dle < indent) {
q = t->next;
t->next = 0;
return q;
}
/* indent at least 2, and at most as
* as far as the initial line was indented. */
indent = clip ? clip : 2;
}
if ( (q->dle < indent) && (ishr(q) || islist(q,&z,flags,&z)
|| (check && (*check)(q)))
&& !issetext(q,&z) ) {
q = t->next;
t->next = 0;
return q;
}
clip = (q->dle > indent) ? indent : q->dle;
}
return t;
}
static int
endoftextblock(Line *t, int toplevelblock, DWORD flags)
{
int z;
if ( end_of_block(t) || isquote(t) )
return 1;
/* HORRIBLE STANDARDS KLUDGES:
* 1. non-toplevel paragraphs absorb adjacent code blocks
* 2. Toplevel paragraphs eat absorb adjacent list items,
* but sublevel blocks behave properly.
* (What this means is that we only need to check for code
* blocks at toplevel, and only check for list items at
* nested levels.)
*/
return toplevelblock ? 0 : islist(t,&z,flags,&z);
}
/* must be called with interned term (isinternstr(term)is true) */
int is_interned_rec(Cell term) {
int areaindex, reclen;
struct intterm_rec *recptr;
CPtr term_rec;
UInteger hashindex;
if (islist(term)) {areaindex = LIST_INDEX; reclen = 2; }
else {areaindex = get_arity(get_str_psc(term)); reclen = areaindex + 1; }
if (!hc_block[areaindex].base) return FALSE;
term_rec = (CPtr)cs_val(term);
hashindex = it_hash(hc_block[areaindex].hashtab_size,reclen,term_rec);
recptr = hc_block[areaindex].hashtab[hashindex];
while (recptr) {
if (term_rec == &(recptr->intterm_psc)) {return TRUE;}
recptr = recptr->next;
}
return FALSE;
}
static int
endoftextblock(Line *t, int toplevelblock, DWORD flags)
{
int z;
if ( blankline(t)||isquote(t)||ishdr(t,&z)||ishr(t) )
return 1;
/* HORRIBLE STANDARDS KLUDGE: non-toplevel paragraphs absorb adjacent
* code blocks
*/
if ( toplevelblock && iscode(t) )
return 1;
/* HORRIBLE STANDARDS KLUDGE: Toplevel paragraphs eat absorb adjacent
* list items, but sublevel blocks behave properly.
*/
return toplevelblock ? 0 : islist(t,&z,flags, &z);
}
/* Apply a procedure expression to a list of expressions */
static exp_t *
prim_apply(exp_t *args)
{
exp_t *op, *prev, *last;
if (isnull(args) || isnull(cdr(args)))
everr("apply: expects at least 2 arguments, given", args);
op = car(args);
if (!isnull(last = cddr(args))) {
for (prev = cdr(args); !isnull(cdr(last)); last = cdr(last))
prev = last;
cdr(prev) = car(last);
args = cdr(args);
} else {
last = cdr(args);
args = car(last);
}
if (!islist(car(last)))
everr("apply: should be a proper list", car(last));
return apply(op, args);
}
xsbBool answer_is_junk(CPtr dlist) /* assumes that dlist != NULL */
{
CPtr cptr;
VariantSF subgoal;
NODEptr ans_subst;
Cell tmp_cell;
while (islist(dlist)) {
dlist = clref_val(dlist);
cptr = (CPtr) cs_val(cell(dlist));
tmp_cell = cell(cptr + 1);
subgoal = (VariantSF) addr_val(tmp_cell);
tmp_cell = cell(cptr + 2);
ans_subst = (NODEptr) addr_val(tmp_cell);
if (is_failing_delay_element(subgoal,ans_subst)) {
return TRUE;
}
dlist = (CPtr) cell(dlist+1);
}
return FALSE;
}
static action_t cont_fn() {
ref_t formals = car(expr), body = cdr(expr);
size_t arity = 0;
bool rest = NO;
if (!islist(formals))
error("invalid function: formals must be a list");
for(; !isnil(formals); arity++, formals = cdr(formals)) {
ref_t sym = car(formals);
if (sym == sym_amp) {
if (length(cdr(formals)) != 1)
error("invalid function: must have exactly one symbol after &");
rest = YES;
set_car(formals, cadr(formals));
set_cdr(formals, NIL);
break;
}
}
formals = car(expr);
pop_cont();
expr = lambda(formals, body, C(cont)->closure, arity, rest);
return ACTION_APPLY_CONT;
}
/* should be passed a term which is dereffed for which isinternstr is true! */
int isinternstr_really(prolog_term term) {
int areaindex, reclen, i;
CPtr termrec;
CPtr hc_term;
struct intterm_rec *recptr;
Integer hashindex;
int found;
XSB_Deref(term);
if (isconstr(term)) {
areaindex = get_arity(get_str_psc(term));
reclen = areaindex + 1;
} else if (islist(term)) {
areaindex = LIST_INDEX;
reclen = 2;
} else return FALSE;
if (!hc_block[areaindex].hashtab) return FALSE;
termrec = (CPtr)dec_addr(term);
hashindex = it_hash(hc_block[areaindex].hashtab_size,reclen,termrec);
recptr = hc_block[areaindex].hashtab[hashindex];
while (recptr) {
found = 1;
hc_term = &(recptr->intterm_psc);
for (i=0; i<reclen; i++) {
if (cell(hc_term+i) != cell(termrec+i)) {
found = 0; break;
}
}
// if (found && (hc_term == termrec)) printf("found interned term\n");
if (found) return (hc_term == termrec);
recptr = recptr->next;
}
return FALSE;
}
xsbBool glstack_realloc(CTXTdeclc size_t new_size, int arity)
{
CPtr new_heap_bot=NULL ; /* bottom of new Global Stack area */
CPtr new_ls_bot ; /* bottom of new Local Stack area */
size_t heap_offset ; /* offsets between the old and new */
size_t local_offset ; /* stack bottoms, measured in Cells */
CPtr *cell_ptr ;
Cell cell_val ;
size_t i, rnum_in_trieinstr_unif_stk = (trieinstr_unif_stkptr-trieinstr_unif_stk)+1;
size_t new_size_in_bytes, new_size_in_cells ; /* what a mess ! */
double expandtime ;
if (new_size <= glstack.size) { // asked to shrink
// new_size is space needed + half of init_size, rounded to K
new_size = (((glstack.high - (byte *)top_of_localstk) +
((byte *)hreg - glstack.low)) + glstack.init_size*K/2 + (K-1)) / K;
// but not smaller than init_size
if (new_size < glstack.init_size) new_size = glstack.init_size;
if (new_size >= glstack.size) return 0; // computed new_size won't shrink
// printf("shrinking glstack from %dK to %dK\n",glstack.size,new_size);
}
// fprintf(stddbg,"Reallocating the Heap and Local Stack data area");
#ifdef DEBUG_VERBOSE
if (LOG_REALLOC <= cur_log_level) {
if (glstack.size == glstack.init_size) {
xsb_dbgmsg((LOG_REALLOC,"\tBottom:\t\t%p\t\tInitial Size: %" Intfmt "K",
glstack.low, glstack.size));
xsb_dbgmsg((LOG_REALLOC,"\tTop:\t\t%p", glstack.high));
}
}
#endif
expandtime = cpu_time();
new_size_in_bytes = new_size*K ;
new_size_in_cells = new_size_in_bytes/sizeof(Cell) ;
/* and let's hope K stays divisible by sizeof(Cell) */
stack_boundaries ;
/* Expand the data area and push the Local Stack to the high end. */
if (new_size < glstack.size) { //shrinking
// move local stack down
memmove(glstack.low + new_size_in_bytes-(glstack.high-(byte *)ls_top), // to
ls_top, // from
glstack.high - (byte *)ls_top // size
);
new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
heap_offset = new_heap_bot - heap_bot ;
new_ls_bot = new_heap_bot + new_size_in_cells - 1 ;
local_offset = new_ls_bot - ls_bot ;
} else { // expanding
if (!USER_MEMORY_LIMIT_EXHAUSTED(new_size))
new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
if (new_heap_bot == NULL) {
if (2*glstack.size == new_size) { /* if trying to double, try backing off, may not help */
size_t increment = new_size;
while (new_heap_bot == NULL && increment > 40) {
increment = increment/2;
new_size = glstack.size + increment;
new_size_in_bytes = new_size*K ;
new_size_in_cells = new_size_in_bytes/sizeof(Cell) ;
if (!USER_MEMORY_LIMIT_EXHAUSTED(new_size))
new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
}
if (new_heap_bot == NULL) {
// xsb_mesg("Not enough core to resize the Heap/Local Stack! (current: %"Intfmt"; resize %"Intfmt")",
// glstack.size*K,new_size_in_bytes);
return 1; /* return an error output -- will be picked up later */
}
} else {
xsb_mesg("Not enough core to resize the Heap and Local Stack! (%" Intfmt ")",new_size_in_bytes);
return 1; /* return an error output -- will be picked up later */
}
}
// printf("realloced heap %d -> %d\n",glstack.size,new_size);
heap_offset = new_heap_bot - heap_bot ;
new_ls_bot = new_heap_bot + new_size_in_cells - 1 ;
local_offset = new_ls_bot - ls_bot ;
#if defined(GENERAL_TAGGING)
// printf("glstack expand %p %p\n",(void *)new_heap_bot,(void *)new_ls_bot+1);
extend_enc_dec_as_nec(new_heap_bot,new_ls_bot+1);
#endif
memmove(ls_top + local_offset, /* move to */
ls_top + heap_offset, /* move from */
(ls_bot - ls_top + 1)*sizeof(Cell) ); /* number of bytes */
}
initialize_glstack(heap_top + heap_offset,ls_top+local_offset);
/* TLS: below, the condition should not need to be commented out.
If the heap expands, there should be no pointers from heap into
the local stack, so we shouldnt need to traverse the heap.
However, call subumption code actually copies the substitution
factor from the CPS to heap (I dont know why, but see the comment
after the call to subsumptive_call_search() in slginsts_xsb_i.h),
so that substitution factor pointers may point from the heap to
local stack. Therefore the pointer update causes the heap-ls
pointers to be harmless at glstack expansion.
*/
/* Update the Heap links */
// if (heap_offset != 0) {
for (cell_ptr = (CPtr *)(heap_top + heap_offset);
cell_ptr-- > (CPtr *)new_heap_bot;
)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
// }
/* Update the pointers in the Local Stack */
for (cell_ptr = (CPtr *)(ls_top + local_offset);
cell_ptr <= (CPtr *)new_ls_bot;
cell_ptr++)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
/* Update the trailed variable pointers */
for (cell_ptr = (CPtr *)top_of_trail - 1;
cell_ptr > (CPtr *)tcpstack.low;
cell_ptr = cell_ptr - 2)
{ /* first the value */
reallocate_heap_or_ls_pointer(cell_ptr);
/* now the address */
cell_ptr-- ;
cell_val = (Cell)*cell_ptr ;
#ifdef PRE_IMAGE_TRAIL
if ((size_t) cell_val & PRE_IMAGE_MARK) {
/* remove tag */
cell_val = (Cell) ((Cell) cell_val & ~PRE_IMAGE_MARK);
/* realloc and tag */
realloc_ref_pre_image(cell_ptr,(CPtr)cell_val) ;
cell_ptr--;
/* realoc pre-image */
reallocate_heap_or_ls_pointer(cell_ptr);
} else
#endif
realloc_ref(cell_ptr,(CPtr)cell_val) ;
}
/* Update the CP Stack pointers */
for (cell_ptr = (CPtr *)top_of_cpstack;
cell_ptr < (CPtr *)tcpstack.high;
cell_ptr++)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
/* Update the argument registers */
while (arity)
{ cell_ptr = (CPtr *)(reg+arity) ;
reallocate_heap_or_ls_pointer(cell_ptr) ;
arity-- ;
}
i = 0;
while (i < rnum_in_trieinstr_unif_stk) {
cell_ptr = (CPtr *)(trieinstr_unif_stk+i);
// printf(" reallocate trieinstr_unif_stk[%d]=%p\n",i,cell_ptr);
reallocate_heap_or_ls_pointer(cell_ptr) ;
i++;
}
/* Update the system variables */
glstack.low = (byte *)new_heap_bot ;
glstack.high = (byte *)(new_ls_bot + 1) ;
pspace_tot_gl = pspace_tot_gl + (new_size - glstack.size)*K;
glstack.size = new_size ;
hreg = (CPtr)hreg + heap_offset ;
hbreg = (CPtr)hbreg + heap_offset ;
hfreg = (CPtr)hfreg + heap_offset ;
ereg = (CPtr)ereg + local_offset ;
ebreg = (CPtr)ebreg + local_offset ;
efreg = (CPtr)efreg + local_offset ;
if (islist(delayreg))
delayreg = (CPtr)makelist(clref_val(delayreg) + heap_offset);
expandtime = cpu_time() - expandtime;
xsb_dbgmsg((LOG_REALLOC,"\tNew Bottom:\t%p\t\tNew Size: %" Intfmt "K",
glstack.low, glstack.size));
xsb_dbgmsg((LOG_REALLOC,"\tNew Top:\t%p", glstack.high));
xsb_dbgmsg((LOG_REALLOC,
"Heap/Local Stack data area expansion - finished in %lf secs\n",
expandtime));
return 0;
} /* glstack_realloc */
string emitCode(Form* form/*, emissionContext ctx = Bottom*/)
{
string out;
if(form == NULL)
error(form,"Can't emit code for the null form.");
else if(isatom(form))
{
switch(analyze(val(form)))
{
case BooleanTrue:
{
out = constant(get_unique_res("i1"),"i1","true");
break;
}
case BooleanFalse:
{
out = constant(get_unique_res("i1"),"i1","false");
break;
}
case Integer:
{
out = constant(get_unique_res("i64"),"i64",val(form));
break;
}
case Character:
{
string c = string(val(form),1,val(form).length()-2);
string address = "@___string" + to_string<unsigned long>(++string_version);
push(address + " = global [2 x i8] c\"" + c + "\0\0\"");
out += get_unique_res("i8") + " = load i8* getelementptr inbounds ([2 x i8]* " + address + ", i32 0, i64 0)";
break;
}
case Real:
{
out = constant(get_unique_res("double"),"double",val(form));
break;
}
case String:
{
//Remember strings come with their double quotes
//Also convert them to unicode
string str = cutboth(val(form));
unsigned long length = str.length();
stringstream ss;
string result;
for(unsigned long i = 0; i < str.length(); i++)
{
string tmp;
if(str[i] == '\\')
{
//Oh goodness, escape sequences
i++;
switch(str[i])
{
case 'n':
ss << "0A";
break;
case '\\':
ss << "5C";
break;
case '"':
ss << "22";
break;
case '0':
ss << "00";
break;
case 'a':
ss << "07";
break;
case 'b':
ss << "08";
break;
case 'f':
ss << "0C";
break;
case 'r':
ss << "0D";
break;
case 't':
ss << "09";
break;
case 'v':
ss << "0B";
break;
case 'x':
//TODO: Manage hex input
break;
case 'o':
//TODO: Manage octal input
break;
case 'U':
//TODO: Great, a unicode codepoint...
break;
default:
error(form,"Unknown character escape sequence.");
}
length--;
}
else
{
ss << hex << (int)str[i];
}
tmp = ss.str();
if(tmp.length() > 2)
{
tmp = string(tmp,tmp.length()-2);
}
result += '\\' + tmp;
//cerr << "Result: " << result << endl;
}
string type = "[" + to_string<unsigned long>(length+1) + " x i8]";
push("@___string" + to_string<unsigned long>(++string_version) + " = global " + type + " c\"" + result + "\\00\"");
out = get_unique_res("i8*") + " = getelementptr " + type + "* @___string" + to_string<unsigned long>(string_version) + ", i64 0, i64 0";
break;
}
case Symbol:
{
string sym = val(form);
Variable* tmp = lookup(sym);
if(tmp == NULL)
error_unbound(form);
else
out = load(get_unique_res_address(tmp->type,tmp->address,true),tmp->type,((tmp->global) ? "@" : "%")
+ sym+to_string(tmp->scope_address));
break;
}
case Unidentifiable:
{
error(form,"Received an unidentifiable form as input.");
break;
}
}
}
else
{
if(islist(car(form)))
error(form,"Lists can't be used as function names in calls. Until I implement lambda.");
string func = val(car(form));
map<string,hFuncPtr>::iterator seeker = Core.find(func);
if(seeker != Core.end())
out = seeker->second(form);
else
out = callFunction(form);
}
return out+"\n";
}
expr *eval(scope *scope, expr *e) {
if (e == NULL)
return NULL;
switch (e->type) {
// String and Integer expressions evaluate to themselves.
case STRING_EXPR:
case INT_EXPR:
case FUNC_EXPR:
case BUILTIN_EXPR:
case BOOL_EXPR:
return e;
case SYMBOL_EXPR: {
expr *value = scope_lookup(scope, e->string_value);
// if (!value)
// PANIC("Symbol %s not bound to any value\n", e->string_value);
return value;
}
case CELL_EXPR: {
expr *head = eval(scope, e->head);
if (head == NULL)
PANIC("() is not a function.");
if (head->type == BUILTIN_EXPR) {
// Call the built-in construct.
return head->func_ptr(scope, e->tail);
} else if (head->type == FUNC_EXPR) {
// Call the function.
struct scope *new_scope = scope_create(head->closure);
if (islist(head->arguments)) {
expr *actuals = e->tail;
for (expr *formal = head->arguments; formal != NULL; formal = formal->tail) {
expr *formal_expr = formal->head;
assert(formal_expr->type == SYMBOL_EXPR);
if (actuals != NULL) {
// If this is a regular function, evaluate the argument. Otherwise, return expression,
// Since macros take in their arguments literally.
expr *actual_value = head->ismacro ? actuals->head : eval(scope, actuals->head);
// Bind the actual value to the formal symbol.
scope_add_mapping(new_scope, formal_expr->string_value, actual_value);
// Proceed to the next actual.
actuals = actuals->tail;
} else {
// No more actuals, so simply bind the symbol to the empty list (NIL).
scope_add_mapping(new_scope, formal_expr->string_value, NULL);
}
}
} else if (issymbol(head->arguments)) {
if (head->ismacro)
scope_add_mapping(new_scope, head->arguments->string_value, e->tail);
else
scope_add_mapping(new_scope, head->arguments->string_value, eval_varargs(scope, e->tail));
}
// Evaulate the body of the function
struct expr *last_value = NULL;
for (struct expr *statement = head->body; statement != NULL; statement = statement->tail) {
last_value = eval(new_scope, statement->head);
}
// If this is a regular function, we simply return the result.
return head->ismacro ? eval(scope, last_value) : last_value;
} else {
PANIC("Tried to execute something which is not a function or a macro.");
}
}
default:
PANIC("Unkown expression type.\n");
}
}
/* XSB string substitution entry point
In:
Arg1: string
Arg2: beginning offset
Arg3: ending offset. `_' or -1: end of string, -2: char before last, etc.
Out:
Arg4: new (output) string
Always succeeds, unless error.
*/
xsbBool substring(CTXTdecl)
{
/* Prolog args are first assigned to these, so we could examine the types
of these objects to determine if we got strings or atoms. */
prolog_term input_term, output_term;
prolog_term beg_offset_term, end_offset_term;
char *input_string=NULL; /* string where matches are to be found */
Integer beg_offset=0, end_offset=0, input_len=0, substring_len=0;
int conversion_required=FALSE;
XSB_StrSet(&output_buffer,"");
input_term = reg_term(CTXTc 1); /* Arg1: string to find matches in */
if (isatom(input_term)) /* check it */
input_string = string_val(input_term);
else if (islist(input_term)) {
input_string = p_charlist_to_c_string(CTXTc input_term, &input_buffer,
"SUBSTRING", "input string");
conversion_required = TRUE;
} else
xsb_abort("[SUBSTRING] Arg 1 (the input string) must be an atom or a character list");
input_len = strlen(input_string);
/* arg 2: beginning offset */
beg_offset_term = reg_term(CTXTc 2);
if (! (isointeger(beg_offset_term)))
xsb_abort("[SUBSTRING] Arg 2 (the beginning offset) must be an integer");
beg_offset = oint_val(beg_offset_term);
if (beg_offset < 0)
beg_offset = 0;
else if (beg_offset > input_len)
beg_offset = input_len;
/* arg 3: ending offset */
end_offset_term = reg_term(CTXTc 3);
if (isref(end_offset_term))
end_offset = input_len;
else if (! (isointeger(end_offset_term)))
xsb_abort("[SUBSTRING] Arg 3 (the end offset) must be integer or _");
else end_offset = oint_val(end_offset_term);
if (end_offset < 0)
end_offset = input_len + 1 + end_offset;
else if (end_offset > input_len)
end_offset = input_len;
else if (end_offset < beg_offset)
end_offset = beg_offset;
output_term = reg_term(CTXTc 4);
if (! isref(output_term))
xsb_abort("[SUBSTRING] Arg 4 (the output string) must be an unbound variable");
/* do the actual replacement */
substring_len = end_offset-beg_offset;
XSB_StrAppendBlk(&output_buffer, input_string+beg_offset, (int)substring_len);
XSB_StrNullTerminate(&output_buffer);
/* get result out */
if (conversion_required)
c_string_to_p_charlist(CTXTc output_buffer.string, output_term,
4, "SUBSTRING", "Arg 4");
else
c2p_string(CTXTc output_buffer.string, output_term);
return(TRUE);
}
/*
* break a collection of markdown input into
* blocks of lists, code, html, and text to
* be marked up.
*/
static Paragraph *
compile(Line *ptr, int toplevel, MMIOT *f)
{
ParagraphRoot d = { 0, 0 };
Paragraph *p = 0;
Line *r;
int para = toplevel;
int blocks = 0;
int hdr_type, list_type, list_class, indent;
ptr = consume(ptr, ¶);
while ( ptr ) {
if ( iscode(ptr) ) {
p = Pp(&d, ptr, CODE);
if ( f->flags & MKD_1_COMPAT) {
/* HORRIBLE STANDARDS KLUDGE: the first line of every block
* has trailing whitespace trimmed off.
*/
___mkd_tidy(&p->text->text);
}
ptr = codeblock(p);
}
#if WITH_FENCED_CODE
else if ( iscodefence(ptr,3,0) && (p=fencedcodeblock(&d, &ptr)) )
/* yay, it's already done */ ;
#endif
else if ( ishr(ptr) ) {
p = Pp(&d, 0, HR);
r = ptr;
ptr = ptr->next;
___mkd_freeLine(r);
}
else if ( list_class = islist(ptr, &indent, f->flags, &list_type) ) {
if ( list_class == DL ) {
p = Pp(&d, ptr, DL);
ptr = definition_block(p, indent, f, list_type);
}
else {
p = Pp(&d, ptr, list_type);
ptr = enumerated_block(p, indent, f, list_class);
}
}
else if ( isquote(ptr) ) {
p = Pp(&d, ptr, QUOTE);
ptr = quoteblock(p, f->flags);
p->down = compile(p->text, 1, f);
p->text = 0;
}
else if ( ishdr(ptr, &hdr_type) ) {
p = Pp(&d, ptr, HDR);
ptr = headerblock(p, hdr_type);
}
else {
p = Pp(&d, ptr, MARKUP);
ptr = textblock(p, toplevel, f->flags);
/* tables are a special kind of paragraph */
if ( actually_a_table(f, p->text) )
p->typ = TABLE;
}
if ( (para||toplevel) && !p->align )
p->align = PARA;
blocks++;
para = toplevel || (blocks > 1);
ptr = consume(ptr, ¶);
if ( para && !p->align )
p->align = PARA;
}
return T(d);
}
/* TLS: making a conservative guess at which system calls need to be
mutexed. I'm doing it whenever I see the process table altered or
affected, so this is the data structure that its protecting.
At some point, the SET_FILEPTRs should be protected against other
threads closing that stream. Perhaps for such things a
thread-specific stream table should be used.
*/
xsbBool sys_system(CTXTdeclc int callno)
{
// int pid;
Integer pid;
switch (callno) {
case PLAIN_SYSTEM_CALL: /* dumb system call: no communication with XSB */
/* this call is superseded by shell and isn't used */
ctop_int(CTXTc 3, system(ptoc_string(CTXTc 2)));
return TRUE;
case SLEEP_FOR_SECS:
#ifdef WIN_NT
Sleep((int)iso_ptoc_int_arg(CTXTc 2,"sleep/1",1) * 1000);
#else
sleep(iso_ptoc_int_arg(CTXTc 2,"sleep/1",1));
#endif
return TRUE;
case GET_TMP_FILENAME:
ctop_string(CTXTc 2,tempnam(NULL,NULL));
return TRUE;
case IS_PLAIN_FILE:
case IS_DIRECTORY:
case STAT_FILE_TIME:
case STAT_FILE_SIZE:
return file_stat(CTXTc callno, ptoc_longstring(CTXTc 2));
case EXEC: {
#ifdef HAVE_EXECVP
/* execs a new process in place of XSB */
char *params[MAX_SUBPROC_PARAMS+2];
prolog_term cmdspec_term;
int index = 0;
cmdspec_term = reg_term(CTXTc 2);
if (islist(cmdspec_term)) {
prolog_term temp, head;
char *string_head=NULL;
if (isnil(cmdspec_term))
xsb_abort("[exec] Arg 1 must not be an empty list.");
temp = cmdspec_term;
do {
head = p2p_car(temp);
temp = p2p_cdr(temp);
if (isstring(head))
string_head = string_val(head);
else
xsb_abort("[exec] non-string argument passed in list.");
params[index++] = string_head;
if (index > MAX_SUBPROC_PARAMS)
xsb_abort("[exec] Too many arguments.");
} while (!isnil(temp));
params[index] = NULL;
} else if (isstring(cmdspec_term)) {
char *string = string_val(cmdspec_term);
split_command_arguments(string, params, "exec");
} else
xsb_abort("[exec] 1st argument should be term or list of strings.");
if (execvp(params[0], params))
xsb_abort("[exec] Exec call failed.");
#else
xsb_abort("[exec] builtin not supported in this architecture.");
#endif
}
case SHELL: /* smart system call: like SPAWN_PROCESS, but returns error code
instead of PID. Uses system() rather than execvp.
Advantage: can pass arbitrary shell command. */
case SPAWN_PROCESS: { /* spawn new process, reroute stdin/out/err to XSB */
/* +CallNo=2, +ProcAndArgsList,
-StreamToProc, -StreamFromProc, -StreamFromProcStderr,
-Pid */
static int pipe_to_proc[2], pipe_from_proc[2], pipe_from_stderr[2];
int toproc_stream=-1, fromproc_stream=-1, fromproc_stderr_stream=-1;
int pid_or_status;
FILE *toprocess_fptr=NULL,
*fromprocess_fptr=NULL, *fromproc_stderr_fptr=NULL;
char *params[MAX_SUBPROC_PARAMS+2]; /* one for progname--0th member,
one for NULL termination*/
prolog_term cmdspec_term, cmdlist_temp_term;
prolog_term cmd_or_arg_term;
xsbBool toproc_needed=FALSE, fromproc_needed=FALSE, fromstderr_needed=FALSE;
char *cmd_or_arg=NULL, *shell_cmd=NULL;
int idx = 0, tbl_pos;
char *callname=NULL;
xsbBool params_are_in_a_list=FALSE;
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (callno == SPAWN_PROCESS)
callname = "spawn_process/5";
else
callname = "shell/[1,2,5]";
cmdspec_term = reg_term(CTXTc 2);
if (islist(cmdspec_term))
params_are_in_a_list = TRUE;
else if (isstring(cmdspec_term))
shell_cmd = string_val(cmdspec_term);
else if (isref(cmdspec_term))
xsb_instantiation_error(CTXTc callname,1);
else
xsb_type_error(CTXTc "atom or list e.g. [command, arg, ...]",cmdspec_term,callname,1);
// xsb_abort("[%s] Arg 1 must be an atom or a list [command, arg, ...]",
// callname);
/* the user can indicate that he doesn't want either of the streams created
by putting an atom in the corresponding argument position */
if (isref(reg_term(CTXTc 3)))
toproc_needed = TRUE;
if (isref(reg_term(CTXTc 4)))
fromproc_needed = TRUE;
if (isref(reg_term(CTXTc 5)))
fromstderr_needed = TRUE;
/* if any of the arg streams is already used by XSB, then don't create
pipes --- use these streams instead. */
if (isointeger(reg_term(CTXTc 3))) {
SET_FILEPTR(toprocess_fptr, oint_val(reg_term(CTXTc 3)));
}
if (isointeger(reg_term(CTXTc 4))) {
SET_FILEPTR(fromprocess_fptr, oint_val(reg_term(CTXTc 4)));
}
if (isointeger(reg_term(CTXTc 5))) {
SET_FILEPTR(fromproc_stderr_fptr, oint_val(reg_term(CTXTc 5)));
}
if (!isref(reg_term(CTXTc 6)))
xsb_type_error(CTXTc "variable (to return process id)",reg_term(CTXTc 6),callname,5);
// xsb_abort("[%s] Arg 5 (process id) must be a variable", callname);
if (params_are_in_a_list) {
/* fill in the params[] array */
if (isnil(cmdspec_term))
xsb_abort("[%s] Arg 1 must not be an empty list", callname);
cmdlist_temp_term = cmdspec_term;
do {
cmd_or_arg_term = p2p_car(cmdlist_temp_term);
cmdlist_temp_term = p2p_cdr(cmdlist_temp_term);
if (isstring(cmd_or_arg_term)) {
cmd_or_arg = string_val(cmd_or_arg_term);
}
else
xsb_abort("[%s] Non string list member in the Arg",
callname);
params[idx++] = cmd_or_arg;
if (idx > MAX_SUBPROC_PARAMS)
xsb_abort("[%s] Too many arguments passed to subprocess",
callname);
} while (!isnil(cmdlist_temp_term));
params[idx] = NULL; /* null termination */
} else { /* params are in a string */
if (callno == SPAWN_PROCESS)
split_command_arguments(shell_cmd, params, callname);
else {
/* if callno==SHELL => call system() => don't split shell_cmd */
params[0] = shell_cmd;
params[1] = NULL;
}
}
/* -1 means: no space left */
if ((tbl_pos = get_free_process_cell()) < 0) {
xsb_warn(CTXTc "Can't create subprocess because XSB process table is full");
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
/* params[0] is the progname */
pid_or_status = xsb_spawn(CTXTc params[0], params, callno,
(toproc_needed ? pipe_to_proc : NULL),
(fromproc_needed ? pipe_from_proc : NULL),
(fromstderr_needed ? pipe_from_stderr : NULL),
toprocess_fptr, fromprocess_fptr,
fromproc_stderr_fptr);
if (pid_or_status < 0) {
xsb_warn(CTXTc "[%s] Subprocess creation failed, Error: %d, errno: %d, Cmd: %s", callname,pid_or_status,errno,params[0]);
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
if (toproc_needed) {
toprocess_fptr = fdopen(pipe_to_proc[1], "w");
toproc_stream = xsb_intern_fileptr(CTXTc toprocess_fptr,callname,"pipe","w",CURRENT_CHARSET);
ctop_int(CTXTc 3, toproc_stream);
}
if (fromproc_needed) {
fromprocess_fptr = fdopen(pipe_from_proc[0], "r");
fromproc_stream = xsb_intern_fileptr(CTXTc fromprocess_fptr,callname,"pipe","r",CURRENT_CHARSET);
ctop_int(CTXTc 4, fromproc_stream);
}
if (fromstderr_needed) {
fromproc_stderr_fptr = fdopen(pipe_from_stderr[0], "r");
fromproc_stderr_stream
= xsb_intern_fileptr(CTXTc fromproc_stderr_fptr,callname,"pipe","r",CURRENT_CHARSET);
ctop_int(CTXTc 5, fromproc_stderr_stream);
}
ctop_int(CTXTc 6, pid_or_status);
xsb_process_table.process[tbl_pos].pid = pid_or_status;
xsb_process_table.process[tbl_pos].to_stream = toproc_stream;
xsb_process_table.process[tbl_pos].from_stream = fromproc_stream;
xsb_process_table.process[tbl_pos].stderr_stream = fromproc_stderr_stream;
concat_array(CTXTc params, " ",
xsb_process_table.process[tbl_pos].cmdline,MAX_CMD_LEN);
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
case GET_PROCESS_TABLE: { /* sys_system(3, X). X is bound to the list
of the form [process(Pid,To,From,Stderr,Cmdline), ...] */
int i;
prolog_term table_term_tail, listHead;
prolog_term table_term=reg_term(CTXTc 2);
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (!isref(table_term))
xsb_abort("[GET_PROCESS_TABLE] Arg 1 must be a variable");
table_term_tail = table_term;
for (i=0; i<MAX_SUBPROC_NUMBER; i++) {
if (!FREE_PROC_TABLE_CELL(xsb_process_table.process[i].pid)) {
c2p_list(CTXTc table_term_tail); /* make it into a list */
listHead = p2p_car(table_term_tail);
c2p_functor(CTXTc "process", 5, listHead);
c2p_int(CTXTc xsb_process_table.process[i].pid, p2p_arg(listHead,1));
c2p_int(CTXTc xsb_process_table.process[i].to_stream, p2p_arg(listHead,2));
c2p_int(CTXTc xsb_process_table.process[i].from_stream, p2p_arg(listHead,3));
c2p_int(CTXTc xsb_process_table.process[i].stderr_stream,
p2p_arg(listHead,4));
c2p_string(CTXTc xsb_process_table.process[i].cmdline, p2p_arg(listHead,5));
table_term_tail = p2p_cdr(table_term_tail);
}
}
c2p_nil(CTXTc table_term_tail); /* bind tail to nil */
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return p2p_unify(CTXTc table_term, reg_term(CTXTc 2));
}
case PROCESS_STATUS: {
prolog_term pid_term=reg_term(CTXTc 2), status_term=reg_term(CTXTc 3);
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (!(isointeger(pid_term)))
xsb_abort("[PROCESS_STATUS] Arg 1 (process id) must be an integer");
pid = (int)oint_val(pid_term);
if (!isref(status_term))
xsb_abort("[PROCESS_STATUS] Arg 2 (process status) must be a variable");
switch (process_status(pid)) {
case RUNNING:
c2p_string(CTXTc "running", status_term);
break;
case STOPPED:
c2p_string(CTXTc "stopped", status_term);
break;
case EXITED_NORMALLY:
c2p_string(CTXTc "exited_normally", status_term);
break;
case EXITED_ABNORMALLY:
c2p_string(CTXTc "exited_abnormally", status_term);
break;
case ABORTED:
c2p_string(CTXTc "aborted", status_term);
break;
case INVALID:
c2p_string(CTXTc "invalid", status_term);
break;
default:
c2p_string(CTXTc "unknown", status_term);
}
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
case PROCESS_CONTROL: {
/* sys_system(PROCESS_CONTROL, +Pid, +Signal). Signal: wait, kill */
int status;
prolog_term pid_term=reg_term(CTXTc 2), signal_term=reg_term(CTXTc 3);
SYS_MUTEX_LOCK( MUTEX_SYS_SYSTEM );
init_process_table();
if (!(isointeger(pid_term)))
xsb_abort("[PROCESS_CONTROL] Arg 1 (process id) must be an integer");
pid = (int)oint_val(pid_term);
if (isstring(signal_term) && strcmp(string_val(signal_term), "kill")==0) {
if (KILL_FAILED(pid)) {
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
#ifdef WIN_NT
CloseHandle((HANDLE) pid);
#endif
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
if (isconstr(signal_term)
&& strcmp(p2c_functor(signal_term),"wait") == 0
&& p2c_arity(signal_term)==1) {
int exit_status;
if (WAIT(pid, status) < 0) {
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return FALSE;
}
#ifdef WIN_NT
exit_status = status;
#else
if (WIFEXITED(status))
exit_status = WEXITSTATUS(status);
else
exit_status = -1;
#endif
p2p_unify(CTXTc p2p_arg(signal_term,1), makeint(exit_status));
SYS_MUTEX_UNLOCK( MUTEX_SYS_SYSTEM );
return TRUE;
}
xsb_warn(CTXTc "[PROCESS_CONTROL] Arg 2: Invalid signal specification. Must be `kill' or `wait(Var)'");
return FALSE;
}
case LIST_DIRECTORY: {
/* assume all type- and mode-checking is done in Prolog */
prolog_term handle = reg_term(CTXTc 2); /* ref for handle */
char *dir_name = ptoc_longstring(CTXTc 3); /* +directory name */
prolog_term filename = reg_term(CTXTc 4); /* reference for name of file */
if (is_var(handle))
return xsb_find_first_file(CTXTc handle,dir_name,filename);
else
return xsb_find_next_file(CTXTc handle,dir_name,filename);
}
default:
xsb_abort("[SYS_SYSTEM] Wrong call number (an XSB bug)");
} /* end case */
return TRUE;
}
/* caller must ensure enough heap space (term_size(term)*sizeof(Cell)) */
prolog_term intern_term(CTXTdeclc prolog_term term) {
Integer ti = 0;
Cell arg, newterm, interned_term, orig_term;
unsigned int subterm_index;
XSB_Deref(term);
if (!(islist(term) || isconstr(term))) {return term;}
if (isinternstr(term)) {return term;}
if (is_cyclic(CTXTc term)) {xsb_abort("Cannot intern a cyclic term\n");}
// if (!ground(term)) {return term;}
orig_term = term;
// printf("iti: ");printterm(stdout,orig_term,100);printf("\n");
if (!ts_array) {
ts_array = mem_alloc(init_ts_array_len*sizeof(*ts_array),OTHER_SPACE);
if (!ts_array) xsb_abort("No space for interning term\n");
ts_array_len = init_ts_array_len;
}
ts_array[0].term = term;
if (islist(term)) {
ts_array[0].subterm_index = 0;
ts_array[0].newterm = makelist(hreg);
hreg += 2;
}
else {
// if (isboxedinteger(term)) printf("interning boxed int\n");
// else if (isboxedfloat(term)) printf("interning boxed float %f\n",boxedfloat_val(term));
ts_array[0].subterm_index = 1;
ts_array[0].newterm = makecs(hreg);
new_heap_functor(hreg, get_str_psc(term));
hreg += get_arity(get_str_psc(term));
}
ts_array[ti].ground = 1;
while (ti >= 0) {
term = ts_array[ti].term;
newterm = ts_array[ti].newterm;
subterm_index = ts_array[ti].subterm_index;
if ((islist(term) && subterm_index >= 2) ||
(isconstr(term) && subterm_index > get_arity(get_str_psc(term)))) {
if (ts_array[ti].ground) {
interned_term = intern_rec(CTXTc newterm);
if (!interned_term) xsb_abort("error term should have been interned\n");
hreg = clref_val(newterm); // reclaim used stack space
if (!ti) {
if (compare(CTXTc (void*)orig_term,(void*)interned_term) != 0) printf("NOT SAME\n");
//printf("itg: ");printterm(stdout,interned_term,100);printf("\n");
return interned_term;
}
ti--;
get_str_arg(ts_array[ti].newterm,ts_array[ti].subterm_index-1) = interned_term;
} else {
//printf("hreg = %p, ti=%d\n",hreg,ti);
if (!ti) {
if (compare(CTXTc (void*)orig_term,(void*)newterm) != 0) printf("NOT SAME\n");
//printf("ito: ");printterm(stdout,newterm,100);printf("\n");
return newterm;
}
ti--;
get_str_arg(ts_array[ti].newterm,ts_array[ti].subterm_index-1) = newterm;
ts_array[ti].ground = 0;
}
} else {
arg = get_str_arg(term, (ts_array[ti].subterm_index)++);
XSB_Deref(arg);
switch (cell_tag(arg)) {
case XSB_FREE:
case XSB_REF1:
case XSB_ATTV:
ts_array[ti].ground = 0;
get_str_arg(newterm,subterm_index) = arg;
break;
case XSB_STRING:
if (string_find_safe(string_val(arg)) != string_val(arg)) printf("uninterned string?\n");
case XSB_INT:
case XSB_FLOAT:
get_str_arg(newterm,subterm_index) = arg;
break;
case XSB_LIST:
if (isinternstr(arg)) get_str_arg(newterm,subterm_index) = arg;
else {
ti++;
check_ts_array_overflow;
ts_array[ti].term = arg;
ts_array[ti].subterm_index = 0;
ts_array[ti].ground = 1;
ts_array[ti].newterm = makelist(hreg);
hreg += 2;
}
break;
case XSB_STRUCT:
if (isinternstr(arg)) get_str_arg(newterm,subterm_index) = arg;
else {
// if (isboxedinteger(arg)) printf("interning boxed int\n");
// else if (isboxedfloat(arg)) printf("interning boxed float %f\n",boxedfloat_val(arg));
ti++;
check_ts_array_overflow;
ts_array[ti].term = arg;
ts_array[ti].subterm_index = 1;
ts_array[ti].ground = 1;
ts_array[ti].newterm = makecs(hreg);
new_heap_functor(hreg,get_str_psc(arg));
hreg += get_arity(get_str_psc(arg));
}
}
}
}
printf("intern_term: shouldn't happen\n");
return 0;
}
/* XSB string substitution entry point: replace substrings specified in Arg2
with strings in Arg3.
In:
Arg1: string
Arg2: substring specification, a list [s(B1,E1),s(B2,E2),...]
Arg3: list of replacement strings
Out:
Arg4: new (output) string
Always succeeds, unless error.
*/
xsbBool string_substitute(CTXTdecl)
{
/* Prolog args are first assigned to these, so we could examine the types
of these objects to determine if we got strings or atoms. */
prolog_term input_term, output_term;
prolog_term subst_reg_term, subst_spec_list_term, subst_spec_list_term1;
prolog_term subst_str_term=(prolog_term)0,
subst_str_list_term, subst_str_list_term1;
char *input_string=NULL; /* string where matches are to be found */
char *subst_string=NULL;
prolog_term beg_term, end_term;
Integer beg_offset=0, end_offset=0, input_len;
Integer last_pos = 0; /* last scanned pos in input string */
/* the output buffer is made large enough to include the input string and the
substitution string. */
int conversion_required=FALSE; /* from C string to Prolog char list */
XSB_StrSet(&output_buffer,"");
input_term = reg_term(CTXTc 1); /* Arg1: string to find matches in */
if (isatom(input_term)) /* check it */
input_string = string_val(input_term);
else if (islist(input_term)) {
input_string = p_charlist_to_c_string(CTXTc input_term, &input_buffer,
"STRING_SUBSTITUTE", "input string");
conversion_required = TRUE;
} else
xsb_abort("[STRING_SUBSTITUTE] Arg 1 (the input string) must be an atom or a character list");
input_len = strlen(input_string);
/* arg 2: substring specification */
subst_spec_list_term = reg_term(CTXTc 2);
if (!islist(subst_spec_list_term) && !isnil(subst_spec_list_term))
xsb_abort("[STRING_SUBSTITUTE] Arg 2 must be a list [s(B1,E1),s(B2,E2),...]");
/* handle substitution string */
subst_str_list_term = reg_term(CTXTc 3);
if (! islist(subst_str_list_term))
xsb_abort("[STRING_SUBSTITUTE] Arg 3 must be a list of strings");
output_term = reg_term(CTXTc 4);
if (! isref(output_term))
xsb_abort("[STRING_SUBSTITUTE] Arg 4 (the output) must be an unbound variable");
subst_spec_list_term1 = subst_spec_list_term;
subst_str_list_term1 = subst_str_list_term;
if (isnil(subst_spec_list_term1)) {
XSB_StrSet(&output_buffer, input_string);
goto EXIT;
}
if (isnil(subst_str_list_term1))
xsb_abort("[STRING_SUBSTITUTE] Arg 3 must not be an empty list");
do {
subst_reg_term = p2p_car(subst_spec_list_term1);
subst_spec_list_term1 = p2p_cdr(subst_spec_list_term1);
if (!isnil(subst_str_list_term1)) {
subst_str_term = p2p_car(subst_str_list_term1);
subst_str_list_term1 = p2p_cdr(subst_str_list_term1);
if (isatom(subst_str_term)) {
subst_string = string_val(subst_str_term);
} else if (islist(subst_str_term)) {
subst_string = p_charlist_to_c_string(CTXTc subst_str_term, &subst_buf,
"STRING_SUBSTITUTE",
"substitution string");
} else
xsb_abort("[STRING_SUBSTITUTE] Arg 3 must be a list of strings");
}
beg_term = p2p_arg(subst_reg_term,1);
end_term = p2p_arg(subst_reg_term,2);
if (!(isointeger(beg_term)) ||
!(isointeger(end_term)))
xsb_abort("[STRING_SUBSTITUTE] Non-integer in Arg 2");
else {
beg_offset = oint_val(beg_term);
end_offset = oint_val(end_term);
}
/* -1 means end of string */
if (end_offset < 0)
end_offset = input_len;
if ((end_offset < beg_offset) || (beg_offset < last_pos))
xsb_abort("[STRING_SUBSTITUTE] Substitution regions in Arg 2 not sorted");
/* do the actual replacement */
XSB_StrAppendBlk(&output_buffer,input_string+last_pos,(int)(beg_offset-last_pos));
XSB_StrAppend(&output_buffer, subst_string);
last_pos = end_offset;
} while (!isnil(subst_spec_list_term1));
XSB_StrAppend(&output_buffer, input_string+end_offset);
EXIT:
/* get result out */
if (conversion_required)
c_string_to_p_charlist(CTXTc output_buffer.string, output_term,
4, "STRING_SUBSTITUTE", "Arg 4");
else
c2p_string(CTXTc output_buffer.string, output_term);
return(TRUE);
}
int compare(CTXTdeclc const void * v1, const void * v2)
{
int comp;
CPtr cptr1, cptr2;
Cell val1 = (Cell) v1 ;
Cell val2 = (Cell) v2 ;
XSB_Deref(val2); /* val2 is not in register! */
XSB_Deref(val1); /* val1 is not in register! */
if (val1 == val2) return 0;
switch(cell_tag(val1)) {
case XSB_FREE:
case XSB_REF1:
if (isattv(val2))
return vptr(val1) - (CPtr)dec_addr(val2);
else if (isnonvar(val2)) return -1;
else { /* in case there exist local stack variables in the */
/* comparison, globalize them to guarantee that their */
/* order is retained as long as nobody "touches" them */
/* in the future -- without copying garbage collection */
if ((top_of_localstk <= vptr(val1)) &&
(vptr(val1) <= (CPtr)glstack.high-1)) {
bld_free(hreg);
bind_ref(vptr(val1), hreg);
hreg++;
val1 = follow(val1); /* deref again */
}
if ((top_of_localstk <= vptr(val2)) &&
(vptr(val2) <= (CPtr)glstack.high-1)) {
bld_free(hreg);
bind_ref(vptr(val2), hreg);
hreg++;
val2 = follow(val2); /* deref again */
}
return vptr(val1) - vptr(val2);
}
case XSB_FLOAT:
if (isref(val2) || isattv(val2)) return 1;
else if (isofloat(val2))
return sign(float_val(val1) - ofloat_val(val2));
else return -1;
case XSB_INT:
if (isref(val2) || isofloat(val2) || isattv(val2)) return 1;
else if (isinteger(val2))
return int_val(val1) - int_val(val2);
else if (isboxedinteger(val2))
return int_val(val1) - boxedint_val(val2);
else return -1;
case XSB_STRING:
if (isref(val2) || isofloat(val2) || isinteger(val2) || isattv(val2))
return 1;
else if (isstring(val2)) {
return strcmp(string_val(val1), string_val(val2));
}
else return -1;
case XSB_STRUCT:
// below, first 2 if-checks test to see if this struct is actually a number representation,
// (boxed float or boxed int) and if so, does what the number case would do, only with boxed_val
// macros.
if (isboxedinteger(val1)) {
if (isref(val2) || isofloat(val2) || isattv(val2)) return 1;
else if (isinteger(val2))
return boxedint_val(val1) - int_val(val2);
else if (isboxedinteger(val2))
return boxedint_val(val1) - boxedint_val(val2);
else return -1;
} else if (isboxedfloat(val1)) {
if (isref(val2) || isattv(val2)) return 1;
else if (isofloat(val2))
return sign(boxedfloat_val(val1) - ofloat_val(val2));
else return -1;
} else if (cell_tag(val2) != XSB_STRUCT && cell_tag(val2) != XSB_LIST) return 1;
else {
int arity1, arity2;
Psc ptr1 = get_str_psc(val1);
Psc ptr2 = get_str_psc(val2);
arity1 = get_arity(ptr1);
if (islist(val2)) arity2 = 2;
else arity2 = get_arity(ptr2);
if (arity1 != arity2) return arity1-arity2;
if (islist(val2)) comp = strcmp(get_name(ptr1), ".");
else comp = strcmp(get_name(ptr1), get_name(ptr2));
if (comp || (arity1 == 0)) return comp;
cptr1 = clref_val(val1);
cptr2 = clref_val(val2);
for (arity2 = 1; arity2 <= arity1; arity2++) {
if (islist(val2))
comp = compare(CTXTc (void*)cell(cptr1+arity2), (void*)cell(cptr2+arity2-1));
else
comp = compare(CTXTc (void*)cell(cptr1+arity2), (void*)cell(cptr2+arity2));
if (comp) break;
}
return comp;
}
break;
case XSB_LIST:
if (cell_tag(val2) != XSB_STRUCT && cell_tag(val2) != XSB_LIST) return 1;
else if (isconstr(val2)) return -(compare(CTXTc (void*)val2, (void*)val1));
else { /* Here we are comparing two list structures. */
cptr1 = clref_val(val1);
cptr2 = clref_val(val2);
comp = compare(CTXTc (void*)cell(cptr1), (void*)cell(cptr2));
if (comp) return comp;
return compare(CTXTc (void*)cell(cptr1+1), (void*)cell(cptr2+1));
}
break;
case XSB_ATTV:
if (isattv(val2))
return (CPtr)dec_addr(val1) - (CPtr)dec_addr(val2);
else if (isref(val2))
return (CPtr)dec_addr(val1) - vptr(val2);
else
return -1;
default:
xsb_abort("Compare (unknown tag %ld); returning 0", cell_tag(val1));
return 0;
}
}
xsbBool glstack_realloc(int new_size, int arity)
{
CPtr new_heap_bot ; /* bottom of new Global Stack area */
CPtr new_ls_bot ; /* bottom of new Local Stack area */
long heap_offset ; /* offsets between the old and new */
long local_offset ; /* stack bottoms, measured in Cells */
CPtr *cell_ptr ;
Cell cell_val ;
size_t new_size_in_bytes, new_size_in_cells ; /* what a mess ! */
long expandtime ;
if (new_size <= glstack.size) return 0;
xsb_dbgmsg((LOG_REALLOC,
"Reallocating the Heap and Local Stack data area"));
#ifdef DEBUG_VERBOSE
if (LOG_REALLOC <= cur_log_level) {
if (glstack.size == glstack.init_size) {
xsb_dbgmsg((LOG_REALLOC,"\tBottom:\t\t%p\t\tInitial Size: %ldK",
glstack.low, glstack.size));
xsb_dbgmsg((LOG_REALLOC,"\tTop:\t\t%p", glstack.high));
}
}
#endif
expandtime = (long)(1000*cpu_time()) ;
new_size_in_bytes = new_size*K ;
new_size_in_cells = new_size_in_bytes/sizeof(Cell) ;
/* and let's hope K stays divisible by sizeof(Cell) */
stack_boundaries ;
/* Expand the data area and push the Local Stack to the high end. */
new_heap_bot = (CPtr)realloc(heap_bot, new_size_in_bytes);
if (new_heap_bot == NULL) {
xsb_mesg("Not enough core to resize the Heap and Local Stack!");
return 1; /* return an error output -- will be picked up later */
}
heap_offset = new_heap_bot - heap_bot ;
new_ls_bot = new_heap_bot + new_size_in_cells - 1 ;
local_offset = new_ls_bot - ls_bot ;
memmove(ls_top + local_offset, /* move to */
ls_top + heap_offset, /* move from */
(ls_bot - ls_top + 1)*sizeof(Cell) ); /* number of bytes */
/* Update the Heap links */
for (cell_ptr = (CPtr *)(heap_top + heap_offset);
cell_ptr-- > (CPtr *)new_heap_bot;
)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
/* Update the pointers in the Local Stack */
for (cell_ptr = (CPtr *)(ls_top + local_offset);
cell_ptr <= (CPtr *)new_ls_bot;
cell_ptr++)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
/* Update the trailed variable pointers */
for (cell_ptr = (CPtr *)top_of_trail - 1;
cell_ptr > (CPtr *)tcpstack.low;
cell_ptr = cell_ptr - 2)
{ /* first the value */
reallocate_heap_or_ls_pointer(cell_ptr);
/* now the address */
cell_ptr-- ;
cell_val = (Cell)*cell_ptr ;
realloc_ref(cell_ptr,(CPtr)cell_val) ;
}
/* Update the CP Stack pointers */
for (cell_ptr = (CPtr *)top_of_cpstack;
cell_ptr < (CPtr *)tcpstack.high;
cell_ptr++)
{ reallocate_heap_or_ls_pointer(cell_ptr) ; }
/* Update the argument registers */
while (arity)
{ cell_ptr = (CPtr *)(reg+arity) ;
reallocate_heap_or_ls_pointer(cell_ptr) ;
arity-- ;
}
/* Update the system variables */
glstack.low = (byte *)new_heap_bot ;
glstack.high = (byte *)(new_ls_bot + 1) ;
glstack.size = new_size ;
hreg = (CPtr)hreg + heap_offset ;
hbreg = (CPtr)hbreg + heap_offset ;
hfreg = (CPtr)hfreg + heap_offset ;
ereg = (CPtr)ereg + local_offset ;
ebreg = (CPtr)ebreg + local_offset ;
efreg = (CPtr)efreg + local_offset ;
if (islist(delayreg))
delayreg = (CPtr)makelist(clref_val(delayreg) + heap_offset);
expandtime = (long)(1000*cpu_time()) - expandtime;
xsb_dbgmsg((LOG_REALLOC,"\tNew Bottom:\t%p\t\tNew Size: %ldK",
glstack.low, glstack.size));
xsb_dbgmsg((LOG_REALLOC,"\tNew Top:\t%p", glstack.high));
xsb_dbgmsg((LOG_REALLOC,
"Heap/Local Stack data area expansion - finished in %ld msecs\n",
expandtime));
return 0;
} /* glstack_realloc */
/*
* break a collection of markdown input into
* blocks of lists, code, html, and text to
* be marked up.
*/
static Paragraph *
compile(Line *ptr, int toplevel, MMIOT *f)
{
ParagraphRoot d = { 0, 0 };
Paragraph *p = 0;
Line *r;
int para = toplevel;
int blocks = 0;
int hdr_type, list_type, list_class, indent;
ptr = consume(ptr, ¶);
while ( ptr ) {
if ( iscode(ptr) ) {
p = Pp(&d, ptr, CODE);
if ( f->flags & MKD_1_COMPAT) {
/* HORRIBLE STANDARDS KLUDGE: the first line of every block
* has trailing whitespace trimmed off.
*/
___mkd_tidy(&p->text->text);
}
ptr = codeblock(p);
}
else if ( ishr(ptr) ) {
p = Pp(&d, 0, HR);
r = ptr;
ptr = ptr->next;
___mkd_freeLine(r);
}
else if (( list_class = islist(ptr, &indent, f->flags, &list_type) )) {
if ( list_class == DL ) {
p = Pp(&d, ptr, DL);
ptr = definition_block(p, indent, f, list_type);
}
else {
p = Pp(&d, ptr, list_type);
ptr = enumerated_block(p, indent, f, list_class);
}
}
else if ( isquote(ptr) ) {
p = Pp(&d, ptr, QUOTE);
ptr = quoteblock(p, f->flags);
p->down = compile(p->text, 1, f);
p->text = 0;
}
else if ( ishdr(ptr, &hdr_type) ) {
p = Pp(&d, ptr, HDR);
ptr = headerblock(p, hdr_type);
}
else if ( istable(ptr) && !(f->flags & (MKD_STRICT|MKD_NOTABLES)) ) {
p = Pp(&d, ptr, TABLE);
ptr = tableblock(p);
}
else {
p = Pp(&d, ptr, MARKUP);
ptr = textblock(p, toplevel, f->flags);
}
if ( (para||toplevel) && !p->align )
p->align = PARA;
blocks++;
para = toplevel || (blocks > 1);
ptr = consume(ptr, ¶);
if ( para && !p->align )
p->align = PARA;
}
return T(d);
}
