/** 
  
   LGPL (C) 2000 - 2001 Guido Draheim <guidod@gmx.de>
  
    @see     GNU LGPL
    @author  Guido Draheim              @(#) %derived_by: guidod %
    @version %version: bln_mpt1!1.22 %
      (%date_modified: Mon Apr 08 20:39:42 2002 %)
  
   @description:
         ZCHAR-EXT wordset - defines words for zero-terminated strings,
         the datatype prefix is called "Z" which is usually a simple CHAR.
         And CHAR can be either BCHAR or WCHAR depending on your platform.
         Anyway, the words in this wordset should be largely modelled 
         after the examples found in other forth implementations - most 
         prominently MPE's forths.
 */
 
#define _P4_SOURCE 1
 
#include <pfe/pfe-base.h>
 
#include <ctype.h>
#include <string.h>

#include <pfe/def-words.h>
 
/* --------------------------------------------------------------------- */

/** 'Z"'           ( [chars<">] -- z* )
   scan the input to the next doublequote and create a buffer
   that holds the chars - return the address of that zero-terminated
   string-buffer, either =>"A'POCKET" or =>"ALLOT"ed into the dictionary.
 */
FCode(p4_z_quote)
{
    register char* p;
    register p4ucell n;

    p4_word_parse ('"'); *DP=0; /* PARSE-NOHERE */
    n = PFE.word.len;

    if (STATE)
    
{
	FX_COMPILE (p4_z_quote);
	DP += sizeof(short);
	p = DP;
    }
else
{
	p = p4_pocket ();
	n = PFE.word.len < P4_POCKET_SIZE ?
	    PFE.word.len : P4_POCKET_SIZE;
    }


    memcpy (p, PFE.word.ptr, n);  p[PFE.word.len] = '\0';

    if (STATE)
    
{
	DP += n+1;
	FX (p4_align);
	((short*)p)[-1] = ((char*)DP - p);
    }
else
{
	FX_PUSH(p);
    }

}

FCode_XE (p4_z_quote_XT)
{   FX_USE_CODE_ADDR 
{
    short skip = *((short*)IP)++;
    FX_PUSH(IP);
    ((char*)IP) += skip;
    FX_USE_CODE_EXIT;
}
}

p4xt* p4_z_quote_SEE(p4xt* ip, char* p, p4_Semant* s)
{
    int skip = *((short*)ip)++;
    sprintf (p, "%.*s %.*s\" ",
	     NFACNT(*s->name), s->name + 1,
	     (int) skip, (char*) ip);
    ((char*) ip) += skip;
    return ip;
}

P4COMPILES(p4_z_quote, p4_z_quote_XT, p4_z_quote_SEE, 0);

/** ZCOUNT    ( z* -- z* len )
   push length of z-string, additionally to the string addr itself.
 : ZSTRLEN ZCOUNT NIP ;
   (see libc strlen(3)) / compare with => COUNT / => ZSTRLEN
 */
FCode (p4_zcount)
{
    /* FX_PUSH (strlen ((char*)(*SP))) is wrong, gcc may leave unintended beh*/
    register int i = strlen ((char*)(*SP));
    FX_PUSH(i);
}


/** ZSTRLEN    ( z* -- len )
   push length of z-string.
 : ZSTRLEN ZCOUNT NIP ;
   (see libc strlen(3)) / compare with => ZMOVE / => CMOVE
 */
FCode (p4_zstrlen)
{
    *SP = strlen ((char*)(*SP));
}


/** ZMOVE      ( zsrc* zdest* -- )
   copy a zero terminated string
   (see libc strcpy(3)) / compare with => ZSTRLEN / => COUNT
 */
FCode (p4_zmove)
{
    strcpy ((char*)(SP[0]), (char*)(SP[1]));
    FX_2DROP;
}



/** APPENDZ    ( caddr* u zdest* ) 
   Add the string defined by CADDR LEN to the zero terminated string 
   at ZDEST - actually a => SYNONYM of => +ZPLACE of the => ZPLACE family
   (see strncat(3)) / compare with => ZPLACE / => +PLACE
 */

