home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / sbprolog / buffer.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-23  |  33.8 KB  |  939 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona, 1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24. /* buffer.c */
  25.  
  26. #include "builtin.h"
  27.  
  28. /*
  29. #define DEBUG_ALLOC
  30. #define EXAMINE_BUFFCODE
  31. #define DEBUG_SUBSTRING
  32. #define DEBUG_CONLENGTH
  33. */
  34.  
  35. #define BACKWARDS 0      /* Direction parameter = 0 means backwards, */
  36.                          /* != 0 means forwards */
  37.  
  38. #define GET_E_LENGTH(ptr)  ( GET_LENGTH(ptr) < LONGBUFF ?  \
  39.                              (LONG)GET_LENGTH(ptr) :       \
  40.                  *(LONG_PTR)(GET_NAME(ptr)-4))
  41.  
  42. extern LONG_PTR insert();
  43.  
  44. static BYTE perm = PERM;
  45. static BYTE temp = TEMP;
  46.  
  47. /* create a buffer psc_entry on the heap.  Len = 4 */
  48.  
  49. LONG makenullbuff()
  50. {
  51.     LONG        addr;
  52.     PSC_REC_PTR psc_ptr;
  53.  
  54.     addr  = (LONG)hreg;
  55.     psc_ptr = (PSC_REC_PTR)(hreg + 1);
  56.     *hreg = (LONG)psc_ptr;            /* point to psc record being created */
  57.     hreg += 3;                        /* no ep and no hash link */
  58.     GET_ETYPE(psc_ptr)  = T_BUFF;
  59.     GET_ARITY(psc_ptr)  = 0;
  60.     GET_LENGTH(psc_ptr) = 0;
  61.     GET_NAME(psc_ptr)   = (CHAR_PTR)hreg;
  62.     return addr;
  63. }
  64.  
  65.  
  66. b_ALLOC_BUFF()
  67. {
  68.    /* reg1 = size (input)
  69.     * reg2 = Buffer (output)
  70.     * reg3 = 0 => perm, 1 => heap, 2 => subbuff (input)
  71.     * reg4 = Super-Buffer if there is one (input)
  72.     * reg5 = Retcode (output)
  73.     * (long lengths (>= 65535) are kept in 4 bytes immediately preceeding name)
  74.     */
  75.  
  76.    register LONG     op1, op3, op4;
  77.    register LONG_PTR top;
  78.    PSC_REC_PTR       psc_ptr, sub_psc_ptr;
  79.    LONG              addr, rc, size, len, disp;
  80.    LONG_PTR          loc, stack_top, heap_top;
  81.  
  82.    extern LONG       alloc_perm();
  83.  
  84.    /* reg1 should be bound to a number; reg2 is free */
  85.    op1  = reg[1];  DEREF(op1);  size = INTVAL(op1);
  86.    op3  = reg[3];  DEREF(op3);
  87.    rc = 0;
  88.  
  89. #ifdef DEBUG_ALLOC
  90.    printf("b_ALLOC_BUFF: ");
  91. #endif
  92.  
  93.    switch (INTVAL(op3)) {
  94.  
  95.       case 0:                                /* perm */
  96.          addr = alloc_perm(size);            /* addr = ptr to struct node */
  97.                          /*        for buffer         */
  98. #ifdef DEBUG_ALLOC
  99.          printf("case 0 : perm\n");
  100.          printf("            : size = %d   addr = %08x\n", size, addr);
  101. #endif
  102.          if (!unify(reg[2], (addr | CS_TAG)))
  103.             {FAIL0;}
  104.          break;
  105.  
  106.       case 1:                                /* heap */
  107. #ifdef DEBUG_ALLOC
  108.          printf("case 1 : heap\n");
  109.          printf("            : hreg = %08x size = %d  shift = %x\n", 
  110.                 hreg, size, (size + 3) >> 2);
  111. #endif
  112.      /* check for heap overflow */
  113.      stack_top = (breg < ereg) ? breg : ereg - ENV_SIZE(cpreg);
  114.      heap_top  = hreg + 5 + ((size + 3) >> 2);
  115.      if (stack_top < heap_top) {
  116.         /* garbage_collection("b_ALLOC_BUFF"); */
  117.         if (stack_top < heap_top)    /* still too full */
  118.            quit("Heap overflow\n");
  119.      }
  120.          addr = makenullbuff();
  121.          psc_ptr = GET_STR_PSC(addr);
  122. #ifdef DEBUG_ALLOC
  123.          printf("            : addr = %08x   psc_ptr = %08x\n\n",
  124.         addr, psc_ptr);
  125. #endif
  126.          if (size < LONGBUFF)
  127.         GET_LENGTH(psc_ptr) = size;
  128.          else {
  129.             GET_LENGTH(psc_ptr) = LONGBUFF;
  130.             *hreg++ = size;
  131.             GET_NAME(psc_ptr) = (CHAR_PTR)hreg;
  132.          }
  133.          hreg += (size + 3) >> 2;
  134.      /* add a trailing CS-tagged pointer (end_buf) for GC */
  135.      *hreg++ = (LONG)psc_ptr | CS_TAG;
  136.          *(LONG_PTR)GET_NAME(psc_ptr) = 4;   /* displacement of next free */
  137.                          /*   (for subbuffers)        */
  138. #ifdef DEBUG_ALLOC
  139.          printf("            : hreg = %08x \n", hreg);
  140.          printf("            : addr = %08x  =>  %08x\n", addr, *(LONG_PTR)addr);
  141.          printf("            : psc_ptr  = %08x\n", psc_ptr);
  142.          printf("            : etype = %d  arity = %d  len = %d\n",
  143.                 GET_ETYPE(psc_ptr), GET_ARITY(psc_ptr), GET_LENGTH(psc_ptr));
  144.          printf("            : nameptr = %08x\n", GET_NAME(psc_ptr));
  145.          printf("            : ep      = %08x\n", GET_EP(psc_ptr));
  146. #endif
  147.          if (!unify(reg[2], (addr | CS_TAG)))
  148.             {FAIL0;}
  149.          break;
  150.  
  151.       case 2:                                /* subbuffer */
  152. #ifdef DEBUG_ALLOC
  153.          printf("case 2 : subbuffer\n");
  154. #endif
  155.          op4 = reg[4];  DEREF(op4);          /* super buffer */
  156.          psc_ptr = GET_STR_PSC(op4);
  157.          len = GET_E_LENGTH(psc_ptr);
  158.          disp = *(LONG_PTR)GET_NAME(psc_ptr);
  159.          loc = (LONG_PTR)(GET_NAME(psc_ptr) + disp);
  160.  
  161.          if (disp + 12 + size > len)         /* not enough room in super buf */
  162.             rc = 1;                          /*   return error code */
  163.          else {
  164.             addr = (LONG)loc;
  165.             sub_psc_ptr = (PSC_REC_PTR)(loc + 1);
  166.             *loc = (LONG)sub_psc_ptr;
  167.             loc += 3;                        /* no ep, no hash link */
  168.             GET_ETYPE(sub_psc_ptr) = T_BUFF;
  169.             GET_ARITY(sub_psc_ptr) = 0;
  170.             if (size < LONGBUFF)
  171.                GET_LENGTH(sub_psc_ptr) = size;
  172.             else {
  173.                GET_LENGTH(sub_psc_ptr) = LONGBUFF;
  174.                *loc++ = size;
  175.             }
  176.             GET_NAME(sub_psc_ptr) = (CHAR_PTR)loc;
  177.             loc += (size + 3) >> 2;
  178.             *(LONG_PTR)GET_NAME(sub_psc_ptr) = 4;   /* displacement of next free */
  179.             disp = (LONG)((CHAR_PTR)loc - GET_NAME(psc_ptr));
  180.             *(LONG_PTR)GET_NAME(psc_ptr) = disp;
  181.             if (!unify(reg[2], (addr | CS_TAG)))
  182.                {FAIL0;}
  183.          }
  184.          break;
  185.    }
  186.    if (!unify(reg[5], MAKEINT(rc)))
  187.       {FAIL0;}
  188. }
  189.  
  190. b_BUFF_CODE()
  191. {
  192.    /* b_BUFF_CODE inserts a word into, or extracts a word from, a buffer.
  193.     * It is VERY low-level and implementation dependent. It is used to
  194.     * generate byte-code into a buffer, and retrieve a word from a buffer.
  195.     * On entry, reg1 is bound to a buffer, reg2 is the offset in the buffer,
  196.     * reg3 contains a number indicating what internal word to generate,
  197.     * reg4 contains a term from which the word to insert in the buffer is
  198.     * extracted, or a variable that is bound to the word extracted from
  199.     * the buffer
  200.     */
  201.  
  202.    PSC_REC_PTR       psc_ptr, io_psc_ptr;
  203.    register LONG     op1, op4;
  204.    register LONG_PTR top;
  205.    FILE              *fdes;
  206.    WORD              disc, i, arity;
  207.    LONG              disp;
  208.    CHAR              s[100];
  209.    LONG              tempvar, temp1, temp2;
  210.  
  211.    op4 = reg[1];  DEREF(op4);
  212.    if (!ISCONSTR(op4)) {
  213.       errmsg(11);
  214.       FAIL0;
  215.       return;
  216.    }
  217.    psc_ptr = GET_STR_PSC(op4);
  218.    op4 = reg[2];  DEREF(op4);  disp = INTVAL(op4);
  219.    op4 = reg[3];  DEREF(op4);  disc = INTVAL(op4);
  220.    op4 = reg[4];  DEREF(op4);
  221.  
  222.    switch (disc) {
  223.       case  0: /* ppsc: constant/structure, UNTAGGED psc_ptr to buff */
  224.                /* make permanent if could be dangling pointer        */
  225.                if ((LONG)GET_NAME(psc_ptr) < (LONG)GET_STR_PSC(op4)) {
  226.                   io_psc_ptr = GET_STR_PSC(op4);
  227.                   op4 = (LONG)insert(GET_NAME(io_psc_ptr),
  228.                      GET_LENGTH(io_psc_ptr),
  229.                                      GET_ARITY(io_psc_ptr), &perm) | CS_TAG;
  230.                }
  231.                *(LONG_PTR)(GET_NAME(psc_ptr) + disp) = (LONG)GET_STR_PSC(op4);
  232.                break;
  233.       case  1: /* pppsc: con/str, UNTAGGED ptr to psc_ptr to buff */
  234.                /* make permanent if could be dangling pointer        */
  235.                if ((LONG)GET_NAME(psc_ptr) < (LONG)UNTAGGED(op4)) {
  236.                   io_psc_ptr = GET_STR_PSC(op4);
  237.                   op4 = (LONG)insert(GET_NAME(io_psc_ptr),
  238.                      GET_LENGTH(io_psc_ptr),
  239.                                      GET_ARITY(io_psc_ptr), &perm);
  240.                }
  241.                *(LONG_PTR)(GET_NAME(psc_ptr) + disp) = UNTAGGED(op4);
  242.                break;
  243.       case  2: /* pn: number, UNTAGGED LONG value to buff */
  244.                *(LONG_PTR)(GET_NAME(psc_ptr) + disp) = INTVAL(op4);
  245.                break;
  246.       case  3: /* ps: number, UNTAGGED short value to buff */
  247.                *(WORD_PTR)(GET_NAME(psc_ptr) + disp) = INTVAL(op4);
  248.                break;
  249.       case  4: /* ga: return address of location in buffer, as tagged num */
  250.                if (!unify(op4, MAKEINT(GET_NAME(psc_ptr) + disp)))
  251.                   {FAIL0;}
  252.                break;
  253.       case  5: /* gn: return word at location in buffer, as tagged num */
  254.                if (!unify(op4, MAKEADD(*(LONG_PTR)(GET_NAME(psc_ptr) + disp))))
  255.                   {FAIL0;}
  256.                break;
  257.       case  6: /* gs: return short at location in buffer, as tagged num */
  258.                if (!unify(op4, MAKEINT(*(WORD_PTR)(GET_NAME(psc_ptr)+disp)))) {
  259.                   FAIL0;
  260.                }
  261.                break;
  262.       case  7: /* gepb: return buff that 1st arg pred ep points to       */
  263.                /* assumes ep points to 2nd word in buff, first is ptr to */
  264.                /*   its own psc_ptr                                      */
  265.                if (!unify(op4, *(LONG_PTR)(GET_EP(psc_ptr) - 1)))
  266.                   {FAIL0;}
  267.                break;
  268.       case  8: /* gpb: return buff that word at disp-buff points to */
  269.                if (!unify(op4,
  270.                           *(LONG_PTR)(*(LONG_PTR)(GET_NAME(psc_ptr)+disp)-4)))
  271.                   {FAIL0;}
  272.                break;
  273.       case  9: /* pep: set ep of term to point to 4th byte in buff */
  274.                GET_EP(psc_ptr) = (LONG_PTR)(GET_NAME(GET_STR_PSC(op4)) + 4);
  275.                GET_ETYPE(psc_ptr) = T_DYNA;
  276.                /* and set 1st word of buff to point to buff psc_ptr */
  277.                /* *(LONG_PTR)GET_NAME(GET_STR_PSC(op4)) = op4; */
  278.                break;
  279.       case 10: /* pbr: set word p points to 4th byte in buff */
  280.                *(CHAR_PTR *)(GET_NAME(psc_ptr) + disp) = 
  281.              GET_NAME(GET_STR_PSC(op4)) + 4;
  282.                /* and set 1st word of buff to point to buff psc_ptr */
  283.                /* *(LONG_PTR)GET_NAME(GET_STR_PSC(op4)) = op4; */
  284.                break;
  285.       case 11: /* rep: reset ep of first arg to undefined */
  286.                if (IS_PRED(psc_ptr) || IS_DYNA(psc_ptr)) {
  287.                   GET_EP(psc_ptr) = 0;
  288.                   GET_ETYPE(psc_ptr) = T_ORDI;
  289.                }
  290.                break;
  291.       case 12: /* fv: free variable to buff, for use with getival instr */
  292.                temp1 = (LONG)(GET_NAME(psc_ptr) + disp);
  293.                if (ISVAR(temp1))
  294.                   FOLLOW(temp1) = temp1;
  295.                else {
  296.                   curr_fence = (CHAR_PTR)(((LONG)curr_fence + 3) & 0xfffffffc);
  297.                   FOLLOW(temp1) = (LONG)curr_fence;
  298.                   FOLLOW(curr_fence) = (LONG)curr_fence;
  299.                   curr_fence += 4;
  300.           if (curr_fence >= max_fence)
  301.              quit("Program area overflow\n");
  302.                }
  303.                break;
  304.       case 13: /* execb: branch into buffer,  using 4th arg as call */
  305.                pcreg = (WORD_PTR)(GET_NAME(psc_ptr) + disp);
  306.                arity = GET_ARITY(GET_STR_PSC(op4));
  307.                UNTAG(op4);
  308.                for (i = 1; i <= arity; i++)
  309.                   reg[i] = FOLLOW((LONG_PTR)op4 + i);
  310.                break;
  311.       case 14: /* ptv: number or const, tagged word value to buff */
  312.                /* make permanent if could be dangling pointer     */
  313.                if (ISCONSTR(op4) && (LONG)GET_NAME(psc_ptr) <
  314.            (LONG)UNTAGGED(op4)) {
  315.                   io_psc_ptr = GET_STR_PSC(op4);
  316.                   op4 = (LONG)insert(GET_NAME(io_psc_ptr),
  317.                      GET_LENGTH(io_psc_ptr),
  318.                                      GET_ARITY(io_psc_ptr), &perm) | CS_TAG;
  319.                }
  320.                *(LONG_PTR)(GET_NAME(psc_ptr) + disp) = op4;
  321.                break;
  322.       case 15: /* ptp: put str-tagged pointer to second location */
  323.                *(LONG_PTR)(GET_NAME(psc_ptr) + disp) =
  324.                      (LONG)((LONG)(GET_NAME(psc_ptr) + INTVAL(op4)) | CS_TAG);
  325.                break;
  326.       case 16: /* ptl: put list-tagged pointer to second location */
  327.                *(LONG_PTR)(GET_NAME(psc_ptr) + disp) =
  328.                      (LONG)((LONG)(GET_NAME(psc_ptr) + INTVAL(op4)) | LIST_TAG);
  329.                break;
  330.       case 17: /* pvar: put variable into buffer */
  331.                tempvar = (LONG)(GET_NAME(psc_ptr) + disp);
  332.                FOLLOW(tempvar) = tempvar;
  333.                if (op4 >= (LONG)GET_NAME(psc_ptr) &&
  334.                    op4 <= (LONG)(GET_NAME(psc_ptr) + GET_E_LENGTH(psc_ptr)))
  335.                   /* already points into the buffer */
  336.                   FOLLOW(op4) = tempvar;        /* point word to it */
  337.                else {
  338.                   FOLLOW(op4) = tempvar;
  339.                   PUSHTRAIL(op4);               /* and trail! */
  340.                }
  341.                break;
  342.       case 18: /* ubv: unify value with buffer */
  343.                if (!unify(GET_NAME(psc_ptr) + disp, op4))
  344.                   {FAIL0;}
  345.                break;
  346.       case 19: /* cep: copy ep of last arg to ep of first */
  347.                io_psc_ptr = GET_STR_PSC(op4);
  348.                if (!IS_BUFF(psc_ptr)) {
  349.                   GET_EP(psc_ptr) = GET_EP(io_psc_ptr);
  350.                   GET_ETYPE(psc_ptr) = GET_ETYPE(io_psc_ptr);
  351.                }
  352.                break;
  353.       case 20: /* pepb: copy ep of last arg to loc in buff */
  354.                io_psc_ptr = GET_STR_PSC(op4);
  355.                FOLLOW(GET_NAME(psc_ptr) + disp) = (LONG)GET_EP(io_psc_ptr);
  356.                break;
  357.       case 21: /*gnb: return next buffer along the hash chain */
  358.                op1 = *(LONG_PTR)(GET_NAME(psc_ptr) + disp);
  359.                op1 = *(LONG_PTR)(op1 + 12) - 12;
  360.                if (!unify(op4, *(LONG_PTR)op1))
  361.                   {FAIL0;}
  362.                break;
  363.       case 22: /*dis: disassemble buffer for debugging assert         */
  364.                /*op1: buffer; op2: 0 for "w" 1 for "a"; op4: filename */
  365.                io_psc_ptr = GET_STR_PSC(op4);
  366.                temp1 = (LONG)pcreg;
  367.                temp2 = num_line;
  368.                num_line = 1;
  369.                namestring(io_psc_ptr, s);
  370.                if (disp == 0)
  371.                   fdes = fopen(s, "w");
  372.                else
  373.                   fdes = fopen(s, "a");
  374.                fprintf(fdes,
  375.   "\n /* New Buffer Below: pscptr, arity, length, nameptr, backptr *\/\n\n");
  376.                fprintf(fdes, "%x, %d, %d, %x, %x \n",
  377.                psc_ptr, GET_ARITY(psc_ptr), GET_LENGTH(psc_ptr),
  378.                GET_NAME(psc_ptr), GET_EP(psc_ptr));
  379.                pcreg = (WORD_PTR)(GET_NAME(psc_ptr) + 4);
  380.                while (pcreg <
  381.               (WORD_PTR)(GET_NAME(psc_ptr) + GET_LENGTH(psc_ptr)))
  382.                   print_inst(fdes, pcreg);
  383.                fflush(fdes);
  384.                fclose(fdes);
  385.                pcreg = (WORD_PTR)temp1;
  386.                num_line = temp2;
  387.                break;
  388.       case 23: /* ps: short number, UNTAGGED word value to buff */
  389.                *(WORD_PTR)(GET_NAME(psc_ptr) + disp) = INTVAL(op4);
  390.                break;
  391.       case 24: /* gs: return short number at location in buffer,  */
  392.                /* as tagged num                                   */
  393.                if (!unify(op4, MAKEINT(*(WORD_PTR)(GET_NAME(psc_ptr) + disp))))
  394.                   {FAIL0;}
  395.                break;
  396.       case 25: /* bb: build a buffer for a pointer in a buffer, 0 len  */
  397.                temp1 = makenullbuff();
  398.                io_psc_ptr = GET_STR_PSC(temp1);
  399.                GET_NAME(io_psc_ptr) = *(CHAR_PTR *)(GET_NAME(psc_ptr) + disp);
  400.                if (!unify(op4, (temp1 | CS_TAG)))
  401.                   {FAIL0;}
  402.                break;
  403.       case 26: /* pba: put buffer address into buffer */
  404.                io_psc_ptr = GET_STR_PSC(op4);
  405.                FOLLOW(GET_NAME(psc_ptr) + disp) = (LONG)(GET_NAME(io_psc_ptr));
  406.                break;
  407.       case 27: /* pf: put float (in WAM format, word) into buffer */
  408.                *(LONG_PTR)(GET_NAME(psc_ptr) + disp) = op4;
  409.                break;
  410.       case 28: /* gppsc: get ptr to psc_table entry */
  411.            if (!unify(op4, *(LONG_PTR)(GET_NAME(psc_ptr) + disp) | CS_TAG))
  412.                   {FAIL0;}
  413.                break;
  414.       case 29: /* gf: get float (in WAM format, word) from buffer */
  415.                if (!unify(op4, *(LONG_PTR)(GET_NAME(psc_ptr) + disp)))
  416.                   {FAIL0;}
  417.            break;
  418.       case 30: /* pb: number, UNTAGGED byte value to buff */
  419.                *(BYTE_PTR)(GET_NAME(psc_ptr) + disp) = INTVAL(op4);
  420.                break;
  421.       case 31: /* gb: return byte at location in buffer, as tagged num */
  422.                if (!unify(op4, MAKEINT(*(BYTE_PTR)(GET_NAME(psc_ptr) + disp))))
  423.                   {FAIL0;}
  424.                break;
  425.       case 32: /* similar to Case 2, but using ADDVAL.  -- Ultrix */
  426.                *(LONG_PTR)(GET_NAME(psc_ptr) + disp) = ADDVAL(op4);
  427.                break;
  428.       case 33: /* similar to Case 4, but using MAKEADD. -- Ultrix */
  429.                if (!unify(op4, MAKEADD(GET_NAME(psc_ptr) + disp)))
  430.                   {FAIL0;}
  431.                break;
  432.    }
  433. }
  434.  
  435. b_TRIMBUFF()
  436. {
  437.    /* reg1 : new length (if <0 scan for 0x00)
  438.     * reg2 : buffer
  439.     * reg3 : 0 => perm, 1 => temp, 2 => temp in superbuff (r4)
  440.     * reg4 : superbuff to trim (if 2)
  441.     */
  442.  
  443.    register LONG     op1, op2, op3;
  444.    register LONG_PTR top;
  445.    PSC_REC_PTR       psc_ptr, sb_psc_ptr;
  446.    LONG              len;
  447.    LONG_PTR          new_end;
  448.  
  449.    op3 = reg[3];  DEREF(op3);  op3 = INTVAL(op3);
  450.    op2 = reg[2];  DEREF(op2);  psc_ptr = GET_STR_PSC(op2);
  451.    op1 = reg[1];  DEREF(op1);  len = INTVAL(op1);
  452.  
  453. #ifdef DEBUG_ALLOC
  454.    printf("b_TRIMBUFF: op1 = %08x  op = %08x  op3 = %08x\n", op1, op2, op3);
  455.    printf("          : ptr = %08x  len = %08x\n", psc_ptr, len);
  456.    printf("          : type = %d  arity = %d  len = %d\n", 
  457.           GET_ETYPE(psc_ptr), GET_ARITY(psc_ptr), GET_LENGTH(psc_ptr));
  458.    printf("          : name = %08x  %s\n",
  459.       GET_NAME(psc_ptr), GET_NAME(psc_ptr));
  460.    printf("          : ep   = %08x\n", GET_EP(psc_ptr));
  461. #endif
  462.  
  463.    if (len < 0) {
  464.       if (GET_NAME(psc_ptr)) {
  465.          len = strlen(GET_NAME(psc_ptr));
  466. #ifdef DEBUG_ALLOC
  467.          printf(" len < 0  : newlen = %d\n", len);
  468. #endif
  469.       } else {
  470. #ifdef DEBUG_ALLOC
  471.          printf(" len < 0  : failing  (FAIL0)\n");
  472. #endif
  473.          FAIL0;
  474.       }
  475.    }
  476.    else if (op3 == 0) {                      /* perm */
  477.       if (curr_fence == GET_NAME(psc_ptr) + GET_LENGTH(psc_ptr))
  478.          curr_fence = GET_NAME(psc_ptr) + len;
  479.    }
  480.    else if (op3 == 1) {                      /* heap */
  481.       new_end = (LONG_PTR)GET_NAME(psc_ptr) + ((len + 3) >> 2);
  482.       *new_end = (LONG)psc_ptr | CS_TAG;     /* move up end_buf pointer*/
  483.       if (hreg == (LONG_PTR)psc_ptr + BUFF_SIZE(psc_ptr) - 1)
  484.          hreg = new_end + 1;
  485.    }
  486.    else {                                    /* in superbuffer */
  487.       op2 = reg[4];  DEREF(op2);  sb_psc_ptr = GET_STR_PSC(op2);
  488.       if ((LONG)GET_NAME(sb_psc_ptr) + *(LONG_PTR)GET_NAME(sb_psc_ptr) ==
  489.           (LONG)GET_NAME(psc_ptr) + GET_E_LENGTH(psc_ptr))
  490.          *(LONG_PTR)GET_NAME(sb_psc_ptr) =   /* new displacement */
  491.              UNTAGGED((LONG)GET_NAME(psc_ptr) + len -
  492.          (LONG)GET_NAME(sb_psc_ptr) + 3);
  493.    }
  494.    if (GET_LENGTH(psc_ptr) < LONGBUFF)
  495.       GET_LENGTH(psc_ptr) = len;
  496.    else
  497.       *(LONG_PTR)(GET_NAME(psc_ptr) - 4) = len;
  498. }
  499.  
  500.  
  501. b_SUBSTRING()
  502. {
  503.    /* reg1 = direction (1 = forwards for read,  0 = backwards for write)
  504.     * reg2 = numbytes
  505.     * reg3 = Internal constant
  506.     * reg4 = Initial location in the input buffer
  507.     * reg5 = Input Buffer  (must be a valid constant)
  508.     * reg6 = Final location in the input buffer after reading from or
  509.     *        writing into the buffer
  510.     *
  511.     * Forwards: If the internal constant parameter is free upon entry, it
  512.     *           takes the first numbytes of the input buffer and creates
  513.     *           an internal constant.  Reg 6 gets bound to the location
  514.     *           in the input buffer directly FOLLOWing the constant. If the
  515.     *           constant parameter is already bound, it is checked against
  516.     *           the one in the buffer to see if they unify.  The numbytes
  517.     *           parameter must unify with the length of the constant.
  518.     *
  519.     * Backwards: Binds numbytes(if not bound) to the length of the internal
  520.     *            constant. Copies the internal constant into the Input Buffer,
  521.     *            and returns in reg 6 an index into the input buffer which
  522.     *            directly FOLLOWs the constant.
  523.     */
  524.  
  525.    CHAR_PTR    Bnameptr, Cnameptr;   /* Buffer Nameptr, Constant Nameptr */
  526.    PSC_REC_PTR psc_ptr;              /* pointer to psc rec of buffer */
  527.    LONG        addr;                 /* Holds result from insert */
  528.    LONG        offset;               /* Offset into buffer  */
  529.    LONG        numbytes;             /* Numbytes in buffer for constant */
  530.    LONG        i;                    /* Counter */
  531.    LONG        op1, op2, op3, op4, op5;
  532.    register    LONG_PTR top;
  533.  
  534.    op1 = reg[1];  DEREF(op1);          /* direction */
  535.    op2 = reg[2];                       /* length */
  536.    op3 = reg[3];  DEREF(op3);          /* constant substring */
  537.    op4 = reg[4];  DEREF(op4);          /* offset */
  538.    op5 = reg[5];  DEREF(op5);          /* constant, long string */
  539.  
  540.    /* check the direction param for error */
  541.  
  542.    if (!ISINTEGER(op1)) {
  543.       errmsg(0);
  544.       FAIL0;
  545.       return;
  546.    }
  547.  
  548.    /* check input buffer - ?valid constant */
  549.  
  550.    if (!ISATOM(op5)) {
  551.       errmsg(8);
  552.       FAIL0;
  553.       return;
  554.    }
  555.    psc_ptr = GET_STR_PSC(op5);
  556.  
  557.    /* check that offset is valid */
  558.  
  559.    if (!ISINTEGER(op4)) {
  560.       errmsg(2);
  561.       FAIL0;
  562.       return;
  563.    }
  564.    offset = INTVAL(op4);
  565.    if (GET_LENGTH(psc_ptr) < offset || offset < 0) {
  566.       errmsg(3);
  567.       FAIL0;
  568.       return;
  569.    }
  570.  
  571.    /* get length of substring */
  572.  
  573.    if (ISATOM(op3) && !unify(op2, MAKEINT(GET_LENGTH(GET_STR_PSC(op3))))) {
  574.       FAIL0;
  575.       return;
  576.    }
  577.    DEREF(op2);
  578.    if (!ISINTEGER(op2)) {
  579.       errmsg(4);
  580.       FAIL0;
  581.       return;
  582.    }
  583.    numbytes = INTVAL(op2);
  584.  
  585.    /* check no buffer overflow */
  586.  
  587.    if (numbytes < 0 || (offset + numbytes) > GET_LENGTH(psc_ptr)) {
  588.       errmsg(3);
  589.       FAIL0;
  590.       return;
  591.    }
  592.  
  593.    if (INTVAL(op1) != BACKWARDS) {
  594.       /* find the constant, or insert a new one */
  595.       temp = TEMP;
  596.       addr = (LONG)insert(GET_NAME(psc_ptr) + offset, numbytes, 0, &temp);
  597.       if (!unify(op3, addr | CS_TAG)) {
  598.          FAIL0;
  599.          return;
  600.       }
  601.    } else {                              /* going backwards */
  602.       Bnameptr = GET_NAME(psc_ptr);
  603.       if (!ISATOM(op3)) {
  604.          errmsg(5);
  605.      FAIL0;
  606.          return;
  607.       }
  608.       Cnameptr = GET_NAME(GET_STR_PSC(op3));
  609.       for (i = 0; i < numbytes; i++)    /* copy into buffer */
  610.          Bnameptr[i+offset] = Cnameptr[i];
  611.  
  612. #ifdef DEBUG_SUBSTRING
  613.       printf("b_SUBSTRING: (1)dir = %d   (2)bytes = %d   (4)ofs = %d\n",
  614.              INTVAL(op1), INTVAL(op2), INTVAL(op4));
  615.       printf("           : const = %08x\n", GET_STR_PSC(op3));
  616.       printf("           :    type = %d  arity = %d  len = %d\n",
  617.              GET_ETYPE(GET_STR_PSC(op3)), GET_ARITY(GET_STR_PSC(op3)),
  618.              GET_LENGTH(GET_STR_PSC(op3)));
  619.       printf("           :    name = %08x : %s\n",  
  620.              GET_NAME(GET_STR_PSC(op3)), GET_NAME(GET_STR_PSC(op3)));
  621.       printf("           : buff  = %08x\n", GET_STR_PSC(op5));
  622.       printf("           :    type = %d  arity = %d  len = %d\n",
  623.              GET_ETYPE(GET_STR_PSC(op5)), GET_ARITY(GET_STR_PSC(op5)),
  624.              GET_LENGTH(GET_STR_PSC(op5)));
  625.       printf("           :    name = %08x : %s\n",  
  626.              GET_NAME(GET_STR_PSC(op5)), GET_NAME(GET_STR_PSC(op5)));
  627.       printf("           : Cname = %s\n", Cnameptr);
  628.       printf("           : Bname = %s\n", Bnameptr);
  629. #endif
  630.    }
  631.  
  632.    /* check or set out location */
  633.  
  634.    if (!unify(reg[6], MAKEINT(offset + numbytes)))
  635.       {FAIL0;}
  636. }
  637.  
  638.  
  639. b_SUBNUMBER()
  640. {
  641.    /* reg1 = direction (forwards for read,  backward for write)
  642.     * reg2 = number of bytes storing the length
  643.     * reg3 = numeric constant
  644.     * reg4 = Initial location in buffer
  645.     * reg5 = Input Buffer
  646.     * reg6 = Final location in buffer
  647.     *
  648.     * Forward case: Takes numbytes out of Input Buffer, converts
  649.     *               it to a number.  (starting from initial loc in buffer)
  650.     *               Binds reg 6 to location in the buffer FOLLOWing the
  651.     *               string representation of the number.
  652.     *
  653.     * Backward case: Takes a numeric constant, stores its name in the
  654.     *                Input buffer and binds reg6 to the location in the
  655.     *                buffer FOLLOWing the string representation of number
  656.     */
  657.  
  658.    CHAR_PTR    Bnameptr;          /* Buffer nameptr */
  659.    PSC_REC_PTR psc_ptr;           /* pointer to psc rec of buffer */
  660.    LONG        num;               /* Number from subnumber op */
  661.    LONG        numbytes;          /* Number of bytes */
  662.    LONG        xtra;              /* Number of leading zeros */
  663.    LONG        i;                 /* Counter */
  664.    LONG        offset;            /* Offset into buffer */
  665.    CHAR        s[10];             /* String representation of number */
  666.    LONG        op1, op2, op3, op4, op5;
  667.    register    LONG_PTR top;
  668.  
  669.    op1 = reg[1];  DEREF(op1);     /* direction */
  670.    op2 = reg[2];  DEREF(op2);     /* length */
  671.    op3 = reg[3];  DEREF(op3);     /* numeric constant,  substring */
  672.    op4 = reg[4];  DEREF(op4);     /* offset */
  673.    op5 = reg[5];  DEREF(op5);     /* buffer constant, long string */
  674.  
  675.    /* check the direction param for error */
  676.  
  677.    if (!ISINTEGER(op1)) {
  678.       errmsg(0);
  679.       FAIL0;
  680.       return;
  681.    }
  682.  
  683.    /* check input buffer - ?valid constant */
  684.  
  685.    if (!ISATOM(op5)) {
  686.       errmsg(8);
  687.       FAIL0;
  688.       return;
  689.    }
  690.    psc_ptr = GET_STR_PSC(op5);
  691.  
  692.    /* check that offset is valid */
  693.  
  694.    if (!ISINTEGER(op4)) {
  695.       errmsg(2);
  696.       FAIL0;
  697.       return;
  698.    }
  699.    offset = INTVAL(op4);
  700.    if (GET_LENGTH(psc_ptr) < offset || offset < 0) {
  701.       errmsg(3);
  702.       FAIL0;
  703.       return;
  704.    }
  705.    if (!ISINTEGER(op2)) {       /* Number of bytes which is the length */
  706.       errmsg(6);                /* of the string representation of the */
  707.       FAIL0;                    /* number MUST be specified in both    */
  708.       return;                   /* the forward and backward case.      */
  709.    }
  710.    numbytes = INTVAL(op2);    /* get the length of const into numbytes  */
  711.  
  712.    /* check no buffer overflow */
  713.  
  714.    if (numbytes < 0 || (offset + numbytes) > GET_LENGTH(psc_ptr)) {
  715.       errmsg(3);
  716.       FAIL0;
  717.       return;
  718.    }
  719.  
  720.   if (INTVAL(op1) != BACKWARDS) {
  721.      /* get numeric equivalent out */
  722.       num = getnum(numbytes, GET_NAME(psc_ptr) + offset);
  723.       if (!unify(op3, MAKEINT(num))) {     /* unify reg3 with number */
  724.          FAIL0;
  725.          return;
  726.       }
  727.    }
  728.    else {                              /* going backwards */
  729.       if (!ISINTEGER(op3)) {
  730.          errmsg(6);                    /* no number to be written */
  731.          FAIL0;
  732.          return;
  733.       }
  734.       num = INTVAL(op3);               /* get number to be written */
  735.       Bnameptr = GET_NAME(psc_ptr);    /* get buffer name pointer */
  736.       itoa(num, s);                    /* make s string representing num */
  737.       xtra = numbytes - strlen(s);     /* number of leading zeros */
  738.       if (xtra < 0) {                  /* number too large */
  739.          errmsg(10);
  740.          FAIL0;
  741.          return;
  742.       }
  743.       for (i = 0; i < xtra; i++)       /* put leading zeros in if any */
  744.          Bnameptr[i+offset] = '0';
  745.       for (i = xtra; i < strlen(s) + xtra; i++)   /* put character rep of */
  746.          Bnameptr[i+offset] = s[(i-xtra)];        /*   number into buffer */
  747.    }
  748.  
  749.    /* check or set out location */
  750.  
  751.    if (!unify(reg[6], MAKEINT(offset+numbytes)))
  752.       {FAIL0;}
  753. }
  754.  
  755.  
  756. b_SUBDELIM()
  757. {
  758.    /* reg1 = direction       (forwards for read,  backwards for write )
  759.     * reg2 = delimiter
  760.     * reg3 = internal constant
  761.     * reg4 = Initial location in buffer
  762.     * reg5 = Input buffer
  763.     * reg6 = Final location in buffer
  764.     *
  765.     * Forwards: Takes the characters preceeding the delimiter
  766.     *           in the input buffer, and creates an internal
  767.     *           constant with that name.  Binds reg[6] to the
  768.     *           location in the buffer FOLLOWing the delimiter.
  769.     *
  770.     *  Backwards: Puts the internal constant into the buffer,
  771.     *            appends the delimiter to it, binds reg[6] to
  772.     *            the final location in the input buffer
  773.     */
  774.  
  775.    LONG        addr;                  /* Holds result from insert */
  776.    CHAR_PTR    Bnameptr;              /* Buffer Nameptr */
  777.    CHAR_PTR    Cnameptr;              /* Constant Nameptr */
  778.    CHAR_PTR    Dnameptr;              /* Delimiter Nameptr */
  779.    PSC_REC_PTR psc_ptr, con_psc_ptr;  /* pointers to psc recs */
  780.    LONG        offset;                /* Offset into buffer */
  781.    LONG        Blen;                  /* Buffer length */
  782.    LONG        Clen;                  /* Constant length */
  783.    LONG        i;                     /* Counter */
  784.    LONG        op1, op2, op3, op4, op5;
  785.    register    LONG_PTR top;
  786.  
  787.    op1 = reg[1];  DEREF(op1);       /* direction */
  788.    op2 = reg[2];  DEREF(op2);       /* delimiter */
  789.    op3 = reg[3];  DEREF(op3);       /* constant,  substring */
  790.    op4 = reg[4];  DEREF(op4);       /* offset */
  791.    op5 = reg[5];  DEREF(op5);       /* buffer constant, long string */
  792.  
  793.    /* check the direction param for error */
  794.  
  795.    if (!ISINTEGER(op1)) {
  796.       errmsg(0);
  797.       FAIL0;
  798.       return;
  799.    }
  800.  
  801.    /* check input buffer - ?valid constant */
  802.  
  803.    if (!ISATOM(op5)) {
  804.       errmsg(8);
  805.       FAIL0;
  806.       return;
  807.    }
  808.    psc_ptr = GET_STR_PSC(op5);
  809.  
  810.    /* check that offset is valid */
  811.  
  812.    if (!ISINTEGER(op4)) {
  813.       errmsg(2);
  814.       FAIL0;
  815.       return;
  816.    }
  817.    offset = INTVAL(op4);
  818.    if (GET_LENGTH(psc_ptr) < offset || offset < 0) {
  819.       errmsg(3);
  820.       FAIL0;
  821.       return;
  822.    }
  823.  
  824.    if (!ISATOM(op2)) {                     /* delimiter must be given */
  825.       errmsg(7);
  826.       FAIL0;
  827.       return;
  828.    }
  829.  
  830.    Bnameptr = GET_NAME(psc_ptr);           /* get nameptr for Buffer */
  831.    Dnameptr = GET_NAME(GET_STR_PSC(op2));  /* get nameptr for delimiter */
  832.    if (INTVAL(op1) != BACKWARDS) {
  833.       Blen = GET_LENGTH(psc_ptr);          /* length of Buffer */
  834.       Clen = 0;                            /* get the length of the constant */
  835.       while (Bnameptr[offset+Clen] != Dnameptr[0] && offset + Clen < Blen)
  836.          Clen++;
  837.       if (offset + Clen >= Blen) {
  838.          FAIL0;
  839.          return;
  840.       }
  841.       /* create constant of length Clen */
  842.       temp = TEMP;
  843.       addr = (LONG)insert(Bnameptr + offset, Clen, 0, &temp);
  844.       /* unify this with reg3 */
  845.       if (!(unify(op3, addr | CS_TAG))) {
  846.          FAIL0;
  847.          return;
  848.       }
  849.    }
  850.    else {                                    /* going backwards */
  851.       if (ISATOM(op3)) {       /* make sure there is a constant to write out */
  852.          con_psc_ptr  = GET_STR_PSC(op3);
  853.          Cnameptr = GET_NAME(con_psc_ptr);   /* get cnst nameptr */
  854.          Clen     = GET_LENGTH(con_psc_ptr); /* get length of constant */
  855.          for (i = 0; i < Clen; i++)          /* copy constant into buffer */
  856.             Bnameptr[offset+i] = Cnameptr[i];
  857.          /* copy delimiter into buffer */
  858.          Bnameptr[offset + Clen] = Dnameptr[0];
  859.       }
  860.       else {                                 /* no constant to be written out */
  861.          errmsg(5);
  862.      FAIL0;
  863.          return;
  864.       }
  865.    }
  866.  
  867.    /* validate or bind outloc */
  868.  
  869.    if (!unify(reg[6], MAKEINT(offset+Clen+1)))
  870.       {FAIL0;}
  871. }
  872.  
  873.  
  874. b_CONLENGTH()
  875. {
  876.    /* reg 1 is an internal constant or a number
  877.     * reg 2 is the length of the constant or number
  878.     */
  879.  
  880.    LONG     op1;
  881.    register LONG_PTR top;
  882.    LONG     len;
  883.  
  884.    op1 = reg[1];  DEREF(op1);
  885.  
  886.    if (ISATOM(op1)) {
  887. #ifdef  DEBUG_CONLENGTH
  888.       printf("b_CONLENGTH : ptr = %08x\n", GET_STR_PSC(op1));
  889.       printf("            :   type = %d  arity = %d  len = %d\n", 
  890.              GET_ETYPE(GET_STR_PSC(op1)), GET_ARITY(GET_STR_PSC(op1)),
  891.              GET_LENGTH(GET_STR_PSC(op1)));
  892.       printf("            :   name = %08x   %s\n",
  893.              GET_NAME(GET_STR_PSC(op1)), GET_NAME(GET_STR_PSC(op1)));
  894. #endif
  895.  
  896.       len = GET_E_LENGTH(GET_STR_PSC(op1));
  897.    }
  898.    else if (ISINTEGER(op1))
  899.       len = numlength(INTVAL(op1));
  900.    else if (ISFLOAT(op1)) {
  901.       printf("conlength: FLOAT case not implemented\n");
  902.       len = 0;
  903.    }
  904.    else {
  905.       errmsg(9);
  906.       FAIL0;
  907.       return;
  908.    }
  909.  
  910.    if (!unify(MAKEINT(len), reg[2]))
  911.       {FAIL0;}
  912. }
  913.  
  914. /*****************************************************************************/
  915. /* Routine name: errmsg                                                      */
  916. /* Input Parameter: errnum  type: short integer                              */
  917. /* Purpose:  To output a relevant message when an error occurs.              */
  918. /*****************************************************************************/
  919. errmsg(errnum)
  920. WORD errnum;
  921. {
  922.    switch (errnum) {
  923.       case  0: printf("Error: Direction parameter must must be a 0 or 1.\n");
  924.       case  1: printf("Error: Delimiter not found in buffer.\n");
  925.       case  2: printf("Error: Index into buffer is not an integer.\n");
  926.       case  3: printf("Error: Index into buffer is out of range.\n");
  927.       case  4: printf(
  928.       "Error: Constant and length params are both free or bound improperly.\n");
  929.       case  5: printf("Error: Nothing to write out in sub* backwards.\n");
  930.       case  6: printf("Error: Length must be bound in subnumber operation.\n");
  931.       case  7: printf(
  932.       "Error: Delimiter must be bound in subdelim operation.\n");
  933.       case  8: printf("Error: Input buffer is free or bound improperly.\n");
  934.       case  9: printf("Error: Improper argument to Conlength.\n");
  935.       case 10: printf("Error: Number too large for field in Subnumber.\n");
  936.       case 11: printf("Error: Illegal arg to buff_code.\n");
  937.    }
  938. }
  939.