ANEW --FPHPOP-- DECIMAL                       \  Wil Baden  1998-08-26

\  *******************************************************************
\  *     FPH Popular Extensions                                      *
\  *******************************************************************

\  <A HREF="http://www.forth.com/Content/Handbook/Handbook.html">
\         Forth Programmer's Handbook, Conklin and Rather
\  </A>

\  With _Forth Programmer's Handbook_, ISBN 0-9662156-0-5, as an 
\  authoritative work about contemporary Forth, for portability 
\  today's Forth implementations and tutorials should agree with it 
\  when possible. 

\
\  Here are words that are in FPH but not in Standard Forth.
\
\  GLOSSARY
\
\     .'          CURRENT     INCLUDE     M/          WH
\     2+          CVARIABLE   IS          NOT         WHERE
\     2-          DASM        L           T*          [DEFINED]
\     C+!         DEFER       LOCATE      T/          [UNDEFINED]
\     CONTEXT     EMPTY       M-          VOCABULARY
\
\  /GLOSSARY
\
\  These words are in common usage. Some of them are implementation 
\  dependent. Others have simple definitions in Standard Forth. 
\  Potential definitions for those which can be defined in Standard 
\  Forth are given here for systems that are missing them. 
\
\  Comment out definitions that you already have or are
\  improving.
\
\  Definitions in Standard Forth by Wil Baden.  Any similarity
\  with anyone else's code is coincidental, historical, or
\  inevitable.

\  2+                           ( n -- n+2 )
\     Add 2 to the top of stack.

\  2-                           ( n -- n-2 )
\     Subtract 2 from the top of stack.

\  C+!                          ( n addr -- )
\     Add the low-order byte of _n_ to the byte at _addr_,
\     removing both from the stack.

\  DEFER                        ( "name" -- )
\     Define _name_ as an execution vector. When _name_ is
\     executed, the execution token stored in _name_'s data area
\     will be retrieved and its behavior performed. An abort
\     will occur if _name_ is executed before it has been
\     initialized.

\  EMPTY                        ( -- )
\     Reset the dictionary to a predefined golden state,
\     discarding all definitions and releasing all allocated
\     data space beyond that state.

\  INCLUDE                      ( "filename" -- )
\     Include the named file.

\  IS                           ( xt "name" -- )
\     Store _xt_ in _name_, where _name_ is a word defined by
\     `DEFER`.

\  M*/                          ( d . n u -- d . )
\     Multiply _d._ by _n_ to triple result; divide by _u_ to double
\     result.  [Double]

\  M-                           ( d . n --  d . )
\     Subtract single number _n_ from double number _d._.

\  M/                           ( d . n -- q )
\     Divide double number _d._ by single number _n_.

\  NOT                          ( x -- flag )
\     Identical to `0=`, used for program clarity to reverse the
\     result of a previous test.

\  T*                           ( d . n -- t . . )
\     Multiply a double number by a single number to get a triple number.

\  T/                           ( t . . u -- d . )
\     Divide a triple number by an unsigned number to get a double
\     answer.

\  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.

\  [DEFINED]                    ( "name" -- flag )
\     Search the dictionary for _name_. If _name_ is found,
\     return TRUE; otherwise return FALSE. Immediate for use in
\     definitions.

\  [UNDEFINED]                  ( "name" -- flag )
\     Search the dictionary for _name_. If _name_ is found,
\     return FALSE; otherwise return TRUE. Immediate for use in
\     definitions.

: 2+  ( n -- n+2 )  2 + ;

: 2-  ( n -- n-2 )  2 - ;

: C+! ( n addr -- ) dup >R C@ + R> C! ;

