/** 
   -- usually implemented words.
  
    Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
  
    @see     GNU LGPL
    @author  Tektronix CTE               @(#) %derived_by: guidod %
    @version %version: bln_mpt1!5.37 %
      (%date_modified: Tue Apr 09 18:06:20 2002 %)
  
    @description
                There are lots of useful words that do not appear
                in any standard. This wordset defines some of them.
 */
/*@{*/
#if defined(__version_control__) && defined(__GNUC__)
static char* id __attribute__((unused)) = 
"@(#) $Id: %full_filespec:  forth-usual-ext.c~bln_mpt1!5.37:csrc:bln_12xx!1 % $";
#endif

#define _P4_SOURCE 1

#include <pfe/pfe-base.h>
#include <pfe/def-xtra.h>

#include <string.h>
#include <ctype.h>

#include <pfe/def-comp.h>
#include <pfe/dict-sub.h>
#include <pfe/_missing.h>
#include <pfe/logging.h>

/* ---------------------------------------------------------------------- *
   quite a few words have their predecessor being described in
        Forth Programmer's Handbook, Conklin and Rather
   comments here are taken from Neil Bawd's toolbelt.txt
 */
 
/** C+!  ( n addr -- )
    Add the low-order byte of _n_ to the byte at _addr_,
    removing both from the stack.
 */
FCode (p4_c_plus_store)
{
    * (char*) SP[0] += (char) SP[1];
    SP += 2;
}

 
/*  VOCABULARY           ( 'name' -- )
    Create a word list _name_. Subsequent execution of _name_
    replaces the first word list in the search order with
    _name_. When _name_ is made the compilation word list, new
    definitions will be added to _name_'s list.
  
   there are a few specialties about vocabularies in pfe.
 */
extern FCode(p4_vocabulary);

_export p4_Wordl* p4_to_wordlist (p4xt xt) 
{ 
    return (p4_Wordl*) P4_TO_BODY(xt); 
}


/** ">WORDLIST" ( xt -- wordl* )
   convert a =>"VOCABULARY"-xt into its wordlist reference
   (as in win32forth)
 */
FCode (p4_to_wordlist)
{
    *SP = (p4cell) p4_to_wordlist ((void*)(*SP));
}


/* --------------------------------------------------------- *
         Common Use
 */

/** BOUNDS                ( str len -- str+len str )
    Convert _str len_ to range for DO-loop.
 : BOUNDS  ( str len -- str+len str )  OVER + SWAP ;
 */
FCode (p4_bounds)               
{
    p4cell h = SP[1];

    SP[1] += SP[0];
    SP[0] = h;
}


/** OFF                   ( addr  -- )
    Store 0 at _addr_. Defined in f84 as =>"OFF". See antonym =>"ON!".
  : OFF  ( addr -- )  0 SWAP ! ;
 */
FCode (p4_off_store)                  
{
    *(p4cell*) (*SP++) = P4_FALSE;
}


/** ON!                    ( addr -- )
    Store -1 at _addr_. Defined in f83 as =>"ON". See antonym =>"OFF!".
  : ON!  ( addr -- )  -1 SWAP ! ;
 */
FCode (p4_on_store)                   
{
    *(p4cell*) (*SP++) = P4_TRUE;
}


/** APPEND                ( str len add2 -- )
    Append string _str len_ to the counted string at _addr_.
    a.k.a. =>"+PLACE" of the => PLACE family
 : APPEND   2DUP 2>R  COUNT +  SWAP MOVE ( ) 2R> C+! ;
 */
/** +PLACE                ( str len add2 -- )
    Append string _str len_ to the counted string at _addr_.
    a.k.a. =>"APPEND" (being a => SYNONYM now)
 : +PLACE   2DUP 2>R  COUNT +  SWAP MOVE ( ) 2R> C+! ;
 */
FCode (p4_append)
{
    unsigned char* p = (char*) SP[0];
    memcpy (p + 1 + *p, (char*) SP[2], SP[1]);
    *p += (unsigned char) SP[1];
    SP += 3;
}


