header cdecl double

"Header Navigation"

header
Implements header creation and navigation words including the
ones from the forth-83 "experimental annex" targetting definition
field access. Also it has the defer and synonym words that are
almost standard - It is said that the missing DEFER in the ANS Forth
standard of 1994 was just a mistake.
Tektronix CTE %version: 1.14 % GNU LGPL
 FORTH
FORTH-83 definition field address conversion operators
* BODY> ( pfa -- cfa )

trying to convert a pointer to the parameter-field (PFA) to point
then to the corresponding code-field (CFA) - note that this is not
necessarily the inverse of >BODY instead it is a fast implementation
assuming a VARIABLE thing had been used. Every use of "BODY>" is
warned in the logfile. 
 implementation-specific simulation:
   : BODY> CELL - ;

header ordinary primitive

* >LINK ( cfa -- lfa )

converts a pointer to the code-field (CFA) to point
then to the corresponding link-field (LFA) - in some configurations
this can be a very slow operation since the system might need to walk
through all header-words in the system, looking for a >NAME that
has the cfa and *then* returning the "N>LINK" result here - which might
be none at all if the word is a :NONAME. Use always >NAME and
treat this word as non-portable just like any assumption about the
contents of the >LINK-field.
Only in fig-mode and for traditional fig-mode programs, this word may
possibly have enough extra assertions to be somewhat reliable.
(and fig-mode did not know about SYNONYMs - see note at LINK>).

header ordinary primitive

* LINK> ( lfa -- cfa )

converts a pointer to the link-field (LFA) to point
then to the corresponding code-field (CFA)

BEWARE: this one does not care about SYNONYMs and it is the
only way to get at the data of a SYNONYM. Therefore, if you have
a synonym called A for an old word B then there is a different
result using "NAME>" on an A-nfa or using "N>LINK LINK>" since the
first "NAME>" will return the xt of B while the latter will return
the xt of A - but executing an xt of A is an error and it will THROW

this difference is intentional to allow knowledgable persons to
do weird things looking around in the dictionary. The forth standard
words will not give you much of a chance to get hold of the nfa of
a SYNONYM word anyway - asking FIND for a word A will return
the execution token of B immediatly and "NAME>" on that one lead to
the nfa of B and not that of A.

header ordinary primitive

* >NAME ( cfa -- nfa )

converts a pointer to the code-field (CFA) to point
then to the corresponding name-field (NFA) 
 implementation-specific simulation:
   : >NAME  >LINK L>NAME ;

header ordinary primitive

* NAME> ( nfa -- cfa )

converts a pointer to the name-field (NFA) to point
then to the corresponding code-field (CFA)
(in all cases but a SYNONYM the pfe will behave not unlike the
original fig-forth did - being identical to N>LINK LINK> )

header ordinary primitive

* L>NAME ( lfa -- nfa )

converts a pointer to the link-field (LFA) to point
then to the corresponding name-field (CFA) - this one is one of
the slowest operation available. One should always use the inverse
operation "N>LINK" and cache an older value if that is needed.
Some words might be linked but they do not have a name-field (just
the other fields) but this word can not detect that and will try to look
into the bits of the dictionary anway in the assumption that there is
something - and if done in the wrong place it might even segfault.
Only in fig-mode and for traditional fig-mode programs, this word may
possibly have enough extra assertions to be somewhat reliable.
(and fig-mode did not know about SYNONYMs - see note at LINK>). 
 implementation-specific configure-dependent fig-only simulation:
 : L>NAME BEGIN DUP C@ 128 AND 0= WHILE 1- REPEAT ;

header ordinary primitive

* N>LINK ( nfa -- lfa )

converts a pointer to the name-field (NFA) to point
then to the corresponding link-field (LFA) - this operation
is quicker than the inverse L>NAME. This word is a specific
implementation detail and should not be used by normal users - instead
use always NAME> which is much more portable. Many systems may
possibly not even have a >LINK-field in the sense that a @ on
this adress will lead to another >NAME. Any operation on the
resulting >LINK-adress is even dependent on the current configuration
of PFE - only in fig-mode you are asserted to have the classic detail.
(and fig-mode did not know about SYNONYMs - see note at LINK>). 
 implementation-specific configure-dependent fig-only simulation:
   : N>LINK  C@ + ;