: DEFER CREATE                    ( "name" -- )
    ['] ABORT ,  DOES> @ EXECUTE ;

: INCLUDE                         ( "filename" -- )
    BL WORD COUNT INCLUDED  DECIMAL ;

: IS                              ( xt "name" -- )
    '                               ( xt xt2)
    STATE @ IF
        postpone LITERAL  postpone >BODY  postpone !
    ELSE
        >BODY !
    THEN ; IMMEDIATE

: M-  ( d . n -- d . )  NEGATE M+ ;

: M/  ( d . n -- q )  SM/REM NIP ;

: NOT ( n -- flag ) S" 0= " EVALUATE ; IMMEDIATE

    \  From Standard Forth Rationale A.16.6.2.0715.

    : Do-Vocabulary                   ( -- )
        DOES>  @ >R                     ( )( R: widnew)
            GET-ORDER  SWAP DROP        ( wid_n ... wid_2 n)
        R> SWAP SET-ORDER ;

: VOCABULARY                      ( "name" -- )
    WORDLIST CREATE ,  Do-Vocabulary ;

: [DEFINED]                       ( "name" -- flag )
    BL WORD FIND NIP 0<> ; IMMEDIATE

: [UNDEFINED]                     ( "name" -- flag )
    BL WORD FIND NIP 0= ; IMMEDIATE


    : TNEGATE                       ( t . . -- -t . . )
        >R  2dup OR dup IF DROP  DNEGATE 1  THEN
        R> +  NEGATE ;

: T*                              ( d . n -- t . . )
                                    ( d0 d1 n)
    2dup XOR >R                     ( R: sign)
    >R DABS R> ABS
    2>R                             ( d0)( R: sign d1 n)
    R@ UM* 0                        ( t0 d1 0)
    2R> UM*                         ( t0 d1 0 d1*n .)( R: sign)
    D+                              ( t0 t1 t2)
    R> 0< IF TNEGATE THEN ;

: T/                              ( t . . u -- d . )
                                    ( t0 t1 t2 u)
    over >R >R                      ( t0 t1 t2)( R: t2 u)
    dup 0< IF TNEGATE THEN
    R@ UM/MOD                       ( t0 rem d1)
    ROT ROT                         ( d1 t0 rem)
    R> UM/MOD                       ( d1 rem' d0)( R: t2)
    NIP SWAP                        ( d0 d1)
    R> 0< IF DNEGATE THEN ;

: M*/  ( d . n u -- d . )  >R T*  R> T/ ;

	\  POSSIBLY                        ( "name" -- )
	\     Execute _name_ if it exists; otherwise, do nothing. Useful
	\     implementation factor of `ANEW`.

	\  ANEW                            ( "name" -- )
	\     Compiler directive used in the form: `ANEW _name_`. If the
	\     word _name_ already exists, it and all subsequent words
	\     are forgotten from the current dictionary, then a `MARKER`
	\     word _name_ is created that does nothing. This is usually
	\     placed at the start of a file. When the code is reloaded,
	\     any prior version is automatically pruned from the
	\     dictionary.
	\
	\     Executing _name_ will also cause it to be forgotten, since
	\     it is a `MARKER` word.
	\
	\     Useful implementation factor of `EMPTY`.

    : POSSIBLY                      ( "name" -- )
        BL WORD FIND  ?dup AND IF  EXECUTE  THEN ;

    : ANEW  ( "name" -- )  >IN @  POSSIBLY  >IN !  MARKER ;

: EMPTY  ( -- )  
	S" ANEW --WORKSPACE-- DECIMAL  ONLY FORTH DEFINITIONS " EVALUATE ;

\  The following are implementation dependent, and can't have Standard
\  definitions.

\  .'                           ( addr -- )   [Implementation Dependent]
\     Display the name of the nearest definition before _addr_,
\     and the offset of _addr_ from the beginning of that
\     definition.

\  CONTEXT                      ( -- a-addr )  [Implementation Dependent]
\     Return _a-addr_, the address of a cell that contains a
\     pointer to the first word in the search order.

\  CURRENT                      ( -- a-addr )  [Implementation Dependent]
\     Return _a-addr_, the address of a cell that contains a
\     pointer to the current compilation word list.

\  CVARIABLE                    ( "name" -- )  [Implementation Dependent]
\     Define a one-byte variable. Execution of _name_ will
\     return the address of its data space. Typically available
\     only on embedded systems.

\  DASM                         ( addr -- )   [Implementation Dependent]
\     Begin disassembly at the address _addr_ on top of stack.

\  L                            ( -- )        [Implementation Dependent]
\     Show the current source code file or block and the current
\     cursor position in it. If used after a compiling error,
\     point to the source code that caused the error.

\  LOCATE                       ( "name" -- )  [Implementation Dependent]
\     If _name_ is the name of a definition that has been
\     compiled from source code, display the source code for
\     _name_. On some systems, the phrase `VIEW` _name_ performs
\     a similar function. .

\  WH                           ( "name" -- )  [Implementation Dependent]
\     Short synonym for `WHERE`, defined for typing convenience.

\  WHERE                        ( "name" -- )  [Implementation Dependent]
\     Display all the places in the currently compiled program
\     where _name_ has been used, showing any redefinitions
\     separately.