/* @(#) pfcompil.c 98/01/26 1.5 */
/***************************************************************
** Compiler for PForth based on 'C'
** These routines could be left out of an execute only version.
** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
** The pForth software code is dedicated to the public domain,
** and any third party may reproduce, distribute and modify
** the pForth software code or any derivative works thereof
** without any compensation or license. The pForth software
** code is provided on an "as is" basis without any warranty
** of any kind, including, without limitation, the implied
** warranties of merchantability and fitness for a particular
** purpose and their equivalents under the laws of any jurisdiction.
****************************************************************
** 941004 PLB Extracted IO calls from pforth_main.c
** 950320 RDG Added underflow checking for FP stack
***************************************************************/
#define ABORT_RETURN_CODE (10)
#define UINT32_MASK ((sizeof(ucell_t)-1))
/***************************************************************/
/************** Static Prototypes ******************************/
/***************************************************************/
static void ffStringColon( const ForthStringPtr FName
);
static cell_t
CheckRedefinition( const ForthStringPtr FName
);
static void ffUnSmudge( void );
static cell_t
FindAndCompile( const char *theWord
);
static cell_t
ffCheckDicRoom( void );
static void CreateDeferredC( ExecToken DefaultXT
, const char *CName
);
cell_t
NotCompiled( const char *FunctionName
)
MSG(" not compiled in this version of PForth.\n");
/***************************************************************
** Create an entry in the Dictionary for the given ExecutionToken.
** FName is name in Forth format.
void CreateDicEntry( ExecToken XT
, const ForthStringPtr FName
, ucell_t Flags
)
cfnl
= (cfNameLinks
*) gCurrentDictionary
->dic_HeaderPtr
;
/* Set link to previous header, if any. */
WRITE_CELL_DIC( &cfnl
->cfnl_PreviousName
, ABS_TO_NAMEREL( gVarContext
) );
cfnl
->cfnl_PreviousName
= 0;
/* Put Execution token in header. */
WRITE_CELL_DIC( &cfnl
->cfnl_ExecToken
, XT
);
/* Advance Header Dictionary Pointer */
gCurrentDictionary
->dic_HeaderPtr
+= sizeof(cfNameLinks
);
gVarContext
= gCurrentDictionary
->dic_HeaderPtr
;
pfCopyMemory( (uint8_t *) gCurrentDictionary
->dic_HeaderPtr
, FName
, (*FName
)+1 );
gCurrentDictionary
->dic_HeaderPtr
+= (*FName
)+1;
*(char*)gVarContext
|= (char) Flags
;
/* Align to quad byte boundaries with zeroes. */
while( gCurrentDictionary
->dic_HeaderPtr
& UINT32_MASK
)
*(char*)(gCurrentDictionary
->dic_HeaderPtr
++) = 0;
/***************************************************************
** Convert name then create dictionary entry.
void CreateDicEntryC( ExecToken XT
, const char *CName
, ucell_t Flags
)
CStringToForth( FName
, CName
, sizeof(FName
) );
CreateDicEntry( XT
, FName
, Flags
);
/***************************************************************
** Convert absolute namefield address to previous absolute name
** field address or NULL.
const ForthString
*NameToPrevious( const ForthString
*NFA
)
/* DBUG(("\nNameToPrevious: NFA = 0x%x\n", (cell_t) NFA)); */
cfnl
= (const cfNameLinks
*) ( ((const char *) NFA
) - sizeof(cfNameLinks
) );
RelNamePtr
= READ_CELL_DIC((const cell_t
*) (&cfnl
->cfnl_PreviousName
));
/* DBUG(("\nNameToPrevious: RelNamePtr = 0x%x\n", (cell_t) RelNamePtr )); */
return ( (ForthString
*) NAMEREL_TO_ABS( RelNamePtr
) );
/***************************************************************
** Convert NFA to ExecToken.
ExecToken
NameToToken( const ForthString
*NFA
)
/* Convert absolute namefield address to absolute link field address. */
cfnl
= (const cfNameLinks
*) ( ((const char *) NFA
) - sizeof(cfNameLinks
) );
return READ_CELL_DIC((const cell_t
*) (&cfnl
->cfnl_ExecToken
));
/***************************************************************
** Find XTs needed by compiler.
cell_t
FindSpecialXTs( void )
if( ffFindC( "(QUIT)", &gQuitP_XT
) == 0) goto nofind
;
if( ffFindC( "NUMBER?", &gNumberQ_XT
) == 0) goto nofind
;
if( ffFindC( "ACCEPT", &gAcceptP_XT
) == 0) goto nofind
;
DBUG(("gNumberQ_XT = 0x%x\n", (unsigned int)gNumberQ_XT
));
ERR("FindSpecialXTs failed!\n");
/***************************************************************
** Build a dictionary from scratch.
PForthDictionary
pfBuildDictionary( cell_t HeaderSize
, cell_t CodeSize
)
dic
= pfCreateDictionary( HeaderSize
, CodeSize
);
pfDebugMessage("pfBuildDictionary: Start adding dictionary entries.\n");
gCurrentDictionary
= dic
;
gNumPrimitives
= NUM_PRIMITIVES
;
CreateDicEntryC( ID_EXIT
, "EXIT", 0 );
pfDebugMessage("pfBuildDictionary: added EXIT\n");
CreateDicEntryC( ID_1MINUS
, "1-", 0 );
pfDebugMessage("pfBuildDictionary: added 1-\n");
CreateDicEntryC( ID_1PLUS
, "1+", 0 );
CreateDicEntryC( ID_2_R_FETCH
, "2R@", 0 );
CreateDicEntryC( ID_2_R_FROM
, "2R>", 0 );
CreateDicEntryC( ID_2_TO_R
, "2>R", 0 );
CreateDicEntryC( ID_2DUP
, "2DUP", 0 );
CreateDicEntryC( ID_2LITERAL
, "2LITERAL", FLAG_IMMEDIATE
);
CreateDicEntryC( ID_2LITERAL_P
, "(2LITERAL)", 0 );
CreateDicEntryC( ID_2MINUS
, "2-", 0 );
CreateDicEntryC( ID_2PLUS
, "2+", 0 );
CreateDicEntryC( ID_2OVER
, "2OVER", 0 );
CreateDicEntryC( ID_2SWAP
, "2SWAP", 0 );
CreateDicEntryC( ID_ACCEPT_P
, "(ACCEPT)", 0 );
CreateDeferredC( ID_ACCEPT_P
, "ACCEPT" );
CreateDicEntryC( ID_ALITERAL
, "ALITERAL", FLAG_IMMEDIATE
);
CreateDicEntryC( ID_ALITERAL_P
, "(ALITERAL)", 0 );
CreateDicEntryC( ID_ALLOCATE
, "ALLOCATE", 0 );
pfDebugMessage("pfBuildDictionary: added ALLOCATE\n");
CreateDicEntryC( ID_ARSHIFT
, "ARSHIFT", 0 );
CreateDicEntryC( ID_AND
, "AND", 0 );
CreateDicEntryC( ID_BAIL
, "BAIL", 0 );
CreateDicEntryC( ID_BRANCH
, "BRANCH", 0 );
CreateDicEntryC( ID_BODY_OFFSET
, "BODY_OFFSET", 0 );
CreateDicEntryC( ID_BYE
, "BYE", 0 );
CreateDicEntryC( ID_CATCH
, "CATCH", 0 );
CreateDicEntryC( ID_CELL
, "CELL", 0 );
CreateDicEntryC( ID_CELLS
, "CELLS", 0 );
CreateDicEntryC( ID_CFETCH
, "C@", 0 );
CreateDicEntryC( ID_CMOVE
, "CMOVE", 0 );
CreateDicEntryC( ID_CMOVE_UP
, "CMOVE>", 0 );
CreateDicEntryC( ID_COLON
, ":", 0 );
CreateDicEntryC( ID_COLON_P
, "(:)", 0 );
CreateDicEntryC( ID_COMPARE
, "COMPARE", 0 );
CreateDicEntryC( ID_COMP_EQUAL
, "=", 0 );
CreateDicEntryC( ID_COMP_NOT_EQUAL
, "<>", 0 );
CreateDicEntryC( ID_COMP_GREATERTHAN
, ">", 0 );
CreateDicEntryC( ID_COMP_U_GREATERTHAN
, "U>", 0 );
pfDebugMessage("pfBuildDictionary: added U>\n");
CreateDicEntryC( ID_COMP_LESSTHAN
, "<", 0 );
CreateDicEntryC( ID_COMP_U_LESSTHAN
, "U<", 0 );
CreateDicEntryC( ID_COMP_ZERO_EQUAL
, "0=", 0 );
CreateDicEntryC( ID_COMP_ZERO_NOT_EQUAL
, "0<>", 0 );
CreateDicEntryC( ID_COMP_ZERO_GREATERTHAN
, "0>", 0 );
CreateDicEntryC( ID_COMP_ZERO_LESSTHAN
, "0<", 0 );
CreateDicEntryC( ID_CR
, "CR", 0 );
CreateDicEntryC( ID_CREATE
, "CREATE", 0 );
CreateDicEntryC( ID_CREATE_P
, "(CREATE)", 0 );
CreateDicEntryC( ID_D_PLUS
, "D+", 0 );
CreateDicEntryC( ID_D_MINUS
, "D-", 0 );
CreateDicEntryC( ID_D_UMSMOD
, "UM/MOD", 0 );
CreateDicEntryC( ID_D_MUSMOD
, "MU/MOD", 0 );
CreateDicEntryC( ID_D_MTIMES
, "M*", 0 );
pfDebugMessage("pfBuildDictionary: added M*\n");
CreateDicEntryC( ID_D_UMTIMES
, "UM*", 0 );
CreateDicEntryC( ID_DEFER
, "DEFER", 0 );
CreateDicEntryC( ID_CSTORE
, "C!", 0 );
CreateDicEntryC( ID_DEPTH
, "DEPTH", 0 );
pfDebugMessage("pfBuildDictionary: added DEPTH\n");
CreateDicEntryC( ID_DIVIDE
, "/", 0 );
CreateDicEntryC( ID_DOT
, ".", 0 );
CreateDicEntryC( ID_DOTS
, ".S", 0 );
pfDebugMessage("pfBuildDictionary: added .S\n");
CreateDicEntryC( ID_DO_P
, "(DO)", 0 );
CreateDicEntryC( ID_DROP
, "DROP", 0 );
CreateDicEntryC( ID_DUMP
, "DUMP", 0 );
CreateDicEntryC( ID_DUP
, "DUP", 0 );
CreateDicEntryC( ID_EMIT_P
, "(EMIT)", 0 );
pfDebugMessage("pfBuildDictionary: added (EMIT)\n");
CreateDeferredC( ID_EMIT_P
, "EMIT");
pfDebugMessage("pfBuildDictionary: added EMIT\n");
CreateDicEntryC( ID_EOL
, "EOL", 0 );
CreateDicEntryC( ID_ERRORQ_P
, "(?ERROR)", 0 );
CreateDicEntryC( ID_ERRORQ_P
, "?ERROR", 0 );
CreateDicEntryC( ID_EXECUTE
, "EXECUTE", 0 );
CreateDicEntryC( ID_FETCH
, "@", 0 );
CreateDicEntryC( ID_FILL
, "FILL", 0 );
CreateDicEntryC( ID_FIND
, "FIND", 0 );
CreateDicEntryC( ID_FILE_CREATE
, "CREATE-FILE", 0 );
CreateDicEntryC( ID_FILE_DELETE
, "DELETE-FILE", 0 );
CreateDicEntryC( ID_FILE_OPEN
, "OPEN-FILE", 0 );
CreateDicEntryC( ID_FILE_CLOSE
, "CLOSE-FILE", 0 );
CreateDicEntryC( ID_FILE_READ
, "READ-FILE", 0 );
CreateDicEntryC( ID_FILE_SIZE
, "FILE-SIZE", 0 );
CreateDicEntryC( ID_FILE_WRITE
, "WRITE-FILE", 0 );
CreateDicEntryC( ID_FILE_POSITION
, "FILE-POSITION", 0 );
CreateDicEntryC( ID_FILE_REPOSITION
, "REPOSITION-FILE", 0 );
CreateDicEntryC( ID_FILE_FLUSH
, "FLUSH-FILE", 0 );
CreateDicEntryC( ID_FILE_RENAME
, "(RENAME-FILE)", 0 );
CreateDicEntryC( ID_FILE_RESIZE
, "(RESIZE-FILE)", 0 );
CreateDicEntryC( ID_FILE_RO
, "R/O", 0 );
CreateDicEntryC( ID_FILE_RW
, "R/W", 0 );
CreateDicEntryC( ID_FILE_WO
, "W/O", 0 );
CreateDicEntryC( ID_FILE_BIN
, "BIN", 0 );
CreateDicEntryC( ID_FINDNFA
, "FINDNFA", 0 );
CreateDicEntryC( ID_FLUSHEMIT
, "FLUSHEMIT", 0 );
CreateDicEntryC( ID_FREE
, "FREE", 0 );
CreateDicEntryC( ID_HERE
, "HERE", 0 );
CreateDicEntryC( ID_NUMBERQ_P
, "(SNUMBER?)", 0 );
CreateDicEntryC( ID_I
, "I", 0 );
CreateDicEntryC( ID_INTERPRET
, "INTERPRET", 0 );
CreateDicEntryC( ID_J
, "J", 0 );
CreateDicEntryC( ID_INCLUDE_FILE
, "INCLUDE-FILE", 0 );
CreateDicEntryC( ID_KEY
, "KEY", 0 );
CreateDicEntryC( ID_LEAVE_P
, "(LEAVE)", 0 );
CreateDicEntryC( ID_LITERAL
, "LITERAL", FLAG_IMMEDIATE
);
CreateDicEntryC( ID_LITERAL_P
, "(LITERAL)", 0 );
CreateDicEntryC( ID_LOADSYS
, "LOADSYS", 0 );
CreateDicEntryC( ID_LOCAL_COMPILER
, "LOCAL-COMPILER", 0 );
CreateDicEntryC( ID_LOCAL_ENTRY
, "(LOCAL.ENTRY)", 0 );
CreateDicEntryC( ID_LOCAL_EXIT
, "(LOCAL.EXIT)", 0 );
CreateDicEntryC( ID_LOCAL_FETCH
, "(LOCAL@)", 0 );
CreateDicEntryC( ID_LOCAL_FETCH_1
, "(1_LOCAL@)", 0 );
CreateDicEntryC( ID_LOCAL_FETCH_2
, "(2_LOCAL@)", 0 );
CreateDicEntryC( ID_LOCAL_FETCH_3
, "(3_LOCAL@)", 0 );
CreateDicEntryC( ID_LOCAL_FETCH_4
, "(4_LOCAL@)", 0 );
CreateDicEntryC( ID_LOCAL_FETCH_5
, "(5_LOCAL@)", 0 );
CreateDicEntryC( ID_LOCAL_FETCH_6
, "(6_LOCAL@)", 0 );
CreateDicEntryC( ID_LOCAL_FETCH_7
, "(7_LOCAL@)", 0 );
CreateDicEntryC( ID_LOCAL_FETCH_8
, "(8_LOCAL@)", 0 );
CreateDicEntryC( ID_LOCAL_STORE
, "(LOCAL!)", 0 );
CreateDicEntryC( ID_LOCAL_STORE_1
, "(1_LOCAL!)", 0 );
CreateDicEntryC( ID_LOCAL_STORE_2
, "(2_LOCAL!)", 0 );
CreateDicEntryC( ID_LOCAL_STORE_3
, "(3_LOCAL!)", 0 );
CreateDicEntryC( ID_LOCAL_STORE_4
, "(4_LOCAL!)", 0 );
CreateDicEntryC( ID_LOCAL_STORE_5
, "(5_LOCAL!)", 0 );
CreateDicEntryC( ID_LOCAL_STORE_6
, "(6_LOCAL!)", 0 );
CreateDicEntryC( ID_LOCAL_STORE_7
, "(7_LOCAL!)", 0 );
CreateDicEntryC( ID_LOCAL_STORE_8
, "(8_LOCAL!)", 0 );
CreateDicEntryC( ID_LOCAL_PLUSSTORE
, "(LOCAL+!)", 0 );
CreateDicEntryC( ID_LOOP_P
, "(LOOP)", 0 );
CreateDicEntryC( ID_LSHIFT
, "LSHIFT", 0 );
CreateDicEntryC( ID_MAX
, "MAX", 0 );
CreateDicEntryC( ID_MIN
, "MIN", 0 );
CreateDicEntryC( ID_MINUS
, "-", 0 );
CreateDicEntryC( ID_NAME_TO_TOKEN
, "NAME>", 0 );
CreateDicEntryC( ID_NAME_TO_PREVIOUS
, "PREVNAME", 0 );
CreateDicEntryC( ID_NOOP
, "NOOP", 0 );
CreateDeferredC( ID_NUMBERQ_P
, "NUMBER?" );
CreateDicEntryC( ID_OR
, "OR", 0 );
CreateDicEntryC( ID_OVER
, "OVER", 0 );
pfDebugMessage("pfBuildDictionary: added OVER\n");
CreateDicEntryC( ID_PICK
, "PICK", 0 );
CreateDicEntryC( ID_PLUS
, "+", 0 );
CreateDicEntryC( ID_PLUSLOOP_P
, "(+LOOP)", 0 );
CreateDicEntryC( ID_PLUS_STORE
, "+!", 0 );
CreateDicEntryC( ID_QUIT_P
, "(QUIT)", 0 );
CreateDeferredC( ID_QUIT_P
, "QUIT" );
CreateDicEntryC( ID_QDO_P
, "(?DO)", 0 );
CreateDicEntryC( ID_QDUP
, "?DUP", 0 );
CreateDicEntryC( ID_QTERMINAL
, "?TERMINAL", 0 );
CreateDicEntryC( ID_QTERMINAL
, "KEY?", 0 );
CreateDicEntryC( ID_REFILL
, "REFILL", 0 );
CreateDicEntryC( ID_RESIZE
, "RESIZE", 0 );
CreateDicEntryC( ID_ROLL
, "ROLL", 0 );
CreateDicEntryC( ID_ROT
, "ROT", 0 );
CreateDicEntryC( ID_RSHIFT
, "RSHIFT", 0 );
CreateDicEntryC( ID_R_DROP
, "RDROP", 0 );
CreateDicEntryC( ID_R_FETCH
, "R@", 0 );
CreateDicEntryC( ID_R_FROM
, "R>", 0 );
CreateDicEntryC( ID_RP_FETCH
, "RP@", 0 );
CreateDicEntryC( ID_RP_STORE
, "RP!", 0 );
CreateDicEntryC( ID_SEMICOLON
, ";", FLAG_IMMEDIATE
);
CreateDicEntryC( ID_SP_FETCH
, "SP@", 0 );
CreateDicEntryC( ID_SP_STORE
, "SP!", 0 );
CreateDicEntryC( ID_STORE
, "!", 0 );
CreateDicEntryC( ID_SAVE_FORTH_P
, "(SAVE-FORTH)", 0 );
CreateDicEntryC( ID_SCAN
, "SCAN", 0 );
CreateDicEntryC( ID_SKIP
, "SKIP", 0 );
CreateDicEntryC( ID_SOURCE
, "SOURCE", 0 );
CreateDicEntryC( ID_SOURCE_SET
, "SET-SOURCE", 0 );
CreateDicEntryC( ID_SOURCE_ID
, "SOURCE-ID", 0 );
CreateDicEntryC( ID_SOURCE_ID_PUSH
, "PUSH-SOURCE-ID", 0 );
CreateDicEntryC( ID_SOURCE_ID_POP
, "POP-SOURCE-ID", 0 );
CreateDicEntryC( ID_SOURCE_LINE_NUMBER_FETCH
, "SOURCE-LINE-NUMBER@", 0 );
CreateDicEntryC( ID_SOURCE_LINE_NUMBER_STORE
, "SOURCE-LINE-NUMBER!", 0 );
CreateDicEntryC( ID_SWAP
, "SWAP", 0 );
CreateDicEntryC( ID_TEST1
, "TEST1", 0 );
CreateDicEntryC( ID_TEST2
, "TEST2", 0 );
CreateDicEntryC( ID_TICK
, "'", 0 );
CreateDicEntryC( ID_TIMES
, "*", 0 );
CreateDicEntryC( ID_THROW
, "THROW", 0 );
CreateDicEntryC( ID_TO_R
, ">R", 0 );
CreateDicEntryC( ID_TYPE
, "TYPE", 0 );
CreateDicEntryC( ID_VAR_BASE
, "BASE", 0 );
CreateDicEntryC( ID_VAR_CODE_BASE
, "CODE-BASE", 0 );
CreateDicEntryC( ID_VAR_CODE_LIMIT
, "CODE-LIMIT", 0 );
CreateDicEntryC( ID_VAR_CONTEXT
, "CONTEXT", 0 );
CreateDicEntryC( ID_VAR_DP
, "DP", 0 );
CreateDicEntryC( ID_VAR_ECHO
, "ECHO", 0 );
CreateDicEntryC( ID_VAR_HEADERS_PTR
, "HEADERS-PTR", 0 );
CreateDicEntryC( ID_VAR_HEADERS_BASE
, "HEADERS-BASE", 0 );
CreateDicEntryC( ID_VAR_HEADERS_LIMIT
, "HEADERS-LIMIT", 0 );
CreateDicEntryC( ID_VAR_NUM_TIB
, "#TIB", 0 );
CreateDicEntryC( ID_VAR_RETURN_CODE
, "RETURN-CODE", 0 );
CreateDicEntryC( ID_VAR_TRACE_FLAGS
, "TRACE-FLAGS", 0 );
CreateDicEntryC( ID_VAR_TRACE_LEVEL
, "TRACE-LEVEL", 0 );
CreateDicEntryC( ID_VAR_TRACE_STACK
, "TRACE-STACK", 0 );
CreateDicEntryC( ID_VAR_OUT
, "OUT", 0 );
CreateDicEntryC( ID_VAR_STATE
, "STATE", 0 );
CreateDicEntryC( ID_VAR_TO_IN
, ">IN", 0 );
CreateDicEntryC( ID_WORD
, "WORD", 0 );
CreateDicEntryC( ID_WORD_FETCH
, "W@", 0 );
CreateDicEntryC( ID_WORD_STORE
, "W!", 0 );
CreateDicEntryC( ID_XOR
, "XOR", 0 );
CreateDicEntryC( ID_ZERO_BRANCH
, "0BRANCH", 0 );
pfDebugMessage("pfBuildDictionary: FindSpecialXTs\n");
if( FindSpecialXTs() < 0 ) goto error
;
if( CompileCustomFunctions() < 0 ) goto error
; /* Call custom 'C' call builder. */
DumpMemory( dic
->dic_HeaderBase
, 256 );
DumpMemory( dic
->dic_CodeBase
, 256 );
pfDebugMessage("pfBuildDictionary: Finished adding dictionary entries.\n");
return (PForthDictionary
) dic
;
pfDebugMessage("pfBuildDictionary: Error adding dictionary entries.\n");
pfDeleteDictionary( dic
);
** ( xt -- nfa 1 , x 0 , find NFA in dictionary from XT )
** 1 for IMMEDIATE values
cell_t
ffTokenToName( ExecToken XT
, const ForthString
**NFAPtr
)
const ForthString
*NameField
;
NameField
= (ForthString
*) gVarContext
;
DBUGX(("\ffCodeToName: gVarContext = 0x%x\n", gVarContext
));
TempXT
= NameToToken( NameField
);
DBUGX(("ffCodeToName: NFA = 0x%x\n", NameField
));
NameField
= NameToPrevious( NameField
);
** ( $name -- $addr 0 | nfa -1 | nfa 1 , find NFA in dictionary )
** 1 for IMMEDIATE values
cell_t
ffFindNFA( const ForthString
*WordName
, const ForthString
**NFAPtr
)
const ForthString
*WordChar
;
const char *NameField
, *NameChar
;
WordLen
= (uint8_t) ((ucell_t
)*WordName
& 0x1F);
NameField
= (ForthString
*) gVarContext
;
DBUG(("\nffFindNFA: WordLen = %d, WordName = %*s\n", WordLen
, WordLen
, WordChar
));
DBUG(("\nffFindNFA: gVarContext = 0x%x\n", gVarContext
));
NameLen
= (uint8_t) ((ucell_t
)(*NameField
) & MASK_NAME_SIZE
);
/* DBUG((" %c\n", (*NameField & FLAG_SMUDGE) ? 'S' : 'V' )); */
if( ((*NameField
& FLAG_SMUDGE
) == 0) &&
ffCompareTextCaseN( NameChar
, WordChar
, WordLen
) ) /* FIXME - slow */
DBUG(("ffFindNFA: found it at NFA = 0x%x\n", NameField
));
Result
= ((*NameField
) & FLAG_IMMEDIATE
) ? 1 : -1;
NameField
= NameToPrevious( NameField
);
DBUG(("ffFindNFA: returns 0x%x\n", Result
));
/***************************************************************
** ( $name -- $name 0 | xt -1 | xt 1 )
** 1 for IMMEDIATE values
cell_t
ffFind( const ForthString
*WordName
, ExecToken
*pXT
)
Result
= ffFindNFA( WordName
, &NFA
);
DBUG(("ffFind: %8s at 0x%x\n", WordName
+1, NFA
)); /* WARNING, not NUL terminated. %Q */
*pXT
= NameToToken( NFA
);
*pXT
= (ExecToken
) WordName
;
/****************************************************************
** Find name when passed 'C' string.
cell_t
ffFindC( const char *WordName
, ExecToken
*pXT
)
DBUG(("ffFindC: %s\n", WordName
));
CStringToForth( gScratch
, WordName
, sizeof(gScratch
) );
return ffFind( gScratch
, pXT
);
/***********************************************************/
/********* Compiling New Words *****************************/
/***********************************************************/
#define DIC_SAFETY_MARGIN (400)
/*************************************************************
** Check for dictionary overflow.
static cell_t
ffCheckDicRoom( void )
RoomLeft
= (char *)gCurrentDictionary
->dic_HeaderLimit
-
(char *)gCurrentDictionary
->dic_HeaderPtr
;
if( RoomLeft
< DIC_SAFETY_MARGIN
)
pfReportError("ffCheckDicRoom", PF_ERR_HEADER_ROOM
);
return PF_ERR_HEADER_ROOM
;
RoomLeft
= (char *)gCurrentDictionary
->dic_CodeLimit
-
(char *)gCurrentDictionary
->dic_CodePtr
.Byte
;
if( RoomLeft
< DIC_SAFETY_MARGIN
)
pfReportError("ffCheckDicRoom", PF_ERR_CODE_ROOM
);
/*************************************************************
** Create a dictionary entry given a string name.
void ffCreateSecondaryHeader( const ForthStringPtr FName
)
pfDebugMessage("ffCreateSecondaryHeader()\n");
/* Check for dictionary overflow. */
if( ffCheckDicRoom() ) return;
pfDebugMessage("ffCreateSecondaryHeader: CheckRedefinition()\n");
CheckRedefinition( FName
);
CODE_HERE
= (cell_t
*)( (((ucell_t
)CODE_HERE
) + UINT32_MASK
) & ~UINT32_MASK
);
CreateDicEntry( (ExecToken
) ABS_TO_CODEREL(CODE_HERE
), FName
, FLAG_SMUDGE
);
/*************************************************************
** Begin compiling a secondary word.
static void ffStringColon( const ForthStringPtr FName
)
ffCreateSecondaryHeader( FName
);
/*************************************************************
** Read the next ExecToken from the Source and create a word.
gDepthAtColon
= DATA_STACK_DEPTH
;
/*************************************************************
** Check to see if name is already in dictionary.
static cell_t
CheckRedefinition( const ForthStringPtr FName
)
flag
= ffFind( FName
, &XT
);
ioType( FName
+1, (cell_t
) *FName
);
MSG( " redefined.\n" ); /* FIXME - allow user to run off this warning. */
void ffStringCreate( char *FName
)
ffCreateSecondaryHeader( FName
);
CODE_COMMA( ID_CREATE_P
);
/* Read the next ExecToken from the Source and create a word. */
void ffStringDefer( const ForthStringPtr FName
, ExecToken DefaultXT
)
pfDebugMessage("ffStringDefer()\n");
ffCreateSecondaryHeader( FName
);
CODE_COMMA( ID_DEFER_P
);
/* Convert name then create deferred dictionary entry. */
static void CreateDeferredC( ExecToken DefaultXT
, const char *CName
)
CStringToForth( FName
, CName
, sizeof(FName
) );
ffStringDefer( FName
, DefaultXT
);
/* Read the next token from the Source and create a word. */
ffStringDefer( FName
, ID_QUIT_P
);
/* Unsmudge the word to make it visible. */
static void ffUnSmudge( void )
*(char*)gVarContext
&= ~FLAG_SMUDGE
;
ThrowCode
ffSemiColon( void )
if( (gDepthAtColon
!= DATA_STACK_DEPTH
) &&
(gDepthAtColon
!= DEPTH_AT_COLON_INVALID
) ) /* Ignore if no ':' */
exception
= THROW_SEMICOLON
;
gDepthAtColon
= DEPTH_AT_COLON_INVALID
;
/* Finish the definition of a Forth word. */
void ffFinishSecondary( void )
/**************************************************************/
/* Used to pull a number from the dictionary to the stack */
void ff2Literal( cell_t dHi
, cell_t dLo
)
CODE_COMMA( ID_2LITERAL_P
);
void ffALiteral( cell_t Num
)
CODE_COMMA( ID_ALITERAL_P
);
void ffLiteral( cell_t Num
)
CODE_COMMA( ID_LITERAL_P
);
void ffFPLiteral( PF_FLOAT fnum
)
/* Hack for Metrowerks complier which won't compile the
/* Make sure that literal float data is float aligned. */
while( (((ucell_t
) dicPtr
++) & (sizeof(PF_FLOAT
) - 1)) != 0)
DBUG((" comma NOOP to align FPLiteral\n"));
CODE_COMMA( ID_FP_FLITERAL_P
);
temp
= (PF_FLOAT
*)CODE_HERE
;
WRITE_FLOAT_DIC(temp
,fnum
); /* Write to dictionary. */
CODE_HERE
= (cell_t
*) temp
;
#endif /* PF_SUPPORT_FP */
/**************************************************************/
static ThrowCode
FindAndCompile( const char *theWord
)
Flag
= ffFind( theWord
, &XT
);
DBUG(("FindAndCompile: theWord = %8s, XT = 0x%x, Flag = %d\n", theWord
, XT
, Flag
));
/* Is it a normal word ? */
if( gVarState
) /* compiling? */
exception
= pfCatch( XT
);
else if ( Flag
== 1 ) /* or is it IMMEDIATE ? */
DBUG(("FindAndCompile: IMMEDIATE, theWord = 0x%x\n", theWord
));
exception
= pfCatch( XT
);
else /* try to interpret it as a number. */
/* Call deferred NUMBER? */
DBUG(("FindAndCompile: not found, try number?\n" ));
PUSH_DATA_STACK( theWord
); /* Push text of number */
exception
= pfCatch( gNumberQ_XT
);
if( exception
) goto error
;
DBUG(("FindAndCompile: after number?\n" ));
NumResult
= POP_DATA_STACK
; /* Success? */
if( gVarState
) /* compiling? */
if( gVarState
) /* compiling? */
Num
= POP_DATA_STACK
; /* get hi portion */
ff2Literal( Num
, POP_DATA_STACK
);
if( gVarState
) /* compiling? */
ffFPLiteral( *gCurrentTask
->td_FloatStackPtr
++ );
ioType( theWord
+1, *theWord
);
MSG( " ? - unrecognized word!\n" );
exception
= THROW_UNDEFINED_WORD
;
/**************************************************************
** Forth outer interpreter. Parses words from Source.
** Executes them or compiles them based on STATE.
ThrowCode
ffInterpret( void )
/* Is there any text left in Source ? */
while( gCurrentTask
->td_IN
< (gCurrentTask
->td_SourceNum
) )
pfDebugMessage("ffInterpret: calling ffWord(()\n");
theWord
= ffLWord( BLANK
);
DBUG(("ffInterpret: theWord = 0x%x, Len = %d\n", theWord
, *theWord
));
PUSH_DATA_STACK( theWord
); /* Push word. */
exception
= pfCatch( gLocalCompiler_XT
);
if( exception
) goto error
;
flag
= POP_DATA_STACK
; /* Compiled local? */
exception
= FindAndCompile( theWord
);
if( exception
) goto error
;
DBUG(("ffInterpret: IN=%d, SourceNum=%d\n", gCurrentTask
->td_IN
,
gCurrentTask
->td_SourceNum
) );
/**************************************************************/
/* Check for stack underflow. %Q what about overflows? */
if( (gCurrentTask
->td_StackBase
- gCurrentTask
->td_StackPtr
) < 0 )
exception
= THROW_STACK_UNDERFLOW
;
#ifdef PF_SUPPORT_FP /* Check floating point stack too! */
else if((gCurrentTask
->td_FloatStackBase
- gCurrentTask
->td_FloatStackPtr
) < 0)
exception
= THROW_FLOAT_STACK_UNDERFLOW
;
else if( gCurrentTask
->td_InputStream
== PF_STDIN
)
if( !gVarState
) /* executing? */
if(gVarTraceStack
) ffDotS();
/***************************************************************
** Cleanup Include stack by popping and closing files.
***************************************************************/
void pfHandleIncludeError( void )
while( (cur
= ffPopInputStream()) != PF_STDIN
)
DBUG(("ffCleanIncludeStack: closing 0x%x\n", cur
));
/***************************************************************
** Interpret input in a loop.
***************************************************************/
ThrowCode
ffOuterInterpreterLoop( void )
if(exception
<= 0) break;
exception
= ffInterpret();
} while( exception
== 0 );
/***************************************************************
** Include then close a file
***************************************************************/
ThrowCode
ffIncludeFile( FileStream
*InputFile
)
exception
= ffPushInputStream( InputFile
);
if( exception
< 0 ) return exception
;
/* Run outer interpreter for stream. */
exception
= ffOuterInterpreterLoop();
/* Report line number and nesting level. */
MSG("INCLUDE error on line #"); ffDot(gCurrentTask
->td_LineNumber
);
MSG(", level = "); ffDot(gIncludeIndex
);
/* Dump line of error and show offset in line for >IN */
for( i
=0; i
<gCurrentTask
->td_SourceNum
; i
++ )
char c
= gCurrentTask
->td_SourcePtr
[i
];
for( i
=0; i
<(gCurrentTask
->td_IN
- 1); i
++ ) EMIT('^');
/* ANSI spec specifies that this should also close the file. */
#endif /* !PF_NO_SHELL */
/***************************************************************
** Save current input stream on stack, use this new one.
***************************************************************/
Err
ffPushInputStream( FileStream
*InputFile
)
/* Push current input state onto special include stack. */
if( gIncludeIndex
< MAX_INCLUDE_DEPTH
)
inf
= &gIncludeStack
[gIncludeIndex
++];
inf
->inf_FileID
= gCurrentTask
->td_InputStream
;
inf
->inf_IN
= gCurrentTask
->td_IN
;
inf
->inf_LineNumber
= gCurrentTask
->td_LineNumber
;
inf
->inf_SourceNum
= gCurrentTask
->td_SourceNum
;
/* Copy TIB plus any NUL terminator into saved area. */
if( (inf
->inf_SourceNum
> 0) && (inf
->inf_SourceNum
< (TIB_SIZE
-1)) )
pfCopyMemory( inf
->inf_SaveTIB
, gCurrentTask
->td_TIB
, inf
->inf_SourceNum
+1 );
/* Set new current input. */
DBUG(( "ffPushInputStream: InputFile = 0x%x\n", InputFile
));
gCurrentTask
->td_InputStream
= InputFile
;
gCurrentTask
->td_LineNumber
= 0;
ERR("ffPushInputStream: max depth exceeded.\n");
/***************************************************************
** Go back to reading previous stream.
** Just return gCurrentTask->td_InputStream upon underflow.
***************************************************************/
FileStream
*ffPopInputStream( void )
DBUG(("ffPopInputStream: gIncludeIndex = %d\n", gIncludeIndex
));
Result
= gCurrentTask
->td_InputStream
;
/* Restore input state. */
inf
= &gIncludeStack
[--gIncludeIndex
];
gCurrentTask
->td_InputStream
= inf
->inf_FileID
;
DBUG(("ffPopInputStream: stream = 0x%x\n", gCurrentTask
->td_InputStream
));
gCurrentTask
->td_IN
= inf
->inf_IN
;
gCurrentTask
->td_LineNumber
= inf
->inf_LineNumber
;
gCurrentTask
->td_SourceNum
= inf
->inf_SourceNum
;
/* Copy TIB plus any NUL terminator into saved area. */
if( (inf
->inf_SourceNum
> 0) && (inf
->inf_SourceNum
< (TIB_SIZE
-1)) )
pfCopyMemory( gCurrentTask
->td_TIB
, inf
->inf_SaveTIB
, inf
->inf_SourceNum
+1 );
DBUG(("ffPopInputStream: return = 0x%x\n", Result
));
/***************************************************************
** Convert file pointer to value consistent with SOURCE-ID.
***************************************************************/
cell_t
ffConvertStreamToSourceID( FileStream
*Stream
)
Result
= (cell_t
) Stream
;
/***************************************************************
** Convert file pointer to value consistent with SOURCE-ID.
***************************************************************/
FileStream
* ffConvertSourceIDToStream( cell_t id
)
stream
= (FileStream
*) id
;
/**************************************************************
** Receive line from input stream.
** Return length, or -1 for EOF.
static cell_t
readLineFromStream( char *buffer
, cell_t maxChars
, FileStream
*stream
)
DBUGX(("readLineFromStream(0x%x, 0x%x, 0x%x)\n", buffer
, len
, stream
));
while( (len
< maxChars
) && !done
)
if( lastChar
!= '\r' ) done
= 1;
/* NUL terminate line to simplify printing when debugging. */
if( (len
>= 0) && (len
< maxChars
) ) p
[len
] = '\0';
/**************************************************************
** ( -- , fill Source from current stream )
** Return 1 if successful, 0 for EOF, or a negative error.
/* reset >IN for parser */
/* get line from current stream */
if( gCurrentTask
->td_InputStream
== PF_STDIN
)
/* ACCEPT is deferred so we call it through the dictionary. */
PUSH_DATA_STACK( gCurrentTask
->td_SourcePtr
);
PUSH_DATA_STACK( TIB_SIZE
);
Num
= readLineFromStream( gCurrentTask
->td_SourcePtr
, TIB_SIZE
,
gCurrentTask
->td_InputStream
);
gCurrentTask
->td_SourceNum
= Num
;
gCurrentTask
->td_LineNumber
++; /* Bump for include. */
/* echo input if requested */
if( gVarEcho
&& ( Num
> 0))
ioType( gCurrentTask
->td_SourcePtr
, gCurrentTask
->td_SourceNum
);