/**
 * -- Dynamic-Strings words
 *
 * Copyright (C) 2001, 2002 David N. Williams
 *
 * @see LGPL 
 * @author David N. Williams              @(#) %derived_by: guidod %
 * @version %version: bln_mpt1!0.6.29 %
 *   (%date_modified: Tue Feb 25 13:20:50 2003 %)
 *     starting date: Sat Dec 16 14:00:00 2000
 * @description
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later
 * version.
 *
 * This library is distributed in the hope that it will be
 * useful, but WITHOUT ANY WARRANTY; without even the implied
 * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
 * PURPOSE. See the GNU Library General Public License for more
 * details.
 *
 * You should have received a copy of the GNU Lesser General
 * Public License along with this library; if not, write to the
 * Free Software Foundation, 59 Temple Place, Suite 330, Boston,
 * MA 02111-1307 USA.
 *
 * If you take advantage of the option in the LGPL to put a
 * particular version of this library part under the GPL, the
 * author would regard it as polite if you would put any direct
 * modifications under the LGPL as well, and include a copy of
 * this request near the beginning of the modified library
 * source.  A "direct modification" is one that enhances or
 * extends the library in line with its original concept, as
 * opposed to developing a distinct application or library which
 * might use it.
 * 
 * This code is based on the ^Forth Motorola 680x0 strings
 * package as of June, 1999.
 * 
 * Please direct any comments to david.n.williams@umich.edu.
 */

#include <pfe/def-config.h>

#if defined(__version_control__) && defined(__GNUC__)
static char* id __attribute__((unused)) = 
"@(#) $Id: %full_filespec:  dstrings-ext.c~bln_mpt1!0.6.29:csrc:bln_12xx!1 % $";
#endif

/* ------------------------------------------------------------------- */

#define _P4_SOURCE 1

#include <pfe/pfe-base.h>
#include <stddef.h>		/* offsetof() */
#include <pfe/dstrings-ext.h>	/* stdlib.h */
#include <string.h>

#include <pfe/option-ext.h>     /* p4_search_option_value */

/* make_str_frame_execution / marg_execution helper global for SEE */

static unsigned int frame_size;  

/* fixme: not MT but acceptable */

#ifdef WRONG_SPRINTF		/* provision for buggy sprintf (SunOS) */
#define SPRFIX(X) strlen(X)
#else
#define SPRFIX(X) X
#endif

#define P4_MARGS_MAGIC P4_MAGIC_('M','A','R','G')

/** MEASURED STRINGS
 *
 * This package uses a "measured string" representation for
 * strings in memory.  A measured string is the same as a Forth
 * counted string, except that instead of being restricted to
 * one character, the size of the count field is defined by the
 * implementation.  We default to unsigned long as the count
 * field type.  See dstrings-ext.h to change that.
 *
 * "Mstring" is short for "measured string".  The "MSA" is the
 * measured string address, the same as the count field address.
 */

/************************************************************************/
/* functions								*/
/************************************************************************/

/* STORE A FORTH STRING AS A MEASURED STRING
 *
 * These two functions store a Forth string into data space as a
 * measured string.  They throw an error if the count is larger
 * than MAX_DATA_STR, which is itself not larger than MAX_MCOUNT.
 * Zero padding, not included in the count, is added to the
 * string body up to the first cell boundary following the
 * string.
 */

static char *
p4_mstring_comma (const char *addr, size_t len)
{
  char *p = (char *) DP;
  char *limit;

  if (len >= MAX_DATA_STR)
    p4_throw (P4_ON_SCOUNT_OVERFLOW);

  *P4_VAR(MCount*,DP)++ = (MCount) len;    /* store count */
  while (len-- != 0)                  /* store string */
    *DP++ = (p4char) *addr++;

  limit = (char *) ALIGNTO_CELL (DP);
  while ( (char *) DP < limit ) 
    *DP++ = 0;
  return p;
}

static char *
p4_parse_mstring_comma (char del)
{
  /* uses now transient PFE.word. parse routines */
  p4_word_parse (del); *DP=0; /* PARSE-NOHERE */
  return p4_mstring_comma (PFE.word.ptr, (size_t) PFE.word.len);
}

/* CLEAR STRING SPACE
 *
 * Clear the string buffer, string stack, and string frame stack.
 * Any string variables holding strings in the string buffer are
 * left pointing into limbo.  This may be executed with the
 * string space in an invalid state, as long as the size and
 * numframes fields of its StrSpace structure are intact.
 */

void
p4_clear_str_space (StrSpace *space)
{
  size_t fstack_offset = ALIGNTO_CELL (sizeof (*space));
  size_t fstack_size = space->numframes * sizeof (StrFrame);

  space->fbreak = (void *) space + fstack_offset;
  space->fp0 = space->fp = (void *) space->fbreak + fstack_size;
  space->buf = space->sbreak = (void *)space->fp0;
  space->sp0 = space->sp = (void *) space->buf + space->size;
  space->cat_str = NULL;
  space->garbage_flag = space->garbage_lock = 0;
  *space->sp0 = NULL;	/* string stack underflow guard, not used */
}

/* MAKE A STRING SPACE
 *
 * Allocate and initialize a string space with string buffer
 * including string stack of prescribed size, and a prescribed
 * number of string stack frames.  The size is rounded up for
 * cell alignment, and the buffer begins and ends with that
 * alignment.
 *   
 * Return the address of the string space.
 */

StrSpace *
p4_make_str_space (size_t size, size_t frames)
{
  StrSpace *space;
  size_t fstack_offset = ALIGNTO_CELL (sizeof (*space));
  size_t fstack_size = frames * sizeof (StrFrame);

  size = ALIGNTO_CELL (size);
  space = (StrSpace *) p4_xalloc (size + PFE_SIZEOF_CELL
          + fstack_offset + fstack_size);
   if (space == NULL)
    p4_throw (P4_ON_OUT_OF_MEMORY);
  space->size = size;
  space->numframes = frames;
  p4_clear_str_space ( space );
  return space;
}

/* COLLECT GARBAGE FROM STRING SPACE
 *
 * The garbage flag in the current string space structure is
 * tested, and if there is garbage, it is collected, unless
 * garbage collection is locked.  Garbage strings are marked by
 * null backward links.  Nongarbage strings are bound by their
 * backward links, pointing either to a string variable data
 * field address or to an entry on the string stack (the deepest
 * if there are several identical references).
 *
 * Garbage collection fills the gaps occupied by garbage strings
 * by moving any nongarbage strings to lower memory one at a
 * time.  The backward link of a string that is moved does not
 * change, but the forward links, in at most one string variable
 * and/or possibly several string stack entries, are updated to
 * point to the new MSA.  This algorithm is "fast" because the
 * backward links make it unnecessary to scan a list of string
 * variables, and because no string is moved more than once.  It
 * does, however, require a scan of the string stack for each
 * string that moves, unless it is the current concatenation
 * string, which is guaranteed not to be on the string stack.
 *
 * When there is no garbage to collect, this routine returns 0.
 * If there is garbage, it throws an error when garbage
 * collection is locked.  Otherwise it collects the garbage and
 * returns 1.
 */