/** +ZPLACE    ( caddr* u zdest* ) 
   Add the string defined by CADDR LEN to the zero terminated string 
   at ZDEST - (for older scripts the => SYNONYM named => APPENDZ exists)
   (see libc strncat(3)) / compare with => ZPLACE / => +PLACE
 */
FCode (p4_appendz)
{
    strncat ((char*)(SP[0]), (char*)(SP[2]), (int)(SP[1]));
    FX_3DROP;
}


/** ZPLACE  ( addr* len zaddr* -- )
   copy string and place as 0 terminated
   (see libc strncpy(3)) / see also => +ZPLACE / => Z+PLACE
 */
FCode (p4_zplace)
{
    strncpy ((char*)(SP[0]), (char*)(SP[2]), (int)(SP[1]));
    FX_3DROP;
}


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

/*
   helper function used by all backslash-lit-strings
   copies a string from input buffer to output buffer
   thereby interpreting backlash-sequences. Returns
   the number of chars copied. 
 */
p4ucell p4_backslash_parse_into (p4char delim, p4char* dst, int max, 
				 int refills)
{
    register int i, j = 0;
    register p4char* src; p4ucell n;

 parse:
    p4_word_parse (delim); *DP=0; /* PARSE-NOHERE */
    src = PFE.word.ptr; n = PFE.word.len;

    if (! n && refills--) 
{ if (p4_refill ()) goto parse; }

    i = 0;
    while (i < n && j < max)
    
{
        if (src[i] != '\\')
        
{
            dst[j++] = src[i++];
        }
else
{
	    if (++i == n) goto parse;
            switch (src[i])
            
{
            case 'n': dst[j++] = '\n'; i++; break;
            case 'r': dst[j++] = '\r'; i++; break;
            case 'b': dst[j++] = '\b'; i++; break;
            case 'a': dst[j++] = '\a'; i++; break;
            case 'f': dst[j++] = '\f'; i++; break;
            case 'v': dst[j++] = '\v'; i++; break;
            case 'e': dst[j++] = '\33'; i++; break;
            case 'i': dst[j++] = '\''; i++; break; /* extra feature */
            case 'q': dst[j++] = '\"'; i++; break; /* extra feature */
            case 'x': i++;
                if (i < n && isxdigit(src[i]))
		
{
		    register p4char a = src[i++]-'0';
		    if (a > '9') a -= 'A'-'9'+1;
		    if (i < n && isxdigit (src[i])) 
		    
{
			a <<= 4;
			if (src[i] <= '9') a |= src[i] - '0';
			else a |= src[i] - 'A' + 10;
		    }

		    dst[j++] = a;
		}
else
{
		    p4_throw (P4_ON_INVALID_NUMBER);
		}

                break;
            default:
                if (! isalnum (src[i]))
                    dst[j++] = src[i++]; 
                else if (isdigit (src[i]))
                
{
                    register p4char a = src[i++]-'0';
                    if (i < n && isdigit (src[i]))
                    
{ a <<= 3; a |= src[i++]-'0'; }

                    if (i < n && isdigit (src[i]))
                    
{ a <<= 3; a |= src[i++]-'0'; }

                    dst[j++] = a; 
		}

                else if ('A' <= src[i] && src[i] <= 'Z')
                
{
		    dst[j++] = src[i++] & 31;
                }
else
{
                    p4_throw (P4_ON_INVALID_NUMBER);
                }

            }

	}

    }

    dst[j] = '\0'; return j;
}

	
    


/* "C\\"" ( [backslashed-strings_<">] -- bstr* )
   scan the following text to create a literal just
   like =>'C"' does, but backslashes can be used to
   escape special chars. The rules for the backslashes
   follow C literals, implemented techniques are
   \n \r \b \a \f \v \e \777
   and all non-alnum chars represent themselves, esp.
   \" \' \ \? \! \% \( \) \[ \] \{ \} etcetera.
   most importantly the doublequote itself can be escaped.
   but be also informed that the usage of \' and \" is not
   portable as some systems preferred to map [\'] into ["].
   Here I use the experimental addition to map [\q] to ["] and [\i] to [']
 */