/** APPEND-CHAR           ( char addr -- )
    Append _char_ to the counted string at _addr_.
    a.k.a. =>"C+PLACE" of the => PLACE family
 : APPEND-CHAR   DUP >R  COUNT  DUP 1+ R> C!  +  C! ;
 */
/** C+PLACE           ( char addr -- )
    Append _char_ to the counted string at _addr_.
    a.k.a. =>"APPEND-CHAR" (being a => SYNONYM now)
 : C+PLACE   DUP >R  COUNT  DUP 1+ R> C!  +  C! ;
 */
FCode (p4_append_char)
{
    unsigned char* p = (char*) SP[0];
    p[ 1 + *p ] = (unsigned char) SP[1];
    *p += (unsigned char) 1;
    SP += 2;
}

 
/** PLACE                 ( str len addr -- )
    Place the string _str len_ at _addr_, formatting it as a
    counted string.
 : PLACE  2DUP 2>R  1+ SWAP  MOVE  2R> C! ;
 : PLACE  2DUP C!   1+ SWAP CMOVE ;
 */
FCode (p4_place)                
{                               
    p4char *p = (p4char *) SP[0];

    *p = SP[1];
    memcpy (p + 1, (p4char *) SP[2], *p);
    SP += 3;
}


 
/* ---------------------------------------------------------------------- *
   F83 like, e.g. F-PC EXTEND
 */

/** PERFORM ( addr -- ? ) 
   see => @EXECUTE which reads better
  */

/** ?LEAVE ( cond -- )
   leave a (innermost) loop if condition is true
 */
FCode (p4_question_leave)
{
    FX_COMPILE (p4_question_leave);
}