int
p4_collect_garbage (void)
{
  DStr *next, *target;
  MStr **sstack;
  char *p, *q, *limit;

  if ( !GARBAGE_FLAG ) 
    return 0;		/* no garbage to collect */

  if ( GARBAGE_LOCK ) p4_throw (P4_ON_SGARBAGE_LOCK);

  GARBAGE_FLAG = 0;
  next = SBUFFER;

  /* locate first garbage hole (no need to check off end, because we
     know there is a hole) */
  while ( next->backlink )
    {	    /* not garbage, skip to next */
      next = (DStr*)ALIGNTO_CELL(next + sizeof (next->backlink)
             + sizeof (next->count) + next->count);
    }
  target = next;

  do	    /* not off end, garbage hole found */
    {
      /* skip over garbage */
      while ( !next->backlink && next < SBREAK )
	{	/* garbage and not off end, skip to next */
	  next = (DStr*) ALIGNTO_CELL (next + sizeof (next->backlink)
	         + sizeof (next->count)
	         + next->count);
	}

      /* BEGIN move and update until next garbage */
      while ( next->backlink && next < SBREAK )
	{	/* not garbage and not off end */
	  target->backlink = next->backlink;
	  target->count = next->count;

	  /* We always update the forward link pointed to by the
	     backward link.  The backward link points to one of:
	     a string variable, a deepest string stack entry,
	     or CAT$. */
	   
	  *(next->backlink) = (MStr*) &(target->count);

	  /* Unless the backward link points to CAT$, we scan
	     the string stack and update copies of the old
	     forward link.  Note that if the backward link
	     points into the string stack, we've already updated
	     the deepest reference, which won't be found in the
	     scan. */

	  if ( next->backlink != (MStr**) &CAT_STR )
	    {
 	      for ( sstack = SSP; sstack < SSP0; sstack++ )
		if ( *sstack == (MStr*) &(next->count) )
		  *sstack = (MStr*) &(target->count);
	    }

	  /* move string, including null fill, to hole */
	  q = (char*) &(target->body);
	  p = (char*) &(next->body);
	  limit = (char*) ALIGNTO_CELL (p + next->count);
	  while ( p < limit )
	    *q++ = *p++;
	  next = (DStr*) p;
 	  target = (DStr*) q;
	}
      /* END move and update until next garbage */
    }
  while ( next < SBREAK );

  SBREAK = target; 
  return 1;
}

/* POP STRING AND MARK GARBAGE
 *
 * Throw an error if the string stack would underflow when
 * popped.
 *
 * Otherwise increment the string stack pointer, thus popping the
 * string stack.
 * 
 * If the old string is in the current string space and bound to
 * the old string stack position, set its back link to NULL and
 * set the garbage flag.
 */

MStr *
p4_pop_str (void)
{
  MStr **strsp = SSP;

  if (strsp == SSP0) p4_throw (P4_ON_SSTACK_UNDERFLOW);
  SSP += 1;

  if ( *strsp >= (MStr *) SBUFFER
       && *strsp < (MStr *) SBREAK
       && *((p4cell **) (*strsp)-1) == (p4cell *) strsp )
    {
      *((p4cell **) (*strsp)-1) = NULL;
      GARBAGE_FLAG = ~0;
    };

  return *strsp;
}

/* DROP ALL STRINGS AND FRAMES
 *
 * Clear the string stack, string frame stack, and any
 * concatenating string in a string space.  Dynamic strings held
 * in string variables remain.  This word is called by ABORT with
 * the current string space.  We decided not to do a garbage
 * collection here because it's used when there's an error, and
 * we might want to dump string space for debugging.
 */

void
p4_drop_all_strings (StrSpace *space)
{
  int depth = space->sp0 - space->sp;
  int i;

  space->fp = space->fp0;	/* drop string frames */
  if (space->cat_str)
    {
      *(p4ucell *)((size_t) space->cat_str - PFE_SIZEOF_CELL) = 0;
      space->cat_str = NULL;
    }

  for (i = 0; i < depth; i++)
    p4_pop_str ();
}

/* PUSH STRING WITH COPY INTO STRING SPACE
 *
 * See the word >$S-COPY for the specs.
 */

void
p4_push_str_copy (char *addr, size_t len)
{
  char *buf;

  Q_CAT;

/* Required for Forth string copies, superfluous
   for mstring copies, insignificant overhead: */
#if MAX_MCOUNT < UCELL_MAX
  if (len > MAX_MCOUNT)
    p4_throw (P4_ON_DSCOUNT_OVERFLOW);
#endif

  Q_ROOM (SBREAK, len + SIZEOF_DSTR_HEADER + PFE_SIZEOF_CELL);

  /* Don't do earlier, maybe garbage was collected: */
  buf = (char*) SBREAK;

  *P4_VAR(MStr**,buf)++ = (MStr*) --SSP;   /* back link */
  *SSP = (MStr*) buf;			/* forward link */
  *P4_VAR(MCount*,buf)++ = (MCount) len;
 
  while (len-- > 0)			/* copy string body */
    *buf++ = *addr++;
 
  addr = (char*) ALIGNTO_CELL (buf);	/* null fill */
  while (buf < addr) 
    *buf++ = 0;

  SBREAK = (DStr*) buf;
}

/* FIND ARGUMENT IN STRING FRAME
 *
 * Search the top string frame for a match to a Forth string and
 * return its index if found, else return -1.
 *
 * NOTE:  The index starts with 0 at the top of the string frame.
 * On the other hand, dynamic-strings words maintain the natural
 * left to right ordering for arguments in string stack comments.
 */

int
p4_find_arg (char *nm, int l)
{
  MStr **ssp = SFSP->top;
  MStr *p;
  int i;

  for (i = 0; i < SFSP->num; i++)
    {
      p = *(ssp++);
      if (l == MLEN (p) && memcmp (nm, MADDR (p), l) == 0)  
        return i;
    }
  return -1;
}

/* MAKE STRING FRAME
 *
 * Define the top n items on the string stack as a string frame
 * by pushing n and the SSP onto the string frame stack.  Errors
 * are thrown if there is not enough room on the string frame
 * stack or if there are not at least n items on the top of the
 * string stack above any previous string frame.
 */

void
p4_make_str_frame (p4ucell n)
{
  if (SFSP == SFBREAK)
    p4_throw (P4_ON_SFRAME_OVERFLOW);
  if (n > (SFSP - (StrFrame *) SSP))
    p4_throw (P4_ON_SFRAME_ITEMS);
  SFSP -= 1 ;
  SFSP->top = SSP;
  SFSP->num = n;
}