header ordinary primitive

* NAME>STRING ( name-token -- str-ptr str-len )

convert a name-token into a string-span, used to detect the
name for a word and print it. The word ID. can be defined as 
 : ID. NAME>STRING TYPE ;
the implementation of NAME>STRING depends on the header layout
that is defined during the configuration of the forth system. 
 : NAME>STRING COUNT 31 AND ; ( for fig-like names )
 : NAME>STRING COUNT ;        ( default, name is a simple counted string )
 : NAME>STRING @ ZCOUNT ;     ( name-token is a pointer to a C-level string )
 : NAME>STRING COUNT 31 AND   ( hybrid of fig-like and zero-terminated )
      DUP 31 = IF DROP 1+ ZCOUNT THEN
 ;
 : NAME>STRING HEAD:: COUNT CODE:: PAD PLACE PAD ; ( different i86 segments )

header ordinary primitive

FORTH LAST

no special info, see general notes

header threadstate variable

* LATEST ( -- nfa )

return the NFA of the lateset definition in the
CURRENT vocabulary

header ordinary primitive

EXTENSIONS
* >FFA ( nfa -- ffa ) obsolete

converts a pointer to the name-field (NFA) to point
then to the corresponding flag-field (FFA) - in traditinal
Forth this is the same address. pfe _can_ do different. 
 implementation-specific configure-dependent simulation:
   : FFA  1- ;

header ordinary primitive

* FFA> ( ffa -- nfa ) obsolete

converts a pointer to the flag-field (FFA) to point
then to the corresponding name-field (NFA) - in traditinal
Forth this is the same address. pfe _can_ do different. 
 implementation-specific configure-dependent simulation:
   : FFA  1+ ;

header ordinary primitive

* NAME-FLAGS@ ( nfa -- nfa-flags )

get the nfa-flags that corresponds to the nfa given. Note that
in the fig-style would include the nfa-count in the lower bits.
(see NAME-FLAGS!)

header ordinary primitive

* NAME-FLAGS! ( nfa-flags nfa -- )

set the nfa-flags of nfa given. Note that in the fig-style the nfa-flags
would include the nfa-count in the lower bits - therefore this should only
set bits that had been previously retrieved with NAME-FLAGS@ 
 : IMMEDIATE LAST @ NAME-FLAGS@ IMMEDIATE-MASK OR LAST @ NAME-FLAGS! ;

header ordinary primitive

* HEADER, ( str-ptr str-len -- )

CREATE a new header in the dictionary from the given string, without CFA 
 usage: : VARIABLE  BL WORD COUNT HEADER, DOVAR , ;

header ordinary primitive

* $HEADER ( bstring -- )

CREATE a new header in the dictionary from the given string
with the variable runtime (see HEADER, and CREATE:) 
 usage: : VARIABLE  BL WORD $HEADER ;

header ordinary primitive

EXTENSIONS HEADER

no special info, see general notes

header loader code P4_xOLD

EXTENSIONS SMUDGE

no special info, see general notes

header ordinary primitive

* REVEAL ( -- )

the FIG definition toggles the SMUDGE bit, and not all systems have
a smudge bit - instead one should use REVEAL or HIDE 
 : REVEAL LAST @ FLAGS@ SMUDGE-MASK INVERT AND LAST @ FLAGS! ;
 : REVEAL LAST @ CHAIN-INTO-CURRENT ;

header ordinary primitive

* RECURSIVE ( -- )

REVEAL the current definition making it RECURSIVE by its
own name instead of using the ans-forth word to RECURSE. 
 ' REVEAL ALIAS RECURSIVE IMMEDIATE

header immediate primitive

EXTENSIONS UNSMUDGE

no special info, see general notes

header loader code P4_xOLD