FCode_XE (p4_question_leave_execution)
{
    FX_USE_CODE_ADDR;
    if (*SP++)
    
{
#     ifndef PFE_SBR_CALL_THREADING
        IP = RP[2] - 1;
        FX_RP_DROP  (3);
        FX_BRANCH;
#     else
        FX_NEW_RP_WORK;
	FX_NEW_RETVAL = RP[2][-1];
        FX_NEW_RP_CELL += 3;
	FX_NEW_RP_DONE;
#     endif
    }

    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_question_leave, p4_question_leave_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** NOOP ( -- )
   do nothing, used as a place-holder where 
   an execution word is needed
 */
extern FCode (p4_noop);

/** RP@ ( -- addr ) 
   returns the return stack pointer 
 example:
   : R@ RP@ @ ;
 */
FCode (p4_r_p_fetch)            
{
    FX_COMPILE (p4_r_p_fetch);
}

FCode (p4_r_p_fetch_execution)            
{
    FX_USE_CODE_ADDR;
    *--SP = (p4cell) RP;
    FX_USE_CODE_EXIT;
}

P4COMPILES (p4_r_p_fetch, p4_r_p_fetch_execution,
	    P4_SKIPS_NOTHING, P4_DEFAULT_STYLE);

/** RP! ( addr -- ) 
   sets the return stack pointer, reverse of => RP@
 */
FCode (p4_r_p_store)            
{                               
#  ifdef P4_RP_IN_VM
    RP = (p4xcode **) *SP++;
#  else
    FX_DROP; /* throw in SBR_THREADING mode ? */
#  endif
}


/** SP! ( ... addr -- ) 
   sets the stack pointer, reverse of => SP@
 */
FCode (p4_s_p_store)            
{                               
    SP = *(p4cell **) SP;
}


/** -ROT ( a b c -- c a b )
   inverse of => ROT
 */
FCode (p4_dash_rot)     
{
    p4cell h = SP[2];

    SP[2] = SP[0];
    SP[0] = SP[1];
    SP[1] = h;
}


/** CSET ( n addr -- ) 
   set bits in byte at given address 
 simulate:
   : CSET  TUCK @ SWAP OR SWAP ! ;
 */
FCode (p4_c_set)                        
{                       
    *(char *) SP[0] |= (char) SP[1];
    SP += 2;
}


/** CRESET ( n addr -- ) 
    reset bits in byte at given address 
 simulate:
   : CRESET  TUCK @ SWAP NOT AND SWAP ! ;
 */
FCode (p4_c_reset)                      
{                               
    *(char *) SP[0] &= ~(char) SP[1];
    SP += 2;
}


/** CTOGGLE ( n addr -- ) 
   toggle bits in byte at given address 
 simulate:
   : CTOGGLE  TUCK @ SWAP XOR SWAP ! ;
 */
FCode (p4_c_toggle)                     
{                               
    *(char *) SP[0] ^= (char) SP[1];
    SP += 2;
}


/** TOGGLE ( c-addr charmask -- ) 
   toggle the bits given in charmask, see also => SMUDGE and = UNSMUDGE
 example: the fig-style SMUDGE had been defined such
   : FIG-SMUDGE LATEST >FFA (SMUDGE#) TOGGLE ;
 */
FCode (p4_toggle)			
{
    *(p4char *) SP[1] ^= (p4char) SP[0];
    SP += 2;
}


/** 3DUP                ( x y z -- x y z x y z )
    Copy top three elements on the stack onto top of stack.
 : 3DUP   THIRD THIRD THIRD ;
  
   or
 : 3DUP  3 PICK 3 PICK 3 PICK ;
 */
FCode (p4_three_dup)    
{
    SP -= 3;
    SP[0] = SP[3];
    SP[1] = SP[4];
    SP[2] = SP[5];
}


 
/** 3DROP               ( x y z -- )
    Drop the top three elements from the stack.
 : 3DROP   DROP 2DROP ;
 */
FCode (p4_three_drop)
{
    FX_3DROP;
}


/** 4DUP ( a b c d -- a b c d a b c d )
 simulate:
  : 4DUP  4 PICK 4 PICK 4 PICK 4 PICK ;
 */
FCode (p4_four_dup)                     
{
    SP -= 4;
    SP[0] = SP[4];
    SP[1] = SP[5];
    SP[2] = SP[6];
    SP[3] = SP[7];
}



/** 4DROP               ( x y z -- )
    Drop the top three elements from the stack.
 : 4DROP   2DROP 2DROP ;
 */
FCode (p4_four_drop)
{
    FX_4DROP;
}


/** TOUPPER ( c1 -- c2 ) 
   convert a single character to upper case 
   : TOUPPER  >R _toupper ;
 */
FCode (p4_toupper)
{                               
    *SP = toupper (*SP);
}


/** UPPER ( addr cnt -- ) 
   convert string to upper case 
 simulate:
   : UPPER  0 DO  DUP I +  DUP C@ UPC SWAP C!  LOOP  DROP ;
 */
FCode (p4_upper)                        
{                               
    p4_upper ((char *) SP[1], SP[0]);
    FX_2DROP;
}


/** LOWER ( addr cnt -- ) 
   convert string to lower case
   This is not in L&P's F83 but provided for symmetry 
 simulate:
   : LOWER  0 DO  DUP I +  DUP C@ >R _tolower SWAP C!  LOOP  DROP ;
 */
FCode (p4_lower)                        
{                               
    p4_lower ((char *) SP[1], SP[0]);
    FX_2DROP;
}


/** ASCII ( [word] -- val )
   state smart version of => CHAR or => [CHAR] resp.
 simulate:
   : ASCII  [COMPILE] [CHAR] 
            STATE @ IF [COMPILE] LITERAL THEN ;
 */
FCode (p4_ascii)
{
    p4_word_parseword (' '); *DP=0; /* PARSE-WORD-NOHERE */
    if (! PFE.word.len)
        p4_throw (P4_ON_INVALID_NAME);
    if (STATE)
    
{
        FX_COMPILE (p4_ascii);
        FX_UCOMMA( *(p4char*) PFE.word.ptr);
    }
else
        FX_PUSH( *(p4char*) PFE.word.ptr);
}

P4COMPILES (p4_ascii, p4_literal_execution,
  P4_SKIPS_CELL, P4_DEFAULT_STYLE);

/** CONTROL ( [word] -- val )
   see =>'ASCII', but returns char - '@' 
 simulate:
   : CONTROL  [COMPILE] [CHAR]  [CHAR] @ -  
              STATE @ IF [COMPILE] LITERAL THEN ;
 */
FCode (p4_control)
{
    register p4ucell c;

    p4_word_parseword (' '); *DP=0; /* PARSE-WORD-NOHERE */
    if (! PFE.word.len)
        p4_throw (P4_ON_INVALID_NAME);
    c = *(p4char*) PFE.word.ptr;
    if ('@' <= c && c <= '_')
        c -= '@';
    if (STATE)
    
{
        FX_COMPILE (p4_control);
        FX_UCOMMA (c);
    }
else
        FX_PUSH (c);
}

P4COMPILES (p4_control, p4_literal_execution,
  P4_SKIPS_CELL, P4_DEFAULT_STYLE);

/** NUMBER? ( addr -- d flag ) 
   convert counted string to number - used in inner interpreter 
   ( => INTERPRET ), flags if conversion was successful
 example:
   BL WORD  HERE NUMBER? 0= IF ." not a number " THEN . 
 */
FCode (p4_number_question)      
{                       
    char *p = (char *) *SP;

    SP -= 2;
    SP[0] = p4_number_question (p + 1, *(p4char *) p, (p4dcell *) &SP[1]);
}


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

/** VOCS ( -- )
   list all vocabularies in the system
 simulate:
   : VOCS VOC-LINK @ BEGIN DUP WHILE
                           DUP ->WORDLIST.NAME @ ID.
                           ->WORDLIST.LINK @
                     REPEAT DROP ; 
 */
FCode (p4_vocs) 
{
    Wordl *wl = VOC_LINK;

    while (wl != NULL)
    
{
        if (wl->nfa)
            p4_dot_name (wl->nfa);
        else
            p4_outs(". "); /* show that there are unnamed wordlists */
        wl = wl->prev;
    }

}


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


/** @EXECUTE ( xt -- ? )
   same as => @ => EXECUTE , but checks for null as xt and
   silently ignores it. Same as in most forths where defined.
 simulate:
   : @EXECUTE  @ ?DUP IF EXECUTE THEN ;
 */
FCode (p4_fetch_execute)
{
    p4xt xt = *(p4xt*) FX_POP;
  
    if (xt) 
{ PFE.execute (xt); }

}


/** EMITS           ( n char -- )
    Emit _char_ _n_ times.
 : EMITS             ( n char -- )
    SWAP 0 ?DO  DUP EMIT  LOOP DROP ;
   also compare
 : SPACES BL EMITS ;
 : SPACE BL EMIT ;
 */
FCode(p4_emits)
{
    p4_emits (SP[1], SP[0]);
    SP += 2;
}


/* ------------------------------------------------------- 
          Error Checking
                              These words should be tailored for your system.
 */

/** FILE-CHECK        ( n -- )
    Check for file access error.
 \ : FILE-CHECK    ( n -- )  THROW ;
 : FILE-CHECK      ( n -- )  ABORT" File Access Error " ;
 */
FCode (p4_file_check)
{
    p4cell d = FX_POP;
    if (d)
    
{
        char* s = strerror(d);
        p4_throws (P4_ON_ABORT_QUOTE, s, 0); 
    }

}

 
/** MEMORY-CHECK      ( n -- )
    Check for memory allocation error.
 \ : MEMORY-CHECK  ( n -- )  THROW ;
 : MEMORY-CHECK    ( n -- )  ABORT" Memory Allocation Error " ;
 */
FCode (p4_memory_check)
{
    p4cell d = FX_POP;
    if (! d)
        p4_throw (P4_ON_OUT_OF_MEMORY);
}


/* ------------------------------------------------------- *
         Generally Useful
 */

/** ++                  ( addr -- )
    Increment the value at _addr_.
 : ++  ( addr -- )  1 SWAP +! ;
 */
FCode (p4_plus_plus)
{
    p4cell* p = (p4cell*) FX_POP;
    ++ *p;
}


/** @++                  ( addr -- addr' x )
    Fetch the value _x_ from _addr_, and increment the address
    by one cell.
 : @++  ( addr -- addr' x )  DUP CELL+ SWAP  @ ;
 */
FCode (p4_fetch_plus_plus)
{
    SP -= 1;
#  ifndef __WATCOMC__
    SP[0] = *(((p4cell*) SP[1])++);
#  else
    SP[0] = *( ((p4cell**)SP)[1] )++;
#  endif
}


/** !++                  ( addr x -- addr' )
    Store the value _x_ into _addr_, and increment the address
    by one cell.
 : !++  ( addr x -- addr' )  OVER !  CELL+ ;
 */
FCode (p4_store_plus_plus)
{
    p4cell d = FX_POP;
#  ifndef __WATCOMC__
    *(((p4cell*) SP[0])++) = d;
#  else
    *(( ((p4cell**)SP)[0] )++) = d;
#  endif
}


P4_LISTWORDS (forth_usual) =
{
    P4_INTO ("FORTH", 0),

    /** the value for BackSpace to be used with => EMIT - compare with => BL */
    P4_OCoN ("#BACKSPACE-CHAR",      '\b'),

    P4_FXco ("C+!",          p4_c_plus_store),
    P4_FXco ("VOCABULARY",   p4_vocabulary),

    P4_FXco ("BOUNDS",       p4_bounds),
    P4_FXco ("OFF!",         p4_off_store),
    P4_FXco ("ON!",          p4_on_store),
    P4_FNYM ("OFF",          "OFF!"),
    P4_FNYM ("ON",           "ON!"),
    P4_FXco ("PLACE",        p4_place),
    P4_FXco ("+PLACE",       p4_append),
    P4_FXco ("C+PLACE",      p4_append_char),
    P4_FNYM ("APPEND",       "+PLACE"),
    P4_FNYM ("APPEND-CHAR",  "C+PLACE"),

    P4_FXco ("@EXECUTE",     p4_fetch_execute),
    P4_SXco ("?LEAVE",       p4_question_leave),
    P4_FXco ("NOOP",         p4_noop),
    P4_SXco ("RP@",          p4_r_p_fetch),
    P4_FXco ("RP!",          p4_r_p_store),
    P4_FXco ("SP!",          p4_s_p_store),
    P4_FXco ("-ROT",         p4_dash_rot),
    P4_FXco ("CSET",         p4_c_set),
    P4_FXco ("CRESET",       p4_c_reset),
    P4_FXco ("CTOGGLE",      p4_c_toggle),
    P4_FXco ("TOGGLE",       p4_toggle),

    P4_FXco ("3DUP",         p4_three_dup),
    P4_FXco ("3DROP",        p4_three_drop),
    P4_FXco ("4DUP",         p4_four_dup),
    P4_FXco ("4DROP",        p4_four_drop),

    P4_FXco ("TOUPPER",      p4_toupper),
    P4_FXco ("UPPER",        p4_upper),
    P4_FXco ("LOWER",        p4_lower),
    P4_SXco ("ASCII",        p4_ascii),
    P4_SXco ("CONTROL",      p4_control),
    P4_FXco ("NUMBER?",      p4_number_question),
    P4_FXco ("VOCS",         p4_vocs),
    
    P4_FXco ("EMITS",        p4_emits),
    P4_FXco ("FILE-CHECK",   p4_file_check),
    P4_FXco ("MEMORY-CHECK", p4_memory_check),

    P4_FXco ("++",           p4_plus_plus),
    P4_FXco ("@++",          p4_fetch_plus_plus),
    P4_FXco ("!++",          p4_store_plus_plus),
    P4_FNYM ("@+",	     "@++"),
    P4_FNYM ("!+",           "!++"),
    P4_SNYM("ENDIF",         "THEN"),

    P4_INTO ("EXTENSIONS", 0),
    P4_FXco (">WORDLIST",    p4_to_wordlist),
    P4_xOLD ("PERFORM",      "@EXECUTE"),
    P4_xOLD ("UPC",          "TOUPPER"),
}
;
P4_COUNTWORDS (forth_usual, "Usual Forth extensions");

/*@}*/

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