/* COMPILE MACRO ARGUMENT 
 *
 * Search for a string in the top string stack frame.  If found,
 * compile run-time code that concatenates the corresponding
 * string in the top run-time string frame onto the current CAT$.
 *
 * This code imitates PFE code for compiling a local.  It is
 * intended for use in a modified INTERPRET.
 */

FCode_XE (p4_marg_execution)
{
  FX_USE_CODE_ADDR
  PUSH_STR ((MStr *) (SFSP->top)[(p4cell) *IP++]);
  FX (p4_cat);
}

/* Warning: this one P4COMPILES an marg_execution. To decompile
 * please ensure that a proper marg_SEE is defined upwards.
 */
int
p4_compile_marg (char *name, int len)
{
  int n;

  if ((n = p4_find_arg (name, len)) == -1)
    return 0;
  FX_COMPILE(p4_marg_execution);
  FX_UCOMMA (n);
  return 1;
}

static p4xt*
p4_marg_SEE (p4xt* ip, char* p, p4_Semant* s)
{
    sprintf (p, "<%c> ", 'A' + frame_size - 1 - (p4cell ) *ip);
    return ++ip;
}

P4COMPILES (p4_marg_execution, p4_marg_execution,
	    p4_marg_SEE, P4_DEFAULT_STYLE);

/************************************************************************/
/* constants								*/
/************************************************************************/

struct p4_MStr p4_empty_str =
{ 
  0,		/* count */
  0		/* superfluous body */
};

struct p4_MStr p4_newline_str =
{ 
  1,		/* count */
  '\n'		/* body */
};

/** EMPTY$	( $: -- empty$ )
 * Push the MSA of a fixed, external representation of the empty
 * string onto the string stack.  "empty-string"
 */
FCode (p4_empty_str)
{
  PUSH_STR (&p4_empty_str);
}

/** \n$		( $: -- newline$ )
 * Push the MSA of a fixed, external string whose body is the
 * Unix newline character onto the string stack.
 * "newline-string"
*/
FCode (p4_newline_str)
{
  PUSH_STR (&p4_newline_str);
}

/************************************************************************/
/* variables								*/
/************************************************************************/

/** DSTRINGS	( -- dfa )
 * A Forth variable that holds the address of the current string
 * space, where all dynamic string operations take place. 
 * "d-strings"
*/

/************************************************************************/
/* Forth string extensions						*/
/************************************************************************/

/** S,		( addr len -- addr' len )
 * ALLOT room and store the Forth string into data space as an
 * mstring, leaving data space aligned; and leave the length and
 * new body address.  It is assumed that len is unsigned.  An
 * error is thrown if len is larger than the system parameter
 * MAX_DATA_STR.  "s-comma"
 *
 * NOTE: MAX_DATA_STR is returned by 
   S" /SCOPY" ENVIRONMENT?
 *
 * Perhaps this restriction should be removed in favor of a
 * normal data space overflow error.
 *
 * NOTE: S, is the same as STRING, in Wil Baden's Tool Belt,
 * except it stores a measured string instead of a counted
 * string.
 */
FCode (p4_s_comma)
{
  SP[1] = (p4cell) ( p4_mstring_comma ((char*) SP[1], (size_t) *SP)
		     + SIZEOF_MCOUNT );
}

/************************************************************************/
/* string space								*/
/************************************************************************/

/** 0STRINGS	( -- )
 * Set all string variables holding bound string values in string
 * space to the empty string, and clear string space, including
 * the string buffer, string stack, and string stack frames. 
 * "zero-strings"

 * NOTE:  If used for under the hood development, this word must
 * be executed only when string space is in a valid state.
 */
FCode (p4_zero_strings)
{
  DStr *next = SBUFFER;

  while (next < SBREAK)
    {   
      if (next->backlink)
	*(next->backlink) = &p4_empty_str;
      next = (DStr*) ALIGNTO_CELL ((size_t)next
	     + offsetof (DStr, body) + next->count);
    }
  p4_clear_str_space (DSTRINGS);
}

/** $GARBAGE?	( -- flag )
 * Leave true if there is garbage in the current string space. 
 * Not normally used, since garbage collection is transparent.
 * "string-garbage-question"

 */
FCode (str_garbage_Q)
{
  *--SP = (p4cell) GARBAGE_FLAG;
}

/** $GC-OFF	( -- )
 * Disable garbage collection in the current string space.  An
 * error will be thrown if garbage collection is attempted.
 * "string-g-c-on"
*/

FCode (p4_str_gc_off)
{
  GARBAGE_LOCK = ~0;
}

/** $GC-ON	( -- )
 * Enable garbage collection in the current string space.  This
 * is the default.  "string-g-c-off"
 */

FCode (p4_str_gc_on)
{
  GARBAGE_LOCK = 0;
}

/** $UNUSED	( -- u )
 * Leave the number of bytes available for dynamic strings and
 * string stack entries in the string buffer. 
 * "string-unused"
 */

FCode (p4_str_unused)
{
  *--SP = (p4cell) SSP - (p4cell) SBREAK; 
}

/** COLLECT-$GARBAGE	( -- collected-flag )
 * If string space is not marked as containing garbage, return
 * false.  If there is garbage, throw an error when garbage
 * collection is disabled.  Otherwise remove the garbage and return
 * true.  Garbage collection is "transparent", so the user would
 * not normally use this word.
 * "collect-string-garbage"
 */
FCode (p4_collect_str_garbage)
{
  p4_collect_garbage () ? (*--SP = ~0) : (*--SP = 0);
}

/** MAKE-$SPACE		( size #frames -- addr )
 * Allocate and initialize a string space with size bytes
 * available for the string buffer including the string stack,
 * and with a string frame stack for frame description entries
 * holding up to #frames.  The size is rounded up to cell
 * alignment, and the buffer begins and ends with cell alignment.
 * Return addr, the address of the string space.  The standard
 * word FREE with addr as input can be used to release the space.
 * "make-string-space"
 */
FCode (p4_make_str_space)
{
  SP[1] = (p4cell) p4_make_str_space (SP[1], SP[0]);
  SP += 1;
}

/************************************************************************/
/* string compilation							*/
/************************************************************************/

/** $"		( [ccc<">] -- $: str )

 * Parse ccc delimited by " (double-quote) and store it in data
 * space as an mstring.  If interpreting, leave the MSA on the
 * string stack.  If compiling, append run-time semantics to the
 * current definition that leaves the MSA on the string stack. 
 * A program should not alter the stored string.  An error is
 * thrown if the quoted string length is larger than the system
 * parameter MAX_DATA_STR (see S,).
 * "string-quote"

 * NOTE:  In contrast to S", the string stored by $" when
 * interpreting is not transient.

 * The implementation is based on PFE code for S".
 */