* IMMEDIATE-MASK ( -- bit-mask )

returns the bit-mask to check if a found word is immediate
(use in conjunction with NAME-FLAGS@ and NAME-FLAGS! ) 
    " my-word" FIND-NAME IF NAME-FLAGS@ IMMEDIATE-MASK AND 
                       IF ." immediate" THEN ELSE DROP THEN

header ordinary constant

* SMUDGE-MASK ( -- bit-mask )

returns the bit-mask to check if a found word is smudge
(use in conjunction with NAME-FLAGS@ and NAME-FLAGS! ) 
    " my-word" FIND-NAME IF NAME-FLAGS@ SMUDGE-MASK AND 
                       IF ." smudge" THEN ELSE DROP THEN

header ordinary constant

EXTENSIONS (IMMEDIATE#)

no special info, see general notes

header loader code P4_xOLD

EXTENSIONS (SMUDGE#)

no special info, see general notes

header loader code P4_xOLD

* DEFER ( 'word' -- )

create a new word with ((DEFER))-semantics 
 simulate:
   : DEFER  CREATE 0, DOES> ( the ((DEFER)) runtime ) 
      @ ?DUP IF EXECUTE THEN ;
   : DEFER  DEFER-RT HEADER 0 , ;

declare as "DEFER deferword"

and set as "['] executionword IS deferword"
(in pfe, you can also use TO deferword to set the execution)

header defining primitive

* IS ( xt-value [word] -- )

set a DEFER word
(in pfe: set the DOES-field - which is the BODY-field in ans-mode
and therefore the same as TO / in fig-mode the DOES-field is
one cell higher up than for a CREATE: VARIABLE
Use IS freely on each DOES-words in both modes). 
 : IS ' 
   STATE @ IF LITERAL, POSTPONE >DOES-BODY POSTPONE ! 
   ELSE >DOES-BODY ! THEN 
 ; IMMEDIATE

header compiling primitive

* BEHAVIOR ( xt1 -- xt2 )

get the execution token xt2 that would be executed by the DEFER
identified by xt1.

This command is used to obtain the execution contents of a deferred
word. A typical use would be to retrieve and save the execution
behavior of the deferred word, set the deferred word to a new behavior,
and then later restore the old behavior.

If the deferred word identified by _xt1_ is associated with some
other deferred word, _xt2_ is the execution token of that other
deferred word. To retrieve the execution token of the word currently
associated with that other deferred word, use the phrase BEHAVIOR BEHAVIOR .

Experience:
Many years of use in OpenBoot and OpenFirmware systems.
(Proposed for ANS Forth 2001)

In PFE it is the inverse of an IS operation and it will never fail
if applied to a word with atleast a body. That's just like IS can
be applied to almost every DOES> word where BEHAVIOR will get
the value back.

header ordinary primitive

* SYNONYM ( "newname" "oldname" -- )

make an name-alias for a word - this is very different from a DEFER
since a DEFER will resolve at runtime. Changing the target of a
DEFER via IS will result in changing the BEHAVIOR of all
words defined earlier and containing the name of the DEFER.

A SYNONYM however does not have any data field (theoretically not
even an execution token), instead it gets resolved at compile time.
In theory, you can try to FIND the name of the SYNONYM but as
soon as you apply NAME> the execution token of the end-point is
returned. This has also the effect that using the inverse ">NAME"
operation will result in the name-token of the other name. 
   SYNONYM CREATE  @ ;
   SEE FOO
   : foo  @ ;
   SYNONYM CREATE CREATE:
   : BAR CREATE 10 ALLOT ;
   SEE BAR
   : bar create: 10 allot ;
(only LINK> does not care about SYNONYMs)

header defining primitive

EXTENSIONS SYNONYM-OBSOLETED

no special info, see general notes

header defining primitive

ENVIRONMENT ENVIRONMENT HEADER-EXT

no special info, see general notes

header ordinary constant

EXTENSIONS P4_EXPT ("SYNONYM was called at runtime"
2070
, P4_ON_SYNONYM_CALLED),