/************************************************************************ * * * The SB-Prolog System * * Copyright SUNY at Stony Brook, 1986 * * * ************************************************************************/ /*----------------------------------------------------------------- SB-Prolog is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY. No author or distributor accepts responsibility to anyone for the consequences of using it or for whether it serves any particular purpose or works at all, unless he says so in writing. Refer to the SB-Prolog General Public License for full details. Everyone is granted permission to copy, modify and redistribute SB-Prolog, but only under the conditions described in the SB-Prolog General Public License. A copy of this license is supposed to have been given to you along with SB-Prolog so you can know your rights and responsibilities. It should be in a file named COPYING. Among other things, the copyright notice and this notice must be preserved on all copies. ------------------------------------------------------------------ */ #include "builtin.h" #define BACKWARDS 0 /* Direction parameter=0 means backwards, */ /* !=0 means forwards */ #define get_e_length(ptr) (get_length(ptr) < 65535 ? \ (word)get_length(ptr) : *(pw)(get_name(ptr)-4)) extern struct psc_rec *insert(); static byte perm = PERM; static byte temp = TEMP; /* create a psc_entry on the heap. Len = 4 */ word makenullbuff() { word addr; struct psc_rec *ptr; *hreg = (word)(hreg + 1); /* fake first of pair */ addr = (word)hreg++; ptr = (struct psc_rec *)hreg; get_etype(ptr) = T_BUFF; get_arity(ptr) = 0; hreg += 2; /* no ep and no hash link */ get_name(ptr) = (char *)hreg; get_length(ptr) = 0; return(addr | CS_TAG); } b_ALLOC_BUFF() /* r1 = size; r2 = Buffer, r3 = 0=>perm, 1=>heap, 2=>subbuff r4 = Super-Buffer if there is one r5 = Retcode */ { /* long lengths (>= 65535) are kept in 4 bytes immediately preceeding the name */ register pw top; register word op1, op3, op4; struct psc_rec *ptr, *pptr; long rc, size, len, disp; pw loc; word addr; /* r1 should be bound to a number; r2 is free */ op1 = gregc(1); deref(op1); size = intval(op1); op3 = gregc(3); deref(op3); rc = 0; switch ((int)(intval(op3))) { case 0: /* perm */ alloc_perm(size,&addr); /* addr: ptr to struct node for buff */ if (!unify(gregc(2), (addr | CS_TAG))) {Fail0;} break; case 1: /* heap */ addr = makenullbuff(); ptr = get_str_psc(addr); if (size < 65535) get_length(ptr) = size; else {get_length(ptr) = 65535; *hreg++ = size;} get_name(ptr) = (char *) hreg; hreg += (size+3) >> 2; *(pw)(get_name(ptr)) = 4; /* disp of next free */ if (!unify(gregc(2), (addr | CS_TAG))) {Fail0;} break; case 2: /* subbuffer */ op4 = gregc(4); deref(op4); /* super buffer */ ptr = get_str_psc(op4); len = get_e_length(ptr); disp = *(pw)(get_name(ptr)); /* printf("disp %d\n", disp); */ loc = (pw)(get_name(ptr)+disp); /* printf("disp: %d, size: %d, len: %d\n", disp, size, len); */ if (disp+12+size>len) rc = 1; else { *loc = (word)(loc+1); addr = (word)loc++; pptr = (struct psc_rec *)loc; get_etype(pptr) = T_BUFF; get_arity(pptr) = 0; loc += 2; /*no ep, no hash link*/ if (size < 65535) get_length(pptr) = size; else {get_length(pptr) = 65535; *loc++ = size;} get_name(pptr) = (char *) loc; *(pw)(get_name(pptr)) = 4; /* disp of next free */ loc += (size+3) >> 2; disp = (word)(((char *)loc) - get_name(ptr)); *(pw)(get_name(ptr)) = disp; if (!unify(gregc(2), (addr | CS_TAG))) {Fail0;} } } if (!unify(gregc(5), makeint(rc))) {Fail0;} } /* b_BUFF_CODE inserts a word into, or extracts a word from, a buffer. It is VERY low-level and implementation dependent. It is used to generate byte-code into a buffer, and retrieve a word from a buffer. On entry, r1 is bound to a buffer, r2 is the offset in the buffer, r3 contains a number indicating what internal word to generate, r4 contains a term from which the word to insert in the buffer is extracted, or a variable that is bound to the word extracted from the buffer */ b_BUFF_CODE() { struct psc_rec *ptr, *pscptr4; FILE *fdes; int disc, disp, i, arity; char s[100]; word tempvar, temp1, temp2; register word op1, op4; register pw top; op4 = gregc(1); deref(op4); if (!isconstr(op4)) {errmsg(11); Fail0; return;} ptr = get_str_psc(op4); op4 = gregc(2); deref(op4); disp = intval(op4); op4 = gregc(3); deref(op4); disc = intval(op4); op4 = gregc(4); deref(op4); switch (disc) { case 0: /* ppsc: constant/structure, untagged psc_ptr to buff */ /* make permanent if could be dangling pointer */ if ((word)get_name(ptr)<(word)get_str_psc(op4)) { pscptr4 = get_str_psc(op4); op4 = (word)insert(get_name(pscptr4), get_length(pscptr4), get_arity(pscptr4), &perm) | CS_TAG; } *(pw)(get_name(ptr)+disp) = (word)(get_str_psc(op4)); break; case 1: /* pppsc: cons/struc, untagged ptr to psc_ptr to buff */ /* make permanent if could be dangling pointer */ if ((word)get_name(ptr)<(word)untagged(op4)) { pscptr4 = get_str_psc(op4); op4 = (word)insert(get_name(pscptr4), get_length(pscptr4), get_arity(pscptr4), &perm); } *(pw)(get_name(ptr)+disp) = untagged(op4); break; case 2: /* pn: number, untagged word value to buff */ *(pw)(get_name(ptr)+disp) = intval(op4); break; case 3: /* pb: number, untagged byte value to buff */ *(byte *)(get_name(ptr)+disp) = intval(op4); break; case 4: /* ga: return address of location in buffer, as tagged num */ if (!unify(op4, makeint(get_name(ptr)+disp))) {Fail0;} break; case 5: /* gn: return word at location in buffer, as tagged num */ if (!unify(op4, makeint(*(pw)(get_name(ptr)+disp)))) {Fail0;} break; case 6: /* gb: return byte at location in buffer, as tagged num */ if (!unify(op4, makeint(*(byte *)(get_name(ptr)+disp)))) {Fail0;} break; case 7: /* gepb: return buff that 1st arg pred ep points to */ /* assumes ep points to 2nd word in buff, first is ptr to its own psc_ptr */ if (!unify(op4, *(pw)(get_ep(ptr)-4))) {Fail0;} break; case 8: /* gpb: return buff that word at disp-buff points to */ if (!unify(op4, *(pw)((*(pw)(get_name(ptr)+disp))-4))) {Fail0;} break; case 9: /* pep: set ep of term to point to 4th byte in buff */ get_ep(ptr) = (byte *)(get_name(get_str_psc(op4))+4); get_etype(ptr) = T_DYNA; /* and set 1st word of buff to point to buff psc ptr */ /* *(pw)get_name(get_str_psc(op4)) = op4; */ break; case 10: /* pbr: set word p points to 4th byte in buff */ *(char **)(get_name(ptr)+disp) = get_name(get_str_psc(op4))+4; /* and set 1st word of buff to point to buff psc ptr */ /* *(pw)get_name(get_str_psc(op4)) = op4; */ break; case 11: /* rep: reset ep of first arg to undefined */ if (is_PRED(ptr) || is_DYNA(ptr)) { get_ep(ptr) = 0; get_etype(ptr) = T_ORDI; } break; case 12: /* fv: free variable to buff, for use with getival instr */ temp1 = (word)(get_name(ptr)+disp); if (!(temp1&3)) follow(temp1) = temp1; else { curr_fence = (byte *)(((int)curr_fence + 3) & 0xfffffffc); follow(temp1) = (word)curr_fence; follow(curr_fence) = (word)curr_fence; curr_fence += 4; } break; case 13: /* execb: branch into buffer, using 4th arg as call */ pcreg = (pb)(get_name(ptr)+disp); arity = get_arity(get_str_psc(op4)); untag(op4); for ( i=1; i<=arity; i++) /*??++i??*/ gregc(i) = follow((pw)op4+i); break; case 14: /* ptv: number or const, tagged word value to buff */ /* make permanent if could be dangling pointer */ if (isconstr(op4) && (word)get_name(ptr)<(word)untagged(op4)) { pscptr4 = get_str_psc(op4); op4 = (word)((long)insert(get_name(pscptr4), get_length(pscptr4), get_arity(pscptr4), &perm) | CS_TAG); } *(pw)(get_name(ptr)+disp) = op4; break; case 15: /* ptp: put str-tagged pointer to second location */ *(pw)(get_name(ptr)+disp) = (word)((long)(get_name(ptr)+intval(op4)) | CS_TAG); break; case 16: /* ptl: put list-tagged pointer to second location */ *(pw)(get_name(ptr)+disp) = (word)((long)(get_name(ptr)+intval(op4)) | LIST_TAG); break; case 17: /* pvar: put variable into buffer */ tempvar = (word)(get_name(ptr)+disp); follow(tempvar) = tempvar; if (op4 >= (word)get_name(ptr) && op4 <= (word)(get_name(ptr)+get_e_length(ptr))) /* already points into the buffer */ follow(op4) = tempvar; /* point word to it */ else { follow(op4) = tempvar; pushtrail(op4); /* and trail! */ } break; case 18: /* ubv: unify value with buffer */ if (!unify(get_name(ptr)+disp, op4)) {Fail0;} break; case 19: /* cep: copy ep of last arg to ep of first */ pscptr4 = get_str_psc(op4); if (!is_BUFF(ptr)) { get_ep(ptr) = get_ep(pscptr4); get_etype(ptr) = get_etype(pscptr4); } break; case 20: /* pepb: copy ep of last arg to loc in buff */ pscptr4 = get_str_psc(op4); follow(get_name(ptr)+disp) = (word)(get_ep(pscptr4)); break; case 21: /*gnb: return next buffer along the hash chain */ op1 = *(pw)(get_name(ptr) + disp); op1 = *(pw)(op1 + 8) - 10; if (!unify(op4, *(pw)op1)) {Fail0;} break; case 22: /*dis: disassemble buffer for debugging assert */ /*op1: buffer; op2: 0 for "w" 1 for "a"; op4: filename */ pscptr4 = get_str_psc(op4); temp1 = (word)pcreg; temp2 = num_line; num_line = 1; namestring(pscptr4, s); if (disp == 0) fdes = fopen(s, "w"); else fdes = fopen(s, "a"); fprintf(fdes, "\n /* New Buffer Below: pscptr, arity, length, nameptr, backptr *\/\n\n"); fprintf(fdes, "%x, %d, %d, %x, %x \n", ptr, get_arity(ptr), get_length(ptr), get_name(ptr), get_ep(ptr)); pcreg = (byte *)(get_name(ptr) + 4); while (pcreg < (byte *)(get_name(ptr) + get_length(ptr))) print_inst(fdes, pcreg); fflush(fdes); fclose(fdes); pcreg = (byte *)temp1; num_line = temp2; break; case 23: /* ps: short number, untagged word value to buff */ *(short *)(get_name(ptr)+disp) = intval(op4); break; case 24: /* gs: return short number at location in buffer, as tagged num */ if (!unify(op4, makeint(*(short *)(get_name(ptr)+disp)))) {Fail0;} break; case 25: /* bb: build a buffer for a pointer in a buffer, 0 len */ temp1 = makenullbuff(); pscptr4 = get_str_psc(temp1); get_name(pscptr4) = *(char **)(get_name(ptr)+disp); if (!unify(op4, temp1)) {Fail0;} break; case 26: /* pba: put buffer address into buffer */ pscptr4 = get_str_psc(op4); follow(get_name(ptr)+disp) = (word)(get_name(pscptr4)); break; case 27: /* pf: put float (in WAM format, word) into buffer */ *(pw)(get_name(ptr)+disp) = op4; break; } } b_TRIMBUFF() /* reg1 : new length (if <0 scan for 0x00) reg2 : buffer reg3 : 0 => perm, 1 => temp, 2 => temp in superbuff (r4) reg4 : superbuff to trim (if 2) */ { struct psc_rec *ptr, *bptr; register word op, op1, op3; long len; register pw top; op3 = gregc(3); deref(op3); op3 = intval(op3); op = gregc(2); deref(op); ptr = get_str_psc(op); op1 = gregc(1); deref(op1); len = intval(op1); if (len<0) {if (get_name(ptr)) len = strlen(get_name(ptr)); else {Fail0;} } else if (op3 == 0) { /* perm */ if (curr_fence == (byte *)(get_name(ptr) + get_length(ptr))) curr_fence = (byte *)(get_name(ptr) + len); } else if (op3 == 1) { /* heap */ if (hreg == (pw)(get_name(ptr) + get_e_length(ptr))) hreg = (pw)(get_name(ptr) + len); } else { /* in superbuffer */ op = gregc(4); deref(op); bptr = get_str_psc(op); if ((word)get_name(bptr)+*(pw)get_name(bptr) == (word)get_name(ptr) + get_e_length(ptr)) *(pw)(get_name(bptr)) = /* new disp */ (((word)get_name(ptr)+len-(word)get_name(bptr))+3)&0xfffffffc; } if (get_length(ptr) < 65535) get_length(ptr) = len; else *(pw)(get_name(ptr)-4) = len; } b_SUBSTRING() /* reg1 = direction (forwards for read, backwards for write) reg2 = numbytes reg3 = Internal constant reg4 = Initial location in the input buffer reg5 = Input Buffer (must be a valid constant) reg6 = Final location in the input buffer after reading from or writing into the buffer /* Forwards: If the internal constant parameter is free upon entry, it takes the first numbytes of the input buffer and creates an internal constant. Reg 6 gets bound to the location in the input buffer directly following the constant. If the constant parameter is already bound, it is checked against the one in the buffer to see if they unify. The numbytes parameter must unify with the length of the constant. Backwards: Binds numbytes(if not bound) to the length of the internal constant. Copies the internal constant into the Input Buffer, and returns in reg 6 an index into the input buffer which directly follows the constant. */ { /* define local variables */ char *Bnameptr, *Cnameptr; /* Buffer Nameptr, Constant Nameptr */ struct psc_rec *buff_psc; /* pointer to psc rec of buffer */ struct psc_rec *addr; /* Holds result from insert */ int offset, /* Offset into buffer */ numbytes, /* Numbytes in buffer for constant */ i; /* Counter */ word op1, op2, op3, op4, op5; register pw top; op1 = gregc(1); deref(op1); /* direction */ op2 = gregc(2); /* length */ op3 = gregc(3); deref(op3); /* constant substring */ op4 = gregc(4); deref(op4); /* offset */ op5 = gregc(5); deref(op5); /* constant, long string */ /* check the direction param for error */ if (!isinteger(op1)) {errmsg(0); Fail0; return;} /* check input buffer - ?valid constant */ if (!isatom(op5)) {errmsg(8); Fail0; return;} buff_psc = get_str_psc(op5); /* check that offset is valid */ if (!isinteger(op4)) {errmsg(2); Fail0; return;} offset = intval(op4); if ((get_length(buff_psc) < offset) || (offset < 0)) {errmsg(3); Fail0; return;} /* get length of substring */ if ((isatom(op3)) && (!unify(op2, makeint(get_length(get_str_psc(op3)))))) {Fail0; return;} deref(op2); if (!isinteger(op2)) {errmsg(4); Fail0; return;} numbytes = intval(op2); /* check no buffer overflow */ if ((numbytes < 0) || ((offset+numbytes) > get_length(buff_psc))) {errmsg(3); Fail0; return;} if (intval(op1) != BACKWARDS) { /* find the constant, or insert a new one */ temp = TEMP; addr = insert(get_name(buff_psc)+offset,numbytes,0,&temp); /*&perm*/ if (!unify(op3, (word)addr | CS_TAG)) {Fail0; return;} } else {/* going backwards */ Bnameptr = get_name(buff_psc); if (!isatom(op3)) {errmsg(5); Fail0; return;} Cnameptr = get_name(get_str_psc(op3)); for (i=0; i get_length(buff_psc))) {errmsg(3); Fail0; return;} if (intval(op1) != BACKWARDS) { /* get numeric equivalent out */ num = getnum(numbytes,get_name(buff_psc)+offset); if (!(unify(op3, makeint(num)))) /* unify reg3 with number */ {Fail0; return;} } else { /* going backwards */ if (!isinteger(op3)) {errmsg(6); /* no number to be written */ Fail0; return;} num = intval(op3); /* get number to be written */ Bnameptr = get_name(buff_psc); /* get buffer name pointer */ itoa(num,s); /* make s string representing num */ xtra = numbytes - strlen(s); /* number of leading zeros */ if (xtra < 0) {errmsg(10); Fail0; return;} /* number too large */ for (i=0; i< xtra; i++) /* put leading zeros in if any */ Bnameptr[i+offset] = '0'; for (i = xtra; i < strlen(s) + xtra; i++)/* put character rep of */ Bnameptr[i+offset] = s[(i-xtra)]; /* number into buffer*/ } /* check or set out location */ if (!unify(gregc(6), makeint(offset+numbytes))) {Fail0;} } b_SUBDELIM() /* reg1 = direction (forwards for read, backwards for write ) reg2 = delimiter reg3 = internal constant reg4 = Initial location in buffer reg5 = Input buffer reg6 = Final location in buffer */ /* Forwards: Takes the characters preceeding the delimiter in the input buffer, and creates an internal constant with that name. Binds reg[6] to the location in the buffer following the delimiter. Backwards: Puts the internal constant into the buffer, appends the delimiter to it, binds reg[6] to the final location in the input buffer */ { /* define local variables */ struct psc_rec *addr; /* Holds result from insert */ char *Bnameptr, /* Buffer Nameptr */ *Cnameptr, /* Constant Nameptr */ *Dnameptr; /* Delimiter Nameptr */ struct psc_rec *buff_psc, *con_psc; /* pointers to psc recs */ int offset, /* Offset into buffer */ Blen, /* Buffer length */ Clen, /* Constant length */ i; /* Counter */ word op1, op2, op3, op4, op5; register pw top; op1 = gregc(1); deref(op1); /* direction */ op2 = gregc(2); deref(op2); /* delimiter */ op3 = gregc(3); deref(op3); /* constant, substring */ op4 = gregc(4); deref(op4); /* offset */ op5 = gregc(5); deref(op5); /* buffer constant, long string */ /* check the direction param for error */ if (!isinteger(op1)) {errmsg(0); Fail0; return;} /* check input buffer - ?valid constant */ if (!isatom(op5)) {errmsg(8); Fail0; return;} buff_psc = get_str_psc(op5); /* check that offset is valid */ if (!isinteger(op4)) {errmsg(2); Fail0; return;} offset = intval(op4); if ((get_length(buff_psc) < offset) || (offset < 0)) {errmsg(3); Fail0; return;} if (!isatom(op2)) /* delimiter must be given */ {errmsg(7); Fail0; return;} Bnameptr = get_name(buff_psc); /* get nameptr for Buffer */ Dnameptr=get_name(get_str_psc(op2)); /* get nameptr for delimiter */ if (intval(op1) != BACKWARDS) { Blen = get_length(buff_psc); /* length of Buffer */ /* get the length of the constant */ Clen = 0; while ((Bnameptr[offset+Clen]!=Dnameptr[0]) && (offset+Clen= Blen) {Fail0; return;} /* create constant of length Clen */ temp = TEMP; addr = insert(Bnameptr+offset,Clen,0,&temp); /* unify this with reg3 */ if (!(unify(op3, (word)addr | CS_TAG))) {Fail0; return;} } else {/* going backwards */ if (isatom(op3)) { /* make sure there is a constant to write out */ con_psc = get_str_psc(op3); Cnameptr = get_name(con_psc); /* get cnst nameptr */ Clen = get_length(con_psc); /* get length of constant */ for (i=0;i