FCode (p4_str_quote)
{
  if (STATE)
    {
      FX_COMPILE (p4_str_quote);
      p4_parse_mstring_comma ('"');
    }
  else
    {
      PUSH_STR ((MStr *) p4_parse_mstring_comma ('"'));
    }
}

FCode_XE (p4_str_quote_execution)
{
  FX_USE_CODE_ADDR
  PUSH_STR ((MStr *) IP);
  FX_SKIP_MSTRING;
}

static p4xt* /* P4_SKIPS_MSTRING */
p4_lit_mstring_SEE (p4xt* ip, char* p, p4_Semant* s)
{
    sprintf (p, "%.*s %.*s\" ",
      NFACNT(*s->name), s->name + 1,
      (int) *(p4_MCount *) ip, (p4char *) ip + sizeof(p4_MCount));
    P4_SKIP_MSTRING (ip);
    return ip;
}

P4COMPILES (p4_str_quote, p4_str_quote_execution,
	    p4_lit_mstring_SEE, P4_DEFAULT_STYLE);

/** $CONSTANT	( "name" $: a$ -- )
 * Create a definition for "name" with the execution semantics
 * "name" execution:	($: -- a$ )

 * It is assumed that the input string resides as a measured,
 * unchanging string outside of string space. 
 * "string-constant"

 * For example:
   $" This is a sample string." $constant sample$
 */
FCode (p4_str_constant)
{
  FX_RUNTIME_HEADER;
  FX_RUNTIME1 (p4_str_constant);
  FX_PCOMMA (p4_pop_str ());
}

FCode_RT (p4_str_constant_RT)
{
  FX_USE_BODY_ADDR
  PUSH_STR ((MStr *) FX_POP_BODY_ADDR[0]);
}

P4RUNTIME1(p4_str_constant, p4_str_constant_RT);

/** $VARIABLE		( "name" -- )
   "name" execution:	( -- dfa )

 * Create an ordinary Forth variable and initialize it to the
 * address of a fixed, external, measured representation of the
 * empty string, such as that pushed onto the string stack by
 * EMPTY$.  "string-variable""
 */
FCode (p4_str_variable)
{
  FX_RUNTIME_HEADER;
  FX_RUNTIME1 (p4_variable);
  FX_PCOMMA (&p4_empty_str);
}

/** ($:		( "ccc" -- )
 * A synonym for (.  Immediate. 
 * "paren-string-colon"
 */

/* EXIT helper called by a semicolon in the sources */
static void p4_margs_EXIT(P4_VOID)
{
  extern FCode (p4_do_drop_str_frame);
  FX (p4_do_drop_str_frame);
  p4_Q_pairs (P4_MARGS_MAGIC);
  
  { 
    register p4code semicolon_code = (p4code) FX_POP; 
    semicolon_code(FX_VOID); /* pushed in p4_args_brace */
  }
}

/** ARGS{	 ( arg1'$ ... argN'$ "arg1 ... argN <}>" --  )
    compilation: ( -- $: arg1$ ... argN$ )

 * Immediate and compilation-only.

 * Copy the argument strings to the string buffer, push them
 * onto the string stack with "argN" the most accessible, and
 * make them into the top compile-time string stack frame. 
 * Compile the run-time code to make an argument frame out of
 * the N most accessible run-time string stack entries.  Inform
 * the system text interpreter that it should compile run-time
 * code for any white-space delimited argument encountered in
 * the text of the definition, that concatenates the
 * corresponding string in the run-time frame.  At the semicolon
 * terminating the definition, drop the compile-time argument
 * frame and compile code to drop the run-time argument frame.
 * "args-brace"

 * Syntax for defining a string macro GEORGE:

	: george  ($: a$ b$ c$ -- cat$ )
	  args{ arg1 arg2 arg3 }
	  cat" This is arg1:  " arg1 cat" ." ENDCAT ;

 * The blank following the last argument is required.  For a
 * macro with no arguments, ARGS{ } does nothing but add
 * useless overhead and should be omitted.  Two of the
 * arguments in this example are ignored and could have been
 * left out.  Words intended only as steps in building a macro
 * would omit ENDCAT, which terminates concatenation and
 * leaves the concatenated string on the string stack.

 * Sample syntax using the string macro GEORGE:

    $" bill"  $" sue"  $" marie"  george $.

 * The resulting display is:

     This is arg1:  bill.

 * NOTE: Macro argument labels must be distinct from each other
 * and from any local labels that appear in the same definition,
 * and there is no check for that.

 * NOTE: At the moment the semantics of ARGS{ is undefined
 * before DOES>.
 */
FCode (p4_args_brace)
{
  register int i;

  FX (p4_Q_comp);
  for (i = 0;; i++)
    {
      p4_word_parseword (' '); *DP=0; /* PARSE-WORD-NOHERE */
      if (PFE.word.len == 1 && *PFE.word.ptr == '}')
        break;	/* if never taken, string space overflows */
      p4_push_str_copy (PFE.word.ptr, PFE.word.len);
    }

if (i)
  {
    p4_make_str_frame (i);
    FX_COMPILE(p4_args_brace);
    FX_UCOMMA (i);
    MARGS_FLAG = ~0;
    FX_PUSH (PFE.semicolon_code);
    FX_PUSH (P4_MARGS_MAGIC);
    PFE.semicolon_code = p4_margs_EXIT;
  }

}

FCode_XE (p4_make_str_frame_execution)
{
  FX_USE_CODE_ADDR
  p4_make_str_frame ((p4ucell) *IP++);
}

static p4xt*
p4_make_str_frame_SEE (p4xt* ip, char* p, p4_Semant* s)
{
    int i;
/*    unsigned int frame_size; */
        
    frame_size = (p4cell) *ip;
    p += SPRFIX (sprintf (p, "ARGS{ "));
    for (i = frame_size; --i >= 0;)
        p += SPRFIX (sprintf (p, "<%c> ", 'A' - 1 + (p4cell) *ip - i));
    p += SPRFIX (sprintf (p, "} "));
    return ++ip;
}

P4COMPILES(p4_args_brace, p4_make_str_frame_execution, 
	   p4_make_str_frame_SEE, P4_LOCALS_STYLE);

/** CAT"	( "ccc" -- )
 * This word has only compile-time semantics, just like CAT`.
 * It appends run-time semantics to the current definition that
 * concatenates the quoted string according to the specification
 * for CAT.  An error is thrown if the length of the quoted
 * string is longer than the system parameter MAX_DATA_STR (see
 * S,).  "cat-quote"
 */
FCode (p4_cat_quote)
{
  FX_COMPILE (p4_cat_quote);
  p4_parse_mstring_comma ('"');
}

FCode_XE (p4_cat_quote_execution)
{
  FX_USE_CODE_ADDR
  PUSH_STR ((MStr *) IP);
  FX_SKIP_MSTRING;
  FX (p4_cat);
}

