/** 
 * -- 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 LP'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;
    SP[0] = *P4_VAR(p4cell*,SP[1])++;
}

/** !++                  ( 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)
{
    register p4cell d = FX_POP;
    *P4_VAR(p4cell*,SP[0])++ = d;
}

P4_LISTWORDS (forth_usual) =
{
     (, ),

    /** the value for BackSpace to be used with EMIT - compare with BL */
     (,      ),

     (,          ),
     (,   ),

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

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

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

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

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

     (, ),
     (,    ),
     (,      ),
     (,          ),
};
P4_COUNTWORDS (forth_usual, "Usual Forth extensions");

/*@}*/

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