/**
* -- The Optional Programming-Tools Word Set
*
* Copyright (C) Tektronix, Inc. 1998 - 2001. All rights reserved.
*
* @see GNU LGPL
* @author Tektronix CTE @(#) %derived_by: guidod %
* @version %version: bln_mpt1!5.18 %
* (%date_modified: Wed Jul 17 14:03:04 2002 %)
*
* @description
* The ANS Forth defines some "Programming Tools", words to
* inspect the stack (.S), memory (DUMP),
* compiled code (SEE) and what words
* are defined (WORDS).
*
* There are also word that provide some precompiler support
* and explicit acces to the CS-STACK.
*
*//*@{*/
/**.S( -- )
* print the stack content in vertical nice format.
* tries to show cell-stack and float-stack side-by-side,
*
* Depending on configuration,
* there are two parameter stacks: for integers and for
* floating point operations. If both stacks are empty, .S
* will display the message lt;stacks emptygt;.
*
* If only the floating point stack is empty, .S displays
* the integer stack items in one column, one item per line,
* both in hex and in decimal like this (the first item is topmost):
12345 HEX 67890 .S
424080 [00067890]
12345 [00003039] ok
*
* If both stacks ar not empty, .S displays both stacks, in two
* columns, one item per line
HEX 123456.78E90 ok
DECIMAL 123456.78E90 .S
291 [00000123] 1.234568E+95
1164414608 [45678E90] ok
* Confusing example? Remember that floating point input only works
* when the BASE number is DECIMAL. The first number looks like
* a floating point but it is a goodhex double integer too - the number
* base is HEX. Thus it is accepted as a hex number. Second try
* with a decimal base will input the floating point number.
*
* If only the integer stack is empty, .S shows two columns, but
* he first columns is called lt;stack emptygt;, and the
* second column is the floating point stack, topmost item first.
*/FCode (p4_dot_s)
{
int i;
int dd = p4_S0 - SP;
# ifndef P4_NO_FP
int fd = p4_F0 - FP;
if (fd == 0)
# endif{
if (dd == 0)
{ /* !fd !dd *//* both stacks empty */
p4_outf ("\n%*s",
(DECWIDTH + HEXWIDTH + 4), "<stacks empty> ");
}else{ /* !fd dd *//* only data stack not empty */
for (i = 0; i < dd; i++)
{
FX (p4_cr);
p4_prCell (SP [i]);
}
}
}# ifndef P4_NO_FP
else if (dd == 0) /* fd !dd */{
/* only floating point stack not empty */
p4_outf ("\n%*s%15.7G ",
(DECWIDTH + HEXWIDTH + 4), "<stack empty> ", FP [0]);
for (i = 1; i < fd; i++)
p4_outf ("\n%*.7G ",
(DECWIDTH + HEXWIDTH + 4) + 15, FP [i]);
}else{ /* fd dd */
int bd = dd < fd ? dd : fd;
for (i = 0; i < bd; i++)
{
FX (p4_cr);
p4_prCell (SP [i]);
p4_outf ("%15.7G ", FP [i]);
}
for (; i < dd; i++)
{
FX (p4_cr);
p4_prCell (SP [i]);
}
for (; i < fd; i++)
p4_outf ("\n%*.7G ",
(DECWIDTH + HEXWIDTH + 4) + 15, FP [i]);
}# endif
}
/**?( addr -- )
* Display the (integer) content of at address addr.
* This word is sensitive to BASE
simulate:
: ? @ . ;
*/FCode (p4_question)
{
FX (p4_fetch);
FX (p4_dot);
}
/**DUMP( addr len -- )
* show a hex-dump of the given area, if it's more than a screenful
* it will ask using ?CR
*
* You can easily cause a segmentation fault of something like that
* by accessing memory that does not belong to the pfe-process.
*/FCode (p4_dump)
{
p4ucell i, j, n = (p4ucell) FX_POP;
p4char *p;
p = P4_POP_ (p4char*, SP);
FX (p4_cr);
FX (p4_start_Q_cr);
p4_outf ("%*s ", HEXWIDTH, "");
for (j = 0; j < 16; j++)
p4_outf ("%02X ", (unsigned)((p4ucell)(p + j) & 0x0F));
for (j = 0; j < 16; j++)
p4_outf ("%X", (unsigned)((p4ucell)(p + j) & 0x0F));
for (i = 0; i < n; i += 16, p += 16)
{
if (p4_Q_cr ())
break;
p4_outf ("%0*lX ", HEXWIDTH, (unsigned long)(p4ucell)p);
for (j = 0; j < 16; j++)
p4_outf ("%02X ", p [j]);
for (j = 0; j < 16; j++)
p4_outf ("%c", p4_isprint (p [j]) ? p [j] : '.');
}
FX (p4_space);
}
/**SEE( "word" -- )
* decompile word - tries to show it in re-compilable form.
*
* (SEE) tries to display the word as a reasonable indented
* source text. If you defined your own control structures or
* use extended control-flow patterns, the indentation may be
* suboptimal.
simulate:
: SEE [COMPILE] ' (SEE) ;
*/
/**WORDS( -- )
* uses CONTEXT and lists the words defined in that vocabulary.
* usually the vocabulary to list is named directly in before.
example:
FORTH WORDS or LOADED WORDS
*/FCode (p4_words)
{
Wordl *wl = CONTEXT [0] ? CONTEXT [0] : ONLY;
p4_wild_words (wl, "*", NULL);
}
/* ----------------------------------------------------------------------- *//* Programming-Tools Extension words */
/**BYE( -- ) no-return
* should quit the forth environment completly
*/FCode (p4_bye)
{
FX (p4_save_buffers);
FX (p4_close_all_files);
if (P4_opt.quiet)
p4_outc ('\n');
else
p4_outs ("\nGoodbye!\n");
# ifndef _K12_SOURCE
p4_longjmp_exit ();
# else/* BYE doesn't make sense in an embedded system. */
FX (p4_cold);
# endif /* _K12_SOURCE */
}
/**CS-PICK( 2a 2b 2c ... n -- 2a 2b 2c ... 2a )
* pick a value in the compilation-stack - note that the compilation
* stack _can_ be seperate in some forth-implemenations. In PFE
* the parameter-stack is used in a double-cell fashion, so CS-PICK
* would 2PICK a DP-mark and a COMP-magic, see PICK
*/FCode (p4_cs_pick)
{
p4cell n = (*SP-- + 1) << 1;
SP [0] = SP [n];
SP [1] = SP [n + 1];
}
/**CS-ROLL( 2a 2b 2c ... n -- 2b 2c ... 2a )
* roll a value in the compilation-stack - note that the compilation
* stack _can_ be seperate in some forth-implemenations. In PFE
* the parameter-stack is used in a double-cell fashion, so CS-ROLL
* would 2ROLL a DP-mark and a COMP-magic, see ROLL
*/FCode (p4_cs_roll)
{
p4cell n = *SP++;
p4dcell h = ((p4dcell *)SP) [n];
for (; n > 0; n--)
((p4dcell *)SP) [n] = ((p4dcell *)SP) [n - 1];
((p4dcell *)SP) [0] = h;
}
/**[ELSE]( -- )
* eat up everything upto and including the next [THEN]. count
* nested [IF] ... [THEN] constructs. see [IF]
this word provides a simple pre-compiler mechanism
*/FCode (p4_bracket_else)
{
char *p;
int len, level = 1;
do {
for (;;)
{
p = p4_word (' ');
if ((len = *(p4char*)p++) == 0)
break;
if (UPPER_CASE)
p4_upper (p, len);
if (len == 4 && strncmp (p, "[IF]", 4) == 0)
++level;
else if (len == 6 && strncmp (p, "[ELSE]", 6) == 0)
if (--level == 0) return; else ++level;
else if (len == 6 && strncmp (p, "[THEN]", 6) == 0)
if (--level == 0) return;
}
} while (p4_refill ());
p4_throw (P4_ON_UNEXPECTED_EOF);
}
/**[IF]( flag -- )
* check the condition in the CS-STACK. If true let the following
* text flow into INTERPRET , otherwise eat up everything upto
* and including the next [ELSE] or [THEN] . In case of
* skipping, count nested [IF] ... [THEN] constructs.
this word provides a simple pre-compiler mechanism
*/FCode (p4_bracket_if)
{
if (FX_POP == 0)
FX (p4_bracket_else);
}