P4COMPILES (p4_cat_quote, p4_cat_quote_execution,
            p4_lit_mstring_SEE, P4_DEFAULT_STYLE);

/** CAT`	( "ccc" -- )
 * This word has only compile-time semantics, just like
 * CAT". It appends run-time semantics to the current
 * definition that concatenates the back-ticked string according
 * to the specification for CAT.  An error is thrown if the
 * length of the quoted string is longer than the system
 * parameter MAX_DATA_STR (see S,).
 * "cat-back-tick"
 */
FCode (p4_cat_back_tick)
{
  FX_COMPILE (p4_cat_back_tick);
  p4_parse_mstring_comma ('`');
}

static p4xt* /* P4_SKIPS_MSTRING_BACK_TICK */
p4_lit_mstring_back_tick_SEE (p4xt* ip, char* p, p4_Semant* s)
{
    sprintf (p, "%.*s %.*s` ",
      NFACNT(*s->name), s->name + 1,
      (int) *(p4_MCount *) ip, (p4char *) ip + sizeof(p4_MCount));
    P4_SKIP_MSTRING (ip);
    return ip;
}

P4COMPILES (p4_cat_back_tick, p4_cat_quote_execution,
	    p4_lit_mstring_back_tick_SEE, P4_DEFAULT_STYLE);

/************************************************************************/
/* string stack operations						*/
/************************************************************************/

/** $2DROP	( $: a$ b$ --  )
 * Drop the two topmost string stack entries, marking them as
 * garbage if appropriate.  "string-two-drop"
 */
FCode (p4_str_two_drop)
{
  p4_pop_str (); p4_pop_str ();
}

/** $2DUP	( $: a$ b$ -- a$ b$ a$ b$ )
 * Leave copies of the two topmost string stack entries.  The string
 * values are not copied.  "string-two-dupe"
 */
FCode (p4_str_two_dup)
{
  if (SSP0 - SSP < 2)
    p4_throw (P4_ON_SSTACK_UNDERFLOW);
  P4_Q_ROOM (SBREAK, PFE_SIZEOF_CELL * 2);
  SSP -= 2;
  SSP[0] = SSP[2];  SSP[1] = SSP[3];
}

/** $DEPTH	( -- n )
 * Leave the number of items on the string stack.
 * "string-depth"
 */
FCode (p4_str_depth)
{
  *--SP = (SSP0 - SSP);
}

/** $DROP	( $:  a$ -- )
 * Drop the topmost string stack entry, marking it as garbage if
 * it is initially bound to the top of the string stack.
 * "string-drop"
 */
FCode(p4_str_drop)
{
 p4_pop_str ();
}

/** $DUP	( $: a$ -- a$ a$ )
 * Leave a copy of the topmost string stack entry.  The string
 * value is not copied.  "string-dupe"
 */
FCode (p4_str_dup)
{
  MStr **strsp;

  strsp = SSP;
  if (strsp == SSP0)
   p4_throw (P4_ON_SSTACK_UNDERFLOW);
  PUSH_STR (*strsp);
}

/** $NIP	($: a$ b$ -- b$ )
 * Drop the next to top item from the string stack.
 * "string-nip"

 * NOTE:  Because of essential string  space bookkeeping, the
 * system level implementation can be little more efficient than
 * the high-level definition:
     	: $NIP  $SWAP $DROP ;
 */
FCode (p4_str_nip)
{
  FX (p4_str_swap);  FX (p4_str_drop);
}

/** $OVER	( $: a$ b$ -- a$ b$ a$ )
 * Leave a copy of the next most accessible string stack entry
 * on top of the string stack.  The string value is not copied.
 * "string-over"
 */
FCode (p4_str_over)
{
  if (SSP0 - SSP < 2)
    p4_throw (P4_ON_SSTACK_UNDERFLOW);
  PUSH_STR (SSP[2]);
}

/** $PICK	( u $: au$ ... a0$ -- au$ ... a0$ au$ )
 * Copy the u-th string stack entry to the top of the string
 * stack.  The string value is not copied.  Throw an error if
 * the input string stack does not have at least u+1 items. 
 * "string-pick"
 */
FCode (p4_str_pick)
{
  p4ucell u = *SP++;

  if (SSP0 - SSP < u + 1) 
    p4_throw (P4_ON_SSTACK_UNDERFLOW);
  PUSH_STR (SSP[u + 1]);
}

/** $SWAP	( $: a$ b$ -- b$ a$ )
 * Exchange the two most accessible strings on the string stack.
 * Throw an error if there are less than two strings on the
 * stack.  Neither string value is copied.
 * "string-swap"
*/
FCode (p4_str_swap)
{
  MStr *str1, *str2;
  char **blp;	/* back link pointer */

  if ( (SSP0 - SSP) < 2 )
   p4_throw (P4_ON_SSTACK_UNDERFLOW);
  str1 = SSP[1];
  str2 = SSP[0];

  if ( !(str1 == str2) )
    {
      SSP[0] = str1;
      SSP[1] = str2;

      if ( str1 >= (MStr *) SBUFFER && str1 < (MStr *) SBREAK )
	{
	blp = (char **) ((size_t) str1 - PFE_SIZEOF_CELL);
	if ( *blp == (char *) (&SSP[1]) )
	  *blp = (char *) SSP;
	}

      if ( str2 >= (MStr *) SBUFFER && str2 < (MStr *) SBREAK )
	{
	blp = (char **) ((size_t) str2 - PFE_SIZEOF_CELL);
	if ( *blp == (char *) SSP )
	  *blp = (char *) &SSP[1];
	}
    }
}

/** $S>		( $: a$ -- S: a.str )
 * Drop a$ from the string stack and leave it as a Forth string
 * a.str, without copying.  "string-s-from"

 * WARNING:  If a$ is a bound string, it may move or disappear
 * at the next garbage collection, making a.str invalid.  This
 * can be avoided by sandwiching sections of code where this
 * could occur between $GC-OFF and $GC-ON.
 */
FCode (p4_str_s_from)
{
  MStr *str = p4_pop_str ();

  *--SP = (p4cell) str + SIZEOF_MCOUNT;
  *--SP = str->count;
}

/** $S>-COPY	( $: a$ -- S: a.str )
 * Drop a$ from the string stack, copy it into data space as a
 * measured string, and leave it as a Forth string a.str.  An
 * error is thrown if the string length is larger than the
 * system parameter MAX_DATA_STR (see S,).
 * "string-s-from-copy"
 */
FCode (p4_str_s_from_copy)
{
  MStr *str = p4_pop_str ();
  MStr *p = (MStr *) p4_mstring_comma (MADDR (str), MLEN (str));

  *--SP = (p4cell) MADDR (p);
  *--SP = MLEN (p);
}

