int
p_diff_vars(value v1, type t1, value v2, type t2)
{
if (IsRef(t1) && IsRef(t2) && v1.ptr != v2.ptr)
{
Mark_Suspending_Variable(v1.ptr);
Mark_Suspending_Variable(v2.ptr);
Succeed;
}
else
Fail;
}
static
p_char_int(value chval, type chtag, value ival, type itag)
{
/* Case of: converting an integer to a character. */
if (IsRef(chtag))
{
value v;
register char *s;
if (IsRef(itag))
{ Bip_Error(PDELAY_1_2); }
else if (!IsInteger(itag))
{ Bip_Error(TYPE_ERROR); }
if ((ival.nint < 0) || (ival.nint > 255))
{
Bip_Error(RANGE_ERROR)
}
Make_Stack_String(1, v, s);
*s++ = ival.nint;
*s = '\0';
Return_Unify_String(chval, chtag, v.ptr);
}
else if (IsString(chtag) && StringLength(chval) == 1)
GMC_DCL(tp_FilHdr, FilHdr)
{
tp_FilHdr DestElmFH, OrigElmFH;
tp_LocElm LocElm;
tp_FilElm FilElm;
tps_Str StrBuf;
if (FilHdr_Flag(OrigFilHdr, FLAG_Union)) {
return; }/*if*/;
Set_Flag(OrigFilHdr, FLAG_Union);
if (!IsRef(OrigFilHdr)) {
DestElmFH = Copy_FilHdr(DestFilHdr);
DestElmFH = Do_Key(DestElmFH, FilHdr_Label(StrBuf, OrigFilHdr, FALSE));
LocElm = Make_CopyLocElm(OrigFilHdr, DestElmFH, FilHdr);
Chain_LocElms(FirstLEPtr, LastLEPtr, LocElm);
Ret_FilHdr(DestElmFH);
return; }/*if*/;
for (FilElm = LocElm_FilElm(FilHdr_LocElm(OrigFilHdr));
FilElm != NIL;
FilElm = FilElm_NextFilElm(FilElm)) {
OrigElmFH = FilElm_FilHdr(FilElm);
Get_CopyList(FirstLEPtr, LastLEPtr, OrigElmFH, DestFilHdr, FilHdr);
Ret_FilHdr(OrigElmFH); }/*for*/;
}/*Get_CopyList*/
GMC_DCL(tp_FilHdr, ListFilHdr)
{
tp_FilHdr ElmFilHdr;
tp_LocElm LocElm;
tp_FilElm FilElm;
if (IsViewSpec(FilHdr)) {
FilHdr_Error("Illegal view specification argument: %s\n", FilHdr);
return; }/*if*/;
if (FilHdr_Flag(FilHdr, FLAG_Union)) {
return; }/*if*/;
Set_Flag(FilHdr, FLAG_Union);
if (!IsRef(FilHdr)) {
ElmFilHdr = Do_Deriv(Copy_FilHdr(FilHdr), RootFilPrm, FilPrm, FilTyp);
/*select*/{
if (ElmFilHdr != ERROR) {
LocElm = Make_LocElm(ElmFilHdr, RootFilPrm, ListFilHdr);
Chain_LocElms(FirstLEPtr, LastLEPtr, LocElm);
Ret_FilHdr(ElmFilHdr);
}else{
FilHdr_Error(" from:\n %s.\n", FilHdr); };}/*select*/;
return; }/*if*/;
for (FilElm = LocElm_FilElm(FilHdr_LocElm(FilHdr));
FilElm != NIL;
FilElm = FilElm_NextFilElm(FilElm)) {
ElmFilHdr = FilElm_FilHdr(FilElm);
Get_Map(FirstLEPtr, LastLEPtr, ElmFilHdr,
Append_FilPrm(FilElm_FilPrm(FilElm), FilPrm),
FilTyp, ListFilHdr);
Ret_FilHdr(ElmFilHdr); }/*for*/;
}/*Get_Map*/
Value& Value::operator=(const Value& v) {
if(this == &v) return *this;
FreeRef();
data = v.data;
if(IsRef())
ptr()->Retain();
return *this;
}
static int
p_atom_length(value aval, type atag, value nval, type ntag)
{
Check_Output_Integer(ntag);
if (IsRef(atag))
{ Bip_Error(PDELAY_1); }
Check_Output_Atom_Or_Nil(aval, atag);
Return_Unify_Integer(nval, ntag, DidLength(aval.did));
}
Value& Value::operator=(const Value& v) {
if(this == &v) return *this;
Value h = v; // Make copy a 'v' can be reference to ValueMap/Array contained element
FreeRef(); // e.g. json = json["foo"]
data = h.data;
if(IsRef())
ptr()->Retain();
return *this;
}
static int
p_string_length(value sval, type stag, value nval, type ntag)
{
Check_Output_Integer(ntag);
if (IsRef(stag))
{ Bip_Error(PDELAY_1); }
else if (!IsString(stag))
{ Bip_Error(TYPE_ERROR); }
Return_Unify_Integer(nval, ntag, StringLength(sval));
}
int
p_atomd(value v1, type t1)
{
if (IsRef(t1))
{
Mark_Suspending_Variable(v1.ptr);
Delay;
}
else
Succeed_If(IsAtom(t1));
}
Vec &Vec::operator =(const Vec2 &v) {
if (!IsRef())
SetSize(v.Elts());
else
Assert(Elts() == v.Elts(), "(Vec::=) Vector sizes don't match");
data[0] = v[0];
data[1] = v[1];
return (*this);
}
Mat &Mat::operator = (const Mat &m)
{
if (!IsRef())
SetSize(m.Rows(), m.Cols());
else
Assert(Rows() == m.Rows(), "(Mat::=) Matrix rows don't match");
for (Int i = 0; i < Rows(); i++)
SELF[i] = m[i];
return(SELF);
}
/*
legal_current_op(?Precedence, ?Assoc, +Operator_atom, +Module)
checks that all arguments are valid for current_op_body/4.
*/
static int
p_legal_current_op(value v_prec, type t_prec, value v_assoc, type t_assoc, value v_op, type t_op, value v_mod, type t_mod)
{
if (!IsRef(t_op)) /* Operator name */
{
Check_Atom_Or_Nil(v_op, t_op);
#ifdef lint
/* v_op is set in Check_Atom_Or_Nil but not used */
if (v_op.nint) return v_op.nint;
#endif /* lint */
}
Check_Module(t_mod, v_mod); /* module */
Check_Module_Access(v_mod, t_mod);
if (IsAtom(t_assoc)) /* Associativity */
{
word iassoc = _get_assoc(v_assoc.did);
if (iassoc == NIL_OP ||
(iassoc > FXX && (ModuleSyntax(v_mod.did)->options & ISO_RESTRICTIONS)))
{
Bip_Error(RANGE_ERROR);
}
}
else if (!IsRef(t_assoc))
{
Bip_Error(TYPE_ERROR);
}
if (IsInteger(t_prec)) /* Precedence */
{
if (v_prec.nint < 0 || v_prec.nint > 1200)
{
Bip_Error(RANGE_ERROR);
}
}
else if (!IsRef(t_prec))
{
Bip_Error(TYPE_ERROR);
}
Succeed_;
}
void String::LFree()
{
if(IsRef()) {
if(ptr != VoidPtr()) {
Rc *rc = Ref();
ASSERT(rc->refcount > 0);
if(AtomicDec(rc->refcount) == 0) MFree(rc);
}
}
else
MFree_S(ptr);
}
void String0::LFree()
{
if(IsRef()) {
if(ptr != (char *)(voidptr + 1)) {
Rc *rc = Ref();
ASSERT(rc->refcount > 0);
if(AtomicDec(rc->refcount) == 0) MFree(rc);
}
}
else
MFree_S(ptr);
}
static int
p_default_module(value v, type t)
{
if (IsRef(t)) {
pword pw;
pw.val.did = d_.default_module;
pw.tag.kernel = ModuleTag(d_.default_module);
Return_Unify_Pw(v, t, pw.val, pw.tag);
}
Check_Module_And_Access(v, t);
d_.default_module = v.did;
Succeed_;
}
double Expression::Parse(const string& token, vector<vector<Expression> >& sSheet, deque<double>& terms) {
if (token.length() == 0) {
throw runtime_error("Parsing failed: please trim whitespace");
} else if (IsVal(token)) {
return atof(token.c_str());
} else if (IsRef(token)) {
return Deref(token, sSheet);
} else if (IsOp(token)) {
return Oper(token, terms);
} else {
throw runtime_error("Parsing failed with: " + token);
}
}
Vec &Vec::operator =(const Vec &v) {
if (!IsRef())
SetSize(v.Elts());
else
Assert(Elts() == v.Elts(), "(Vec::=) Vector sizes don't match");
#ifdef VL_USE_MEMCPY
memcpy(data, v.data, sizeof (double) * Elts());
#else
for (int i = 0; i < Elts(); i++)
data[i] = v[i];
#endif
return (*this);
}
static int
p_tool_body(value vi, type ti, value vb, type tb, value vmb, type tmb, value vm, type tm)
{
dident di;
pri *procb, *proci;
int flags, arity;
dident module;
dident pdid;
pword *ptr = Gbl_Tg;
vmcode *code;
int err;
Prepare_Requests;
Check_Module(tm, vm);
Get_Proc_Did(vi, ti, di);
if (!IsRef(tb)
&& (!IsStructure(tb)
|| vb.ptr->val.did != d_.quotient))
{
Bip_Error(TYPE_ERROR);
}
Check_Output_Atom_Or_Nil(vmb, tmb);
if (!(proci = visible_procedure(di, vm.did, tm, PRI_CREATE)))
{
Get_Bip_Error(err);
Bip_Error(err);
}
if (!_tool_body(proci, &pdid, &arity, &module))
{
Get_Bip_Error(err);
Bip_Error(err);
}
Gbl_Tg += 3;
Check_Gc;
ptr[0].tag.kernel = TDICT;
ptr[0].val.did = d_.quotient;
ptr[1].tag.kernel = TDICT;
ptr[1].val.did = add_dict(pdid, 0);
ptr[2].tag.kernel = TINT;
ptr[2].val.nint = arity;
Request_Unify_Atom(vmb, tmb, module);
Request_Unify_Structure(vb, tb, ptr);
Return_Unify;
}
static int
p_shelf_get(value vhandle, type thandle, value vi, type ti, value vval, type tval, value vmod, type tmod)
{
t_heap_array *obj;
pword pw;
pw.val = vval;
pw.tag = tval;
Get_Shelf(vhandle, thandle, vmod, tmod, obj);
Check_Integer(ti);
if (vi.nint < 0 || vi.nint > DidArity(obj->array[0].val.did))
{ Bip_Error(RANGE_ERROR); }
pw = _heap_arr_get(obj, vi.nint);
if (IsRef(pw.tag))
{
Succeed_; /* nothing to unify */
}
Return_Unify_Pw(vval, tval, pw.val, pw.tag);
}
static void expr_stack(void)
{
#ifdef DEBUG
int i;char *c;
printf("Stack: \n");
for (i=0; i<ces->tos; i++) {
if (IsRef(ces->vl[i]->type)) c="\tRef"; else
if (IsConst(ces->vl[i]->type)) c="\tCon"; else c="\t ";
printf("%s %x ", c, ces->vl[i]->type&0x1fff);
switch (ces->vl[i]->type) {
case (ToRefType(IntType)): printf("(%i)\n", *ces->vl[i]->val.iref); break;
case (ToConstType(IntType)):
case (IntType): printf("(%i)\n", ces->vl[i]->val.ival); break;
default: printf("\n"); break;
}
}
#endif
}
void Vec::SetSize(int ni) {
Assert(ni > 0, "(Vec::SetSize) Illegal vector size");
unsigned int n = (unsigned int) ni;
if (!IsRef()) {
// Don't doublelocate if we already have enough storage
if (n <= elts) {
elts = n;
return;
}
// Otherwise, delete old storage
delete[] data;
elts = n;
data = new double[elts];
} else
Assert(false, "(Vec::SetSize) Can't resize a vector reference");
}
/*ARGSUSED*/
static int
p_get_oracle3(value vfrom, type tfrom, value vto, type tto, value v, type t)
{
pword *b_aux;
char *buf;
int size;
if (IsRef(tto))
{
b_aux = B.args;
while (!IsParallelFrame(BTop(b_aux)))
b_aux = BPrev(b_aux);
}
else
b_aux = vto.ptr;
size = oracle_size(vfrom.ptr, b_aux);
buf = (char *) hp_alloc(size);
retrieve_oracle(buf, size, vfrom.ptr, b_aux);
Return_Unify_Integer(v, t, (long) buf);
}
void String0::LCat(int c)
{
if(IsSmall()) {
qword *x = (qword *)MAlloc_S();
x[0] = q[0];
x[1] = q[1];
LLen() = SLen();
SLen() = 15;
chr[KIND] = MEDIUM;
qptr = x;
}
int l = LLen();
if(IsRef() ? !IsShared() && l < (int)Ref()->alloc : l < 31) {
ptr[l] = c;
ptr[LLen() = l + 1] = 0;
}
else {
char *s = Insert(l, 1, NULL);
s[0] = c;
s[1] = 0;
}
}
Void Mat::SetSize(Int nrows, Int ncols)
{
UInt elts = nrows * ncols;
Assert(nrows > 0 && ncols > 0, "(Mat::SetSize) Illegal matrix size.");
UInt oldElts = Rows() * Cols();
if (IsRef())
{
// Abort! We don't allow this operation on references.
_Error("(Mat::SetSize) Trying to resize a matrix reference");
}
rows = nrows;
cols = ncols;
// Don't reallocate if we already have enough storage
if (elts <= oldElts)
return;
// Otherwise, delete old storage and reallocate
delete[] data;
data = 0;
data = new Real[elts]; // may throw an exception
}
pword *
term_to_dbformat(pword *parg, dident mod)
{
pword **save_tt = TT;
register word arity = 1, len;
register word curr_offset = 0, top_offset = 2; /* in 'word's */
register pword *queue_tail = (pword *) 0;
pword *queue_head = (pword *) 0;
register pword *pw;
register char *dest, *stop;
pword *header;
temp_area meta_attr;
int flag = 0;
Temp_Create(meta_attr, 4 * ATTR_IO_TERM_SIZE * sizeof(pword));
header = TG;
dest = (char *) (header + 1) + 4; /* space for the TBUFFER pword and for
* the external format header */
for(;;) /* handle <arity> consecutive pwords, starting at <parg> */
{
do /* handle the pword pointed to by parg */
{
pw = parg;
/* I need here a slightly modified version of Dereference_(pw)
* that stops also at MARKed words. Not very nice, I know.
*/
while (IsRef(pw->tag) && !(pw->tag.kernel & MARK) && !IsSelfRef(pw))
pw = pw->val.ptr;
Reserve_Space(6);
if (pw->tag.kernel & MARK)
{
if (SameTypeC(pw->tag,TDE)) /* a suspension */
{
Store_Byte(Tag(pw->tag.kernel));
Store_Int32((pw[SUSP_FLAGS].tag.kernel & ~MARK));
if (SuspDead(pw)) {
curr_offset += Words(SUSP_HEADER_SIZE-1);
parg += SUSP_HEADER_SIZE-1;
arity -= SUSP_HEADER_SIZE-1;
} else {
Store_Byte(SuspPrio(pw) + (SuspRunPrio(pw) << 4));
curr_offset += Words(SUSP_GOAL-1);
parg += SUSP_GOAL-1;
arity -= SUSP_GOAL-1;
}
}
else if (pw->val.nint == curr_offset) /* a nonstd variable */
{
Store_Byte(Tag(pw->tag.kernel));
Store_Int(pw->val.nint);
if (!IsNamed(pw->tag.kernel))
{
Store_Byte(0);
}
else /* store its name */
{
dident vdid = TagDid(pw->tag.kernel);
len = DidLength(vdid);
Store_Int(len);
Reserve_Space(len);
Store_String(len, DidName(vdid));
}
}
else /* just a reference to an already encountered variable */
{
Store_Byte(Tag(TVAR_TAG));
Store_Int(pw->val.nint);
}
}
else switch (TagType(pw->tag))
{
case TINT:
#if SIZEOF_CHAR_P > 4
if (pw->val.nint < WSUF(-2147483648) || WSUF(2147483648) <= pw->val.nint)
{
/* store as a bignum (to be readable on 32bit machines) */
len = tag_desc[pw->tag.kernel].string_size(pw->val, pw->tag, 1);
Store_Byte(TBIG);
Store_Int(len);
Reserve_Space(len+1);
stop = dest+len;
dest += tag_desc[pw->tag.kernel].to_string(pw->val, pw->tag,
dest, 1);
while (dest <= stop) /* pad and terminate */
*dest++ = 0;
break;
}
#endif
Store_Byte(TINT);
#ifdef OLD_FORMAT
Store_Int32(pw->val.nint);
#else
Store_Int(pw->val.nint);
#endif
break;
case TNIL:
Store_Byte(Tag(pw->tag.kernel));
break;
case TDICT:
len = DidLength(pw->val.did);
Store_Byte(TDICT);
Store_Int(DidArity(pw->val.did));
Store_Int(len);
Reserve_Space(len);
Store_String(len, DidName(pw->val.did));
break;
case TDBL:
{
ieee_double d;
d.as_dbl = Dbl(pw->val);
Store_Byte(TDBL);
Store_Byte(sizeof(double)-1); /* backward compat */
Reserve_Space(sizeof(double));
Store_Int32(d.as_struct.mant1);
Store_Int32(d.as_struct.mant0);
break;
}
case TIVL:
{
ieee_double dlwb, dupb;
dlwb.as_dbl = IvlLwb(pw->val.ptr);
dupb.as_dbl = IvlUpb(pw->val.ptr);
Store_Byte(TIVL);
Reserve_Space(2*sizeof(double));
Store_Int32(dlwb.as_struct.mant1);
Store_Int32(dlwb.as_struct.mant0);
Store_Int32(dupb.as_struct.mant1);
Store_Int32(dupb.as_struct.mant0);
break;
}
case TSTRG:
len = StringLength(pw->val);
Store_Byte(TSTRG);
Store_Int(len);
Reserve_Space(len);
Store_String(len, StringStart(pw->val));
break;
case TVAR_TAG: /* standard variable */
Store_Byte(Tag(TVAR_TAG));
Store_Int(curr_offset);
Trail_(pw);
pw->val.nint = curr_offset;
pw->tag.kernel |= MARK;
break;
case TNAME:
case TUNIV:
Store_Byte(Tag(TVAR_TAG));
Store_Int(top_offset);
Trail_Tag(pw);
pw->val.nint = top_offset;
pw->tag.kernel |= MARK;
top_offset += 2;
EnQueue_(pw, 1, 0);
break;
case TMETA:
Store_Byte(Tag(TVAR_TAG));
Store_Int(top_offset);
Trail_Tag(pw);
pw->val.nint = top_offset;
pw->tag.kernel |= MARK;
top_offset += 4;
EnQueue_(pw, 2, QUEUE_MASK_META);
break;
case TSUSP:
Store_Byte(Tag(TSUSP));
pw = pw->val.ptr;
if (pw->tag.kernel & MARK) /* not the first encounter */
{
Store_Int(pw->val.nint);
}
else
{
Store_Int(top_offset);
Trail_Pword(pw);
pw->tag.kernel |= MARK;
pw->val.nint = top_offset;
if (SuspDead(pw))
{
top_offset += Words(SUSP_HEADER_SIZE); /* for TDE */
EnQueue_(pw, SUSP_HEADER_SIZE, 0);
}
else
{
top_offset += Words(SUSP_SIZE); /* for TDE */
EnQueue_(pw, SUSP_SIZE, 0);
}
}
break;
case TLIST:
Store_Byte(Tag(TLIST));
Store_Int(top_offset);
top_offset += 4;
EnQueue_(pw->val.ptr, 2, 0);
break;
case TCOMP:
Store_Byte(Tag(TCOMP));
Store_Int(top_offset);
if (flag) {
pword pw_out;
(void) transf_meta_out(pw->val, pw->tag,
(pword *) TempAlloc(meta_attr, ATTR_IO_TERM_SIZE * sizeof(pword)),
D_UNKNOWN, &pw_out);
pw = pw_out.val.ptr;
len = 1 + DidArity(pw->val.did);
EnQueue_(pw, len, 0);
} else {
len = 1 + DidArity(pw->val.ptr->val.did);
EnQueue_(pw->val.ptr, len, 0);
}
top_offset += 2*len;
break;
default:
if (TagType(pw->tag) >= 0 && TagType(pw->tag) <= NTYPES)
{
len = tag_desc[TagType(pw->tag)].string_size(pw->val, pw->tag, 1);
Store_Byte(Tag(pw->tag.kernel));
Store_Int(len);
Reserve_Space(len+1);
stop = dest+len;
dest += tag_desc[TagType(pw->tag)].to_string(pw->val, pw->tag,
dest, 1);
while (dest <= stop) /* pad and terminate */
*dest++ = 0;
}
else
{
p_fprintf(current_err_,
"bad type in term_to_dbformat: 0x%x\n",
pw->tag.kernel);
}
break;
}
curr_offset += Words(1);
++parg;
} while (--arity);
if (EmptyQueue())
break;
DeQueue_(parg, arity, flag);
}
/* # bytes of external representation */
Store_Byte(0); /* add a terminating 0 */
Set_Buffer_Size(header, dest - (char*) header - sizeof(pword));
header->tag.kernel = TBUFFER;
Align(); /* align the global stack pointer */
TG = (pword *) dest;
dest = (char *) (header + 1); /* fill in the external format header */
Store_Int32(top_offset); /* (size of term after restoring) */
Untrail_Variables(save_tt);
Temp_Destroy(meta_attr);
return header;
}
static int
p_string_list(value vs, type ts, value vl, type tl)
{
register pword *pw, *list;
register char *s;
register int len;
pword *old_tg = Gbl_Tg;
if (IsRef(ts)) /* no string given */
{
if (IsRef(tl)) /* we need at least one */
{
Bip_Error(PDELAY_1_2);
}
else if (IsList(tl)) /* make a string from a list */
{
list = vl.ptr; /* space for the string header */
Push_Buffer(1); /* make minimum buffer */
s = (char *) BufferStart(old_tg); /* start of the new string */
for(;;) /* loop through the list */
{
pw = list++;
Dereference_(pw); /* get the list element */
if (IsRef(pw->tag)) /* check it */
{
Gbl_Tg = old_tg;
Push_var_delay(vs.ptr, ts.all);
Push_var_delay(pw, pw->tag.all);
Bip_Error(PDELAY);
}
else if (!IsInteger(pw->tag))
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
else if (pw->val.nint < 0 || pw->val.nint > 255)
{
Gbl_Tg = old_tg;
Bip_Error(RANGE_ERROR);
}
*s++ = pw->val.nint;
if (s == (char *) Gbl_Tg) /* we need another pword */
{
Gbl_Tg += 1;
Check_Gc;
}
Dereference_(list); /* get the list tail */
if (IsRef(list->tag))
{
Gbl_Tg = old_tg;
Push_var_delay(vs.ptr, ts.all);
Push_var_delay(list, list->tag.all);
Bip_Error(PDELAY);
}
else if (IsList(list->tag))
list = list->val.ptr;
else if (IsNil(list->tag))
break; /* end of the list */
else
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
}
*s = '\0'; /* terminate the string */
Set_Buffer_Size(old_tg, s - (char *)(old_tg + 1) + 1);
Kill_DE;
Return_Unify_String(vs, ts, old_tg);
}
else if (IsNil(tl))
{
Kill_DE;
Return_Unify_String(vs, ts, empty_string);
}
else
{
Bip_Error(TYPE_ERROR);
}
}
else if (IsString(ts))
{
Kill_DE;
Check_Output_List(tl);
s = StringStart(vs); /* get a pointer to the string */
len = StringLength(vs);
if (len == 0)
{
Return_Unify_Nil(vl, tl);
}
/* Additional a-priori overflow check because adding to TG may
* may wrap around the address space and break Check_Gc below
*/
Check_Available_Pwords(2*len);
pw = Gbl_Tg; /* reserve space for the list */
Gbl_Tg += 2*len;
Check_Gc;
pw->val.nint = *s++ & 0xFFL; /* construct the list */
pw++->tag.kernel = TINT;
while (--len > 0)
{
pw->val.ptr = pw + 1;
pw++->tag.kernel = TLIST;
pw->val.nint = *s++ & 0xFFL;
pw++->tag.kernel = TINT;
}
pw->tag.kernel = TNIL;
Return_Unify_List(vl, tl, old_tg);
}
else
{
Bip_Error(TYPE_ERROR);
}
}
Vec::~Vec() {
if (!IsRef())
delete[] data;
}
static int
p_text_to_string(value v, type t, value vs, type ts)
{
pword *pw, *list;
char *s;
int len;
pword *old_tg = Gbl_Tg;
if (IsRef(t))
{
Bip_Error(PDELAY_1);
}
if (IsString(t))
{
Kill_DE;
Return_Unify_Pw(v, t, vs, ts);
}
if (IsAtom(t)) /* not including [] ! */
{
Kill_DE;
Return_Unify_String(vs, ts, DidString(v.did));
}
if (IsNil(t))
{
Kill_DE;
Return_Unify_String(vs, ts, empty_string);
}
if (IsList(t)) /* make a string from a list */
{
int element_type = 0;
list = v.ptr; /* space for the string header */
Push_Buffer(1); /* make minimum buffer */
s = (char *) BufferStart(old_tg); /* start of the new string */
for(;;) /* loop through the list */
{
int c;
pw = list++;
Dereference_(pw); /* get the list element */
if (IsRef(pw->tag)) /* check it */
{
Gbl_Tg = old_tg;
Push_var_delay(vs.ptr, ts.all);
Push_var_delay(pw, pw->tag.all);
Bip_Error(PDELAY);
}
else if (IsInteger(pw->tag)) /* char code */
{
element_type |= 1;
c = pw->val.nint;
if (c < 0 || 255 < c)
{
Gbl_Tg = old_tg;
Bip_Error(RANGE_ERROR);
}
}
else if (IsAtom(pw->tag)) /* char atom */
{
element_type |= 2;
if (DidLength(pw->val.did) != 1)
{
Gbl_Tg = old_tg;
Bip_Error(RANGE_ERROR);
}
c = DidName(pw->val.did)[0];
}
else
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
*s++ = c;
if (s == (char *) Gbl_Tg) /* we need another pword */
{
Gbl_Tg += 1;
Check_Gc;
}
Dereference_(list); /* get the list tail */
if (IsRef(list->tag))
{
Gbl_Tg = old_tg;
Push_var_delay(vs.ptr, ts.all);
Push_var_delay(list, list->tag.all);
Bip_Error(PDELAY);
}
else if (IsList(list->tag))
list = list->val.ptr;
else if (IsNil(list->tag))
break; /* end of the list */
else
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
}
if (element_type != 1 && element_type != 2) /* mixed type list? */
{
Gbl_Tg = old_tg;
Bip_Error(TYPE_ERROR);
}
*s = '\0'; /* terminate the string */
Set_Buffer_Size(old_tg, s - (char *)(old_tg + 1) + 1);
Kill_DE;
Return_Unify_String(vs, ts, old_tg);
}
Bip_Error(TYPE_ERROR);
}
static int
p_substring(value val1, type tag1, value val2, type tag2, value valp, type tagp)
{
char *p1, *p2;
word length1, length2;
word i, j;
/* string1 and string2 must be strings; posn an integer/variable. */
Check_Output_Integer(tagp);
Check_Output_String(tag1);
Check_String(tag2);
Error_If_Ref(tag1);
length1 = StringLength(val1);
length2 = StringLength(val2);
if (!IsRef(tagp))
{
if (valp.nint <= 0 || valp.nint > length1 + 1)
{
Bip_Error(RANGE_ERROR);
}
if (valp.nint > length1 - length2 + 1)
{
Fail_; /* string 2 is too long to match */
}
p1 = StringStart(val1) + valp.nint - 1;
p2 = StringStart(val2);
for(j = 0; j < length2; ++j)
{
if (p1[j] != p2[j])
{
Fail_;
}
}
Succeed_;
}
else
{
p1 = StringStart(val1);
p2 = StringStart(val2);
for (i = 1; i <= length1 - length2 + 1; i++)
{
/*
* search through p (i.e. string1) 'length2' characters
* at a time for val2.str (i.e. string2), till the end
* of string1.
*/
for(j = 0; j < length2; ++j)
{
if (p1[j] != p2[j])
break;
}
if (j == length2)
{
Return_Unify_Integer(valp, tagp, i);
}
p1++;
}
/* if not found, fail. */
Fail_;
}
}
bool String::IsVoid() const
{
return IsRef() && ptr == (char *)(voidptr + 1);
}