FCode (p4_c_backslash_quote)
{
    p4char* p;  
    p4ucell l;
    
    if (STATE)
    
{
        FX_COMPILE(p4_c_backslash_quote);
        p = DP;
    }
else
{
        p = p4_pocket ();
    }

    p[0] = l = p4_backslash_parse_into ('"', p+1, 255, 127);
    if (STATE) 
    
{ 
        DP += l+1;
        FX (p4_align);
    }

    FX_PUSH (p);
}

P4COMPILES (p4_c_backslash_quote, p4_c_quote_execution,
	    P4_SKIPS_STRING, P4_DEFAULT_STYLE);

/* "S\\"" ( [backslashed-strings_<">] -- str cnt )
   scan the following text to create a literal just
   like =>'S"' does, but backslashes can be used to
   escape special chars. The rules for the backslashes
   follow C literals, implemented techniques are
   \n \r \b \a \f \v \e \777
   and all non-alnum chars represent themselves, esp.
   \" \' \ \? \! \% \( \) \[ \] \{ \} etcetera.
   most importantly the doublequote itself can be escaped.
   but be also informed that the usage of \' and \" is not
   portable as some systems preferred to map [\'] into ["].
   Here I use the experimental addition to map [\q] to ["] and [\i] to [']
 */
FCode (p4_s_backslash_quote)
{
    p4char* p;  
    p4ucell l;
    
    if (STATE)
    
{
        FX_COMPILE(p4_s_backslash_quote);
        p = DP;
    }
else
{
        p = p4_pocket ();
    }

    p[0] = l = p4_backslash_parse_into ('"', p+1, 255, 127);
    if (STATE) 
    
{ 
        DP += l+1;
        FX (p4_align);
    }

    FX_PUSH (p+1);
    FX_PUSH (l);
}

P4COMPILES(p4_s_backslash_quote, p4_s_quote_execution,
           P4_SKIPS_STRING, P4_DEFAULT_STYLE);

/* "Z\\"" ( [backslashed-strings_<">] -- zstr* )
   scan the following text to create a literal just
   like =>'Z"' does, but backslashes can be used to
   escape special chars. The rules for the backslashes
   follow C literals, implemented techniques are
   \n \r \b \a \f \v \e \777
   and all non-alnum chars represent themselves, esp.
   \" \' \ \? \! \% \( \) \[ \] \{ \} etcetera.
   most importantly the doublequote itself can be escaped
   but be also informed that the usage of \' and \" is not
   portable as some systems preferred to map [\'] into ["].
   Here I use the experimental addition to map [\q] to ["] and [\i] to [']
 */
FCode (p4_z_backslash_quote)
{
    p4char* p;  
    p4ucell l;
    
    if (STATE)
    
{
        FX_COMPILE(p4_z_backslash_quote);
        p = DP;
	l = p4_backslash_parse_into ('"', p+sizeof(short), 65535, 32767);
    }
else
{
        p = p4_pocket ();
	l = p4_backslash_parse_into ('"', p+sizeof(short), 254, 126);
    }

    if (STATE) 
    
{ 
        DP += l+sizeof(short);
        FX (p4_align);
	(*(short*)p) = ((p4char*)DP - p);
    }

    FX_PUSH (p+sizeof(short));
}

P4COMPILES(p4_z_backslash_quote, p4_z_quote_XT,
           p4_z_quote_SEE, P4_DEFAULT_STYLE);


P4_LISTWORDS(zchar) =
{
    P4_INTO ("FORTH", 0 ),
    P4_SXco ("Z\"",              p4_z_quote), 
    P4_FXco ("ZCOUNT",           p4_zcount),
    P4_FXco ("ZSTRLEN",          p4_zstrlen),
    P4_FXco ("ZMOVE",            p4_zmove),
    P4_FXco ("ZPLACE",           p4_zplace),
    P4_FXco ("+ZPLACE",          p4_appendz),
    P4_FNYM ("APPENDZ",          "+ZPLACE"),
    P4_SXco ("S\\\"",	         p4_s_backslash_quote),
    P4_SXco ("C\\\"",            p4_c_backslash_quote),
    P4_SXco ("Z\\\"",            p4_z_backslash_quote),
    P4_INTO ("ENVIRONMENT", 0 ),
    P4_OCON ("ZCHAR-EXT",   2000 ),
}
;
P4_COUNTWORDS(zchar, "ZCHAR-EXT - zero-terminated C-like charstrings");

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