/** $S@ 	( $: a$ -- a$ S: a.str )
 * Leave the string stack unchanged, and leave the string body
 * address and length on the data stack. 
 * "string-s-fetch"

 * NOTE:  In earlier versions this was call $S@S.  The trailing
 * "S" is superfluous if it is understood that the only string
 * format that usually appears on the data stack is the Forth
 * string format.

 * WARNING:  If a$ is a bound string, it may move at the next
 * garbage collection, making a.str invalid.  This can be
 * avoided by sandwiching sections of code where this could
 * occur between $GC-OFF and $GC-ON.
 */
FCode (p4_str_s_fetch)
{
  if (SSP == SSP0)
    p4_throw (P4_ON_SSTACK_UNDERFLOW);
  *--SP = (p4cell) MADDR (*SSP);
  *--SP = MLEN (*SSP);
}

/** $TUCK	($: a$ b$ -- b$ a$ b$ )
 * Copy the top string stack item just below the second item.  The
 * string value is not copied.  "string-tuck"

 * NOTE:  Because of essential string  space bookkeeping, the
 * system level implementation can be little more efficient than
 * the high-level definition:
 	: $TUCK  $SWAP $OVER ;
 */
FCode (p4_str_tuck)
{
  FX (p4_str_swap);  FX (p4_str_over);
}

/** >$S		( a.str -- $: a$ )
 * Push the external Forth string a.str onto the string stack,
 * without copying the string value into the string buffer.  It
 * is an unchecked error if the Forth string a.str is not stored
 * as an external measured string.
 * "to-string-s"

 * WARNING: If the string value of a.str is actually in the
 * string buffer and not external, the push operation may
 * generate a garbage collection that invalidates its MSA.
 */
FCode (p4_to_str_s)
{
  SP += 1;		/* drop length */
  PUSH_STR ((void*) *SP++ - SIZEOF_MCOUNT);
}

/** >$S-COPY	( a.str -- $: a$ )
 * Copy the external string value whose body address and count
 * are on the parameter stack into the string buffer and push it
 * onto the string stack. Errors are thrown if the count is
 * larger than MAX_MCOUNT, if there is not enough room in string
 * space, even after garbage collection, or if there is an
 * unterminated string concatenation.  The input external string
 * need not exist as a measured string. 
 * "to-string-s-copy"

 * NOTE:  MAX_MCOUNT is the largest size the count field of a
 * measured string can hold, e.g., 255, 64K-1, or 4,096M-1.  It
 * is returned by: S" /DYNAMIC-STRING" ENVIRONMENT?

 * WARNING: This word should not be used when the input string
 * is a bound string because the copy operation may generate a
 * garbage collection which invalidates its MSA.
 */
FCode (p4_to_str_s_copy)
{
  p4_push_str_copy ((char *) SP[1], SP[0]);
  SP += 2;
}

/************************************************************************/
/* string manipulation							*/
/************************************************************************/

/** $!		( $var.dfa $: a$ -- )
 * Store the string MSA on the string stack in the variable
 * whose DFA is on the parameter stack. 
 * "string-store"

 * NOTES: The only situation in which $! copies the string
 * value is when it is a bound string already stored in another
 * variable.  In that case, the new copy is the one that is
 * stored in the variable.  In particular, external strings are
 * not copied.

 * If the string value held by the string variable on entry is a
 * bound string that is also referenced deeper on the string
 * stack, its back link is reset to point to the deepest string
 * stack reference.  If it is a bound string not deeper on the
 * string stack and not identical to the input string, its back
 * link is set to zero, making it garbage.  If it is an external
 * string, its MSA in the variable is simply written over by
 * that popped from the string stack.
 */
FCode (p4_str_store)
{
  MStr **addr, **strsp, *oldstr, *newstr;
  int oldext, newext;	/* true if old/new strings external */ 
  char **backlink;
  char *next;

  size_t len;
  char *buf;

  addr = (MStr **) *SP++;
  oldstr = *addr;
  oldext = (oldstr < (MStr *) SBUFFER || oldstr >= (MStr *) SBREAK);

  strsp = SSP;	/* not ready to pop if copy causes garbage collection */
  if (strsp == SSP0)
    p4_throw (P4_ON_SSTACK_UNDERFLOW);
  newstr = *strsp;
  newext = (newstr < (MStr *) SBUFFER || newstr>= (MStr *) SBREAK);

  if ( !(oldext && newext) && !(!oldext && newstr == oldstr) )
    { /* We know the new string is not bound to our variable. */ 

      /* Do old string first; it might open a garbage hole, more room
	 in case new string is copied. */
      if (!oldext)
	{
	  backlink = (char **)((size_t) oldstr - PFE_SIZEOF_CELL);
	  next = NULL;		  /* garbage if not on stack */
	  while (++strsp < SSP0)  /* no need to check first stack item */
	    if (*strsp == oldstr) next = (char*) strsp;
	  *backlink = next;
	  if (!next)
	    GARBAGE_FLAG = ~0;
	}

      if (!newext)
	{
	  backlink = (char **) ((size_t) newstr - PFE_SIZEOF_CELL); 
	  if (*backlink < (char*) SSP || *backlink >= (char*) SSP0)
	    { /* New string is bound to a different variable, copy it. */

	      Q_CAT;
	      len = newstr->count;
	      Q_ROOM (SBREAK, len + SIZEOF_DSTR_HEADER);
	      /* garbage possibly collected */

	      backlink = (char**) SBREAK;
	      SBREAK->count = len;

	      buf = &(SBREAK->body);
	      P4_VAR(char*,newstr) = (char*) *SSP + SIZEOF_MCOUNT;

	      while (len-- > 0)			/* copy string body */
		*buf++ = *P4_VAR(char*,newstr)++;
 
	      P4_VAR(char*,newstr) = (char*) ALIGNTO_CELL (buf); /* null fill*/
	      while (buf < (char*) newstr) 
		*buf++ = 0;

	      SBREAK = (DStr*) buf;
	      newstr = (MStr*) (backlink + offsetof (DStr, count));
	    }
	  *backlink = (char*) addr;
	}
    }
  *addr = newstr;
  SSP += 1;	/* now I tin pop */
}

/** $.		( $: a$ -- )
 * Display the string on the terminal.  If the system
 * implementation of TYPE has its output vectored, $. uses the
 * same vector. "string-dot"
 */
FCode (p4_str_dot)
{
  MStr *str = p4_pop_str ();

  p4_type (MADDR (str), MLEN (str));
}

/** $@		( $var.pfa -- $: a$ )
 * Leave the MSA of the string held by the string variable.
 * "string-fetch"
 */
FCode (p4_str_fetch)
{
  PUSH_STR ((MStr*) *(char**) (*SP++));
}

/** $TYPE	($: a$ -- )
 * Display the string on the terminal.  A $. synonym.  
 * "string-type"
 */

/** CAT		($: a$ -- )
 * Append the string body to the end of the string currently
 * being concatenated as the last string in the string buffer,
 * and update its count field.  If there is no concatenating
 * string, start one.  An error is thrown if the size of the
 * combined string would be larger than MAX_MCOUNT or if there
 * is not enough room in string space even after a garbage
 * collection.

 * If garbage collection occurs, a$ remains valid even when
 * it is in the string buffer.
 
 * When there is a concatenating string, concatenation is the
 * only basic string operation that can copy a string into the
 * string buffer.  "cat"

 * NOTE: It is left to the user to define special concatenating
 * words like:
    : \n-cat  ( -- )  \n$ cat ;
 */
FCode (p4_cat)
{
  char *p,*q;
/*  size_t len, delta = *(MCount*) *SSP; */
  size_t delta = *(MCount*) *SSP;

  if (SSP == SSP0)
    p4_throw (P4_ON_SSTACK_UNDERFLOW);

  if (!CAT_STR)		/* copy first string */
    {
      Q_ROOM (SBREAK, delta + SIZEOF_DSTR_HEADER - PFE_SIZEOF_CELL);
      P4_VAR(MStr*,p) = p4_pop_str ();	/* pop ok after gc */
      P4_VAR(MCount*,p) += 1;
      P4_VAR(DStr*,q) = SBREAK;   
      *P4_VAR(MStr**,q)++ = (MStr *) &CAT_STR;	/* back link */
      CAT_STR = (MStr *) q;			/* forward link */
      *P4_VAR(MCount*,q)++ = delta;
      while (delta-- > 0)
	*q++ = *p++;
    }
  else			/* append next string */
    {
      size_t len = MLEN (CAT_STR);
      size_t newlen = len + delta;

#if MAX_MCOUNT < UCELL_MAX
      if (newlen > MAX_MCOUNT)
        p4_throw (P4_ON_DSCOUNT_OVERFLOW);
#endif
      Q_ROOM (CAT_STR, SIZEOF_MCOUNT + newlen - PFE_SIZEOF_CELL);
      P4_VAR(MStr*,p) = p4_pop_str ();	/* pop ok after gc */
      P4_VAR(MCount*,p) += 1;
      q = (char *) CAT_STR;
      *(MCount *) q = newlen;
      q += len + SIZEOF_MCOUNT;
      while (delta-- > 0)
        *q++ = *p++;
    }

  /* null fill */
  P4_VAR(char*,p) = (char*) ALIGNTO_CELL (q);
  while (q < p)
    *q++ = 0;
  SBREAK = (DStr *) q;
}

/** S-CAT	( a.str -- )
 * Append the Forth string body to the end of the string
 * currently being concatenated as the last string in the string
 * buffer, and update its count field.  If there is no
 * concatenating string, start one.  An error is thrown if the
 * size of the combined string would be larger than MAX_MCOUNT
 * or if there is not enough room in string space even after a
 * garbage collection.

 * S-CAT is most commonly used on external strings, not assumed
 * to exist as mstrings.  In contrast to CAT, garbage
 * collection could invalidate a.str if it is a dynamic string
 * in the string buffer.  S-CAT can be used in that situation if
 * garbage collection is turned off with $GC-OFF.
 
 * When there is a concatenating string, concatenation is the
 * only basic string operation that can copy a string into the
 * string buffer.  "s-cat"
 */
FCode (p4_s_cat)
{
  char *q, *p = (char *) SP[1];
/*  size_t len, delta = SP[0]; */
  size_t delta = SP[0];

  SP += 2;
  if (!CAT_STR)		/* copy first string */
    {
#if MAX_MCOUNT < UCELL_MAX
      if (delta > MAX_MCOUNT)
        p4_throw (P4_ON_DSCOUNT_OVERFLOW);
#endif
      Q_ROOM (SBREAK, delta + SIZEOF_DSTR_HEADER);
      P4_VAR(DStr*,q) = SBREAK;   
      *P4_VAR(MStr**,q)++ = (MStr *) &CAT_STR;	/* back link */
      CAT_STR = (MStr *) q;			/* forward link */
      *P4_VAR(MCount*,q)++ = delta;
      while (delta-- > 0)
	*q++ = *p++;
    }
  else			/* append next string */
    {
      size_t len = MLEN (CAT_STR);
      size_t newlen = len + delta;
      
#if MAX_MCOUNT < UCELL_MAX
      if (newlen > MAX_MCOUNT)
        p4_throw (P4_ON_DSCOUNT_OVERFLOW);
#endif
      Q_ROOM (CAT_STR, SIZEOF_MCOUNT + newlen);
      q = (char *) CAT_STR;
      *(MCount *) q = newlen;
      q += len + SIZEOF_MCOUNT;
      while (delta-- > 0)
	*q++ = *p++;
    }

  /* null fill */
  P4_VAR(char*,p) = (char*) ALIGNTO_CELL (q);
  while (q < p)
    *q++ = 0;
  SBREAK = (DStr *) q;
}

/** ENDCAT	( -- $: cat$ | empty$ )
 * If there is no concatenating string, do nothing but leave the
 * empty string.  If there is, leave it as a string bound to the
 * top of the string stack, and terminate concatenation,
 * permitting normal copies into the string buffer. 
 * "end-cat"
 */
FCode (p4_endcat)
{
  if (CAT_STR != NULL)
  {
    PUSH_STR (CAT_STR);
    *(char **) ((p4cell *)CAT_STR - 1) = (char *) SSP; 
    CAT_STR = NULL;
  }
  else
  {
    PUSH_STR (&p4_empty_str);
  }
}

/************************************************************************/
/* string frames							*/
/************************************************************************/

/** $FRAME	( u -- )
 * Push the description of a string stack frame starting at the
 * top of the string stack and containing u entries onto the
 * string frame stack.  Errors are thrown if the frame stack
 * would overflow or if the depth of the string stack above the
 * top frame, if there is one, is less than u.  The value u = 0
 * is allowed.  "string-frame"

 * NOTE: The current implementation pushes u and the string
 * stack pointer onto the frame stack.
 */
FCode (p4_str_frame)
{
  p4_make_str_frame (*SP++);
}

/** DROP-$FRAME		( -- )
 * Drop the topmost string frame from the string frame stack and
 * string stack.  Errors are thrown if either stack would
 * underflow or if the string frame does not begin at the top of
 * the string stack.  The case where the frame has zero entries
 * on the string stack is handled properly.
 * "drop-string-frame"
 */
FCode (p4_drop_str_frame)
{
  int i;

  if (SFSP == SFSP0)
    p4_throw (P4_ON_SFRAME_UNDERFLOW);
  if (SFSP->top != SSP)
    p4_throw (P4_ON_SFRAME_MISMATCH);
  for (i = 0; i < (int) SFSP->num; i++)
    p4_pop_str ();
  SFSP += 1;
}

/** FIND-ARG	( s -- i true | false )
 * Leave true and its index i in the top string frame if the
 * Forth string matches an element of the frame, else leave
 * false.  The index of the top frame element is zero.
 * "find-arg"
 */
FCode (p4_find_arg)
{
  p4cell i;

  if ( (i = p4_find_arg ((char *) SP[1], SP[0])) >= 0)
    {
      SP[1] = i;
      SP[0] = ~0;
    }
  else
    {
      *++SP = 0;
    }
}

/** (DROP-$FRAME)	( -- )
 * Cleanup code for the end of a definition that uses ARGS{.
 * ;-semicolon should be overloaded to compile it
 * automatically if dynamic string arguments were in use.
 */
FCode (p4_do_drop_str_frame)
{
  if (MARGS_FLAG)
    {
      MARGS_FLAG = 0;
      FX_COMPILE(p4_do_drop_str_frame);
      FX (p4_drop_str_frame);
    }
}

P4COMPILES(p4_do_drop_str_frame, p4_drop_str_frame, 
	   P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/* **********************************************************************/
/* debugging								*/
/************************************************************************/

FCode (per_str_space)
{
  *--SP = DSTRINGS->size;
}

FCode (per_str_space_header)
{
  *--SP = sizeof (StrSpace);
}

FCode (str_break)
{
  *--SP = (p4cell) SBREAK;
}

FCode (str_buffer)
{
  *--SP = (p4cell) SBUFFER;
}

FCode (str_sp)
{
  *--SP = (p4cell) SSP;
}

FCode (str_sp0)
{
  *--SP = (p4cell) SSP0;
}

FCode (frame_depth)
{
  *--SP = ((p4ucell) SFSP0 - (p4ucell) SFSP) / sizeof (StrFrame);
}

FCode (num_frames)
{
  *--SP = DSTRINGS->numframes;
}

FCode (per_frame_stack)
{
  *--SP = sizeof (StrFrame) * DSTRINGS->numframes;
}

FCode (sf_break)
{
  *--SP = (p4cell) SFBREAK;
}

FCode (sf_sp)
{
  *--SP = (p4cell) SFSP;
}

FCode (sf_sp0)
{
  *--SP = (p4cell) SFSP0;
}

FCode (zero_str_space)
{
  p4_clear_str_space (DSTRINGS);
}

/* **********************************************************************/
/* environment								*/
/************************************************************************/

/**  ENVIRONMENT DSTRINGS-EXT  ( -- datecoded-version )
 * an ENVIRONMENT constant to be checked with ENVIRONMENT?
 * the value is currently encoded as a datecode with a decimal
 * printout of format lik YYMMDD
 */

/**  ENVIRONMENT /SCOPY  ( -- MAX_DATA_STR )
 * an ENVIRONMENT constant to be checked with ENVIRONMENT?
 * returns the configuration value of MAX_DATA_STR
 */

/**  ENVIRONMENT /DYNAMIC-STRING  ( -- MAX_MCOUNT )
 * an ENVIRONMENT constant to be checked with ENVIRONMENT?
 * returns the configuration value of MAX_MCOUNT
 */

/* **********************************************************************/
/* interpreter								*/
/************************************************************************/

static p4ucell
FXCode (interpret_dstrings) /*hereclean*/
{
  if (! STATE || ! p4_MARGS_FLAG) return 0; /* quick path */
  /* WORD-string is at PFE.word. (and not at HERE anymore) */
  return p4_compile_marg (PFE.word.ptr, PFE.word.len);
}

static FCode (drop_all_strings)
{
  p4_drop_all_strings (p4_DSTRINGS);
}

static FCode(dstrings_deinit)
{
  PFE.interpret[6] = 0;
  PFE.abort[3] = 0;
  if (PFE.dstrings)
    { 
      p4_xfree (PFE.dstrings);
      PFE.dstrings = 0;
    }
}

static FCode(dstrings_init)
{
  /* stdc commandline option: --str-buffer-size VALUE */
  static const char __str_buffer_size[] = "/str-buffer"; 
  p4ucell str_buffer_size =
    p4_search_option_value (__str_buffer_size, sizeof(__str_buffer_size)-1,
                            P4_STR_BUFFER_SIZE, PFE.set);

  /* WARNING: make_str_space calls xalloc, _deinit above calls xfree */
  PFE.dstrings = (char *) p4_make_str_space (str_buffer_size,
					     P4_MAX_SFRAMES);

  PFE.interpret[6] = PFX (interpret_dstrings);
  PFE.abort[3] = PFX(drop_all_strings);
  p4_forget_word ("deinit:dstrings:%i", 6, PFX(dstrings_deinit), 6);
}

P4_LISTWORDS (dstrings) =
{
  /* P4_INTO: CURRENT */
  /* constants */
   (,		),
   (,		),
  /* variables */
   (,	        ),
  /* forth string extensions */
   (,		),
  /* string space */
   (,		),
   (,		),
   (,		),
   (,		),
   (,  ),
   (,		),
   (,	),
  /* string compilation */
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
  /* string stack */
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
  /* string manipulation */
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
 /* string frames */
   (,		),
   (,	),
   (,		),
   (,	),
  /* debugging */
   (,		),
   (,	),
   (,		),
   (,		),
   (,		),
   (,		),
   (,		),
   (,	),
   (,		),
   (,		),
   (,		),
   (,		),
   (,	),

   (, ),
   (,	),
   (,		 ),
   (,	 ),
   (,   ),

   (, ),
  P4_EXPT ("string count too large"       /* -2053 */, P4_ON_SCOUNT_OVERFLOW),
  P4_EXPT ("string space overflow"        /* -2054 */, P4_ON_SSPACE_OVERFLOW),
  P4_EXPT ("string garbage locked"        /* -2055 */, P4_ON_SGARBAGE_LOCK),
  P4_EXPT ("string stack underflow"       /* -2056 */, P4_ON_SSTACK_UNDERFLOW),
  P4_EXPT ("cat lock preventing string copy" /* -2057 */,   P4_ON_SCAT_LOCK),
  P4_EXPT ("dynamic string count too large"  /* .. */, P4_ON_DSCOUNT_OVERFLOW),
  P4_EXPT ("too many string frames"       /* -2059 */, P4_ON_SFRAME_OVERFLOW),
  P4_EXPT ("not enough strings for frame" /* -2060 */, P4_ON_SFRAME_ITEMS),
  P4_EXPT ("string frame stack underflow" /* -2061 */, P4_ON_SFRAME_UNDERFLOW),
  P4_EXPT ("string frame not at top of string stack"   /* -2062 */,
	   P4_ON_SFRAME_MISMATCH),
  
};
P4_COUNTWORDS (dstrings, "Dynamic-Strings extension");

/* 
 * Local variables:
 * c-file-style: "gnu"
 * End:
 */