git.gag.com Git - debian/pforth/blob - csrc/pf_core.c

   1 /* @(#) pf_core.c 98/01/28 1.5 */
   2 /***************************************************************
   3 ** Forth based on 'C'
   4 **
   5 ** This file has the main entry points to the pForth library.
   6 **
   7 ** Author: Phil Burk
   8 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, Devid Rosenboom
   9 **
  10 ** The pForth software code is dedicated to the public domain,
  11 ** and any third party may reproduce, distribute and modify
  12 ** the pForth software code or any derivative works thereof
  13 ** without any compensation or license.  The pForth software
  14 ** code is provided on an "as is" basis without any warranty
  15 ** of any kind, including, without limitation, the implied
  16 ** warranties of merchantability and fitness for a particular
  17 ** purpose and their equivalents under the laws of any jurisdiction.
  18 **
  19 ****************************************************************
  20 ** 940502 PLB Creation.
  21 ** 940505 PLB More macros.
  22 ** 940509 PLB Moved all stack handling into inner interpreter.
  23 **        Added Create, Colon, Semicolon, HNumberQ, etc.
  24 ** 940510 PLB Got inner interpreter working with secondaries.
  25 **        Added (LITERAL).   Compiles colon definitions.
  26 ** 940511 PLB Added conditionals, LITERAL, CREATE DOES>
  27 ** 940512 PLB Added DO LOOP DEFER, fixed R>
  28 ** 940520 PLB Added INCLUDE
  29 ** 940521 PLB Added NUMBER?
  30 ** 940930 PLB Outer Interpreter now uses deferred NUMBER?
  31 ** 941005 PLB Added ANSI locals, LEAVE, modularised
  32 ** 950320 RDG Added underflow checking for FP stack
  33 ** 970702 PLB Added STACK_SAFETY to FP stack size.
  34 ***************************************************************/
  35
  36 #include "pf_all.h"
  37
  38 /***************************************************************
  39 ** Global Data
  40 ***************************************************************/
  41
  42 cfTaskData   *gCurrentTask;
  43 cfDictionary *gCurrentDictionary;
  44 int32         gNumPrimitives;
  45 char          gScratch[TIB_SIZE];
  46 ExecToken     gLocalCompiler_XT;   /* custom compiler for local variables */
  47
  48 /* Depth of data stack when colon called. */
  49 int32         gDepthAtColon;
  50
  51 /* Global Forth variables. */
  52 char *gVarContext;      /* Points to last name field. */
  53 cell  gVarState;        /* 1 if compiling. */
  54 cell  gVarBase;         /* Numeric Base. */
  55 cell  gVarEcho;         /* Echo input. */
  56 cell  gVarTraceLevel;   /* Trace Level for Inner Interpreter. */
  57 cell  gVarTraceStack;   /* Dump Stack each time if true. */
  58 cell  gVarTraceFlags;   /* Enable various internal debug messages. */
  59 cell  gVarQuiet;        /* Suppress unnecessary messages, OK, etc. */
  60 cell  gVarReturnCode;   /* Returned to caller of Forth, eg. UNIX shell. */
  61
  62 #define DEFAULT_RETURN_DEPTH (512)
  63 #define DEFAULT_USER_DEPTH (512)
  64 #define DEFAULT_HEADER_SIZE (120000)
  65 #define DEFAULT_CODE_SIZE (300000)
  66
  67 /* Initialize non-zero globals in a function to simplify loading on
  68  * embedded systems which may only support uninitialized data segments.
  69  */
  70 void pfInitGlobals( void )
  71 {
  72         gVarBase = 10;
  73         gVarTraceStack = 1;
  74         gDepthAtColon = DEPTH_AT_COLON_INVALID;
  75 }
  76
  77 /***************************************************************
  78 ** Task Management
  79 ***************************************************************/
  80
  81 void pfDeleteTask( cfTaskData *cftd )
  82 {
  83         FREE_VAR( cftd->td_ReturnLimit );
  84         FREE_VAR( cftd->td_StackLimit );
  85         pfFreeMem( cftd );
  86 }
  87 /* Allocate some extra cells to protect against mild stack underflows. */
  88 #define STACK_SAFETY  (8)
  89 cfTaskData *pfCreateTask( int32 UserStackDepth, int32 ReturnStackDepth )
  90 {
  91         cfTaskData *cftd;
  92
  93         cftd = ( cfTaskData * ) pfAllocMem( sizeof( cfTaskData ) );
  94         if( !cftd ) goto nomem;
  95         pfSetMemory( cftd, 0, sizeof( cfTaskData ));
  96
  97 /* Allocate User Stack */
  98         cftd->td_StackLimit = (cell *) pfAllocMem((uint32)(sizeof(int32) *
  99                                 (UserStackDepth + STACK_SAFETY)));
 100         if( !cftd->td_StackLimit ) goto nomem;
 101         cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;
 102         cftd->td_StackPtr = cftd->td_StackBase;
 103
 104 /* Allocate Return Stack */
 105         cftd->td_ReturnLimit = (cell *) pfAllocMem((uint32)(sizeof(int32) * ReturnStackDepth) );
 106         if( !cftd->td_ReturnLimit ) goto nomem;
 107         cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;
 108         cftd->td_ReturnPtr = cftd->td_ReturnBase;
 109
 110 /* Allocate Float Stack */
 111 #ifdef PF_SUPPORT_FP
 112 /* Allocate room for as many Floats as we do regular data. */
 113         cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((uint32)(sizeof(PF_FLOAT) *
 114                                 (UserStackDepth + STACK_SAFETY)));
 115         if( !cftd->td_FloatStackLimit ) goto nomem;
 116         cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;
 117         cftd->td_FloatStackPtr = cftd->td_FloatStackBase;
 118 #endif
 119
 120         cftd->td_InputStream = PF_STDIN;
 121
 122         cftd->td_SourcePtr = &cftd->td_TIB[0];
 123         cftd->td_SourceNum = 0;
 124
 125         return cftd;
 126
 127 nomem:
 128         ERR("CreateTaskContext: insufficient memory.\n");
 129         if( cftd ) pfDeleteTask( cftd );
 130         return NULL;
 131 }
 132
 133 /***************************************************************
 134 ** Dictionary Management
 135 ***************************************************************/
 136
 137 void pfExecByName( const char *CString )
 138 {
 139         if( NAME_BASE != NULL)
 140         {
 141                 ExecToken  autoInitXT;
 142                 if( ffFindC( CString, &autoInitXT ) )
 143                 {
 144                         pfExecuteToken( autoInitXT );
 145                 }
 146         }
 147 }
 148
 149 /***************************************************************
 150 ** Delete a dictionary created by pfCreateDictionary()
 151 */
 152 void pfDeleteDictionary( cfDictionary *dic )
 153 {
 154         if( !dic ) return;
 155
 156         if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )
 157         {
 158                 FREE_VAR( dic->dic_HeaderBaseUnaligned );
 159                 FREE_VAR( dic->dic_CodeBaseUnaligned );
 160         }
 161         pfFreeMem( dic );
 162 }
 163
 164 /***************************************************************
 165 ** Create a complete dictionary.
 166 ** The dictionary consists of two parts, the header with the names,
 167 ** and the code portion.
 168 ** Delete using pfDeleteDictionary().
 169 ** Return pointer to dictionary management structure.
 170 */
 171 cfDictionary *pfCreateDictionary( uint32 HeaderSize, uint32 CodeSize )
 172 {
 173 /* Allocate memory for initial dictionary. */
 174         cfDictionary *dic;
 175
 176         dic = ( cfDictionary * ) pfAllocMem( sizeof( cfDictionary ) );
 177         if( !dic ) goto nomem;
 178         pfSetMemory( dic, 0, sizeof( cfDictionary ));
 179
 180         dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;\r
 181 \r
 182 /* Align dictionary segments to preserve alignment of floats across hosts. */
 183 #define DIC_ALIGNMENT_SIZE  (0x10)\r
 184 #define DIC_ALIGN(addr)  ((uint8 *)((((uint32)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1)))\r
 185
 186 /* Allocate memory for header. */
 187         if( HeaderSize > 0 )
 188         {
 189                 dic->dic_HeaderBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) HeaderSize + DIC_ALIGNMENT_SIZE );
 190                 if( !dic->dic_HeaderBaseUnaligned ) goto nomem;\r
 191 /* Align header base. */\r
 192                 dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);
 193                 pfSetMemory( dic->dic_HeaderBase, 0xA5, (uint32) HeaderSize);
 194                 dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;
 195                 dic->dic_HeaderPtr.Byte = dic->dic_HeaderBase;
 196         }
 197         else
 198         {
 199                 dic->dic_HeaderBase = NULL;
 200         }
 201
 202 /* Allocate memory for code. */
 203         dic->dic_CodeBaseUnaligned = ( uint8 * ) pfAllocMem( (uint32) CodeSize + DIC_ALIGNMENT_SIZE );
 204         if( !dic->dic_CodeBaseUnaligned ) goto nomem;\r
 205         dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);
 206         pfSetMemory( dic->dic_CodeBase, 0x5A, (uint32) CodeSize);
 207
 208         dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;
 209         dic->dic_CodePtr.Byte = dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES);
 210
 211         return dic;
 212 nomem:
 213         pfDeleteDictionary( dic );
 214         return NULL;
 215 }
 216
 217 /***************************************************************
 218 ** Used by Quit and other routines to restore system.
 219 ***************************************************************/
 220
 221 void ResetForthTask( void )
 222 {
 223 /* Go back to terminal input. */
 224         gCurrentTask->td_InputStream = PF_STDIN;
 225
 226 /* Reset stacks. */
 227         gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;
 228         gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;
 229 #ifdef PF_SUPPORT_FP  /* Reset Floating Point stack too! */
 230         gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;
 231 #endif
 232
 233 /* Advance >IN to end of input. */
 234         gCurrentTask->td_IN = gCurrentTask->td_SourceNum;
 235         gVarState = 0;
 236 }
 237
 238 /***************************************************************
 239 ** Set current task context.
 240 ***************************************************************/
 241
 242 void pfSetCurrentTask( cfTaskData *cftd )
 243 {
 244         gCurrentTask = cftd;
 245 }
 246
 247 /***************************************************************
 248 ** Set Quiet Flag.
 249 ***************************************************************/
 250
 251 void pfSetQuiet( int32 IfQuiet )
 252 {
 253         gVarQuiet = (cell) IfQuiet;
 254 }
 255
 256 /***************************************************************
 257 ** Query message status.
 258 ***************************************************************/
 259
 260 int32  pfQueryQuiet( void )
 261 {
 262         return gVarQuiet;
 263 }
 264
 265 /***************************************************************
 266 ** RunForth
 267 ***************************************************************/
 268
 269 int32 pfRunForth( void )
 270 {
 271         ffQuit();
 272         return gVarReturnCode;
 273 }
 274
 275 /***************************************************************
 276 ** Include file based on 'C' name.
 277 ***************************************************************/
 278
 279 int32 pfIncludeFile( const char *FileName )
 280 {
 281         FileStream *fid;
 282         int32 Result;
 283         char  buffer[32];
 284         int32 numChars, len;
 285
 286 /* Open file. */
 287         fid = sdOpenFile( FileName, "r" );
 288         if( fid == NULL )
 289         {
 290                 ERR("pfIncludeFile could not open ");
 291                 ERR(FileName);
 292                 EMIT_CR;
 293                 return -1;
 294         }
 295
 296 /* Create a dictionary word named ::::FileName for FILE? */
 297         pfCopyMemory( &buffer[0], "::::", 4);
 298         len = pfCStringLength(FileName);
 299         numChars = ( len > (32-4-1) ) ? (32-4-1) : len;
 300         pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );
 301         CreateDicEntryC( ID_NOOP, buffer, 0 );
 302
 303         Result = ffIncludeFile( fid );
 304
 305 /* Create a dictionary word named ;;;; for FILE? */
 306         CreateDicEntryC( ID_NOOP, ";;;;", 0 );
 307
 308         sdCloseFile(fid);
 309         return Result;
 310 }
 311
 312 /***************************************************************
 313 ** Output 'C' string message.
 314 ** This is provided to help avoid the use of printf() and other I/O
 315 ** which may not be present on a small embedded system.
 316 ***************************************************************/
 317
 318 void pfMessage( const char *CString )
 319 {
 320         ioType( CString, pfCStringLength(CString) );
 321 }
 322
 323 /**************************************************************************
 324 ** Main entry point fo pForth
 325 */
 326 int32 pfDoForth( const char *DicName, const char *SourceName, int32 IfInit )
 327 {
 328         cfTaskData *cftd;
 329         cfDictionary *dic;
 330         int32 Result = 0;
 331         ExecToken  EntryPoint = 0;
 332         \r
 333 #ifdef PF_USER_INIT\r
 334         Result = PF_USER_INIT;\r
 335         if( Result < 0 ) goto error;\r
 336 #endif\r
 337
 338         pfInitGlobals();
 339
 340 /* Allocate Task structure. */
 341         cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );
 342
 343         if( cftd )
 344         {
 345                 pfSetCurrentTask( cftd );
 346
 347                 if( !pfQueryQuiet() )
 348                 {
 349                         MSG( "PForth V"PFORTH_VERSION"\n" );
 350                 }
 351
 352 #if 0
 353 /* Don't use MSG before task set. */
 354                 if( IfInit ) MSG("Build dictionary from scratch.\n");
 355
 356                 if( DicName )
 357                 {
 358                         MSG("DicName = "); MSG(DicName); MSG("\n");
 359                 }
 360                 if( SourceName )
 361                 {
 362                         MSG("SourceName = "); MSG(SourceName); MSG("\n");
 363                 }
 364 #endif
 365
 366
 367 #ifdef PF_NO_GLOBAL_INIT
 368                 if( LoadCustomFunctionTable() < 0 ) goto error; /* Init custom 'C' call array. */
 369 #endif
 370
 371 #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
 372                 if( IfInit )
 373                 {
 374                         dic = pfBuildDictionary( DEFAULT_HEADER_SIZE, DEFAULT_CODE_SIZE );
 375                 }
 376                 else
 377 #else
 378         TOUCH(IfInit);
 379 #endif /* !PF_NO_INIT && !PF_NO_SHELL*/
 380                 {
 381                         dic = pfLoadDictionary( DicName, &EntryPoint );
 382                 }
 383                 if( dic == NULL ) goto error;
 384                 \r
 385                 pfExecByName("AUTO.INIT");
 386
 387                 if( EntryPoint != 0 )
 388                 {
 389                         pfExecuteToken( EntryPoint );
 390                 }
 391 #ifndef PF_NO_SHELL
 392                 else
 393                 {
 394                         if( SourceName == NULL )
 395                         {
 396                                 Result = pfRunForth();
 397                         }
 398                         else
 399                         {
 400                                 MSG("Including: ");
 401                                 MSG(SourceName);
 402                                 MSG("\n");
 403                                 Result = pfIncludeFile( SourceName );
 404                         }
 405                 }
 406 #endif /* PF_NO_SHELL */
 407                 pfExecByName("AUTO.TERM");
 408                 pfDeleteDictionary( dic );
 409                 pfDeleteTask( cftd );
 410         }\r
 411         \r
 412 #ifdef PF_USER_TERM\r
 413         PF_USER_TERM;\r
 414 #endif\r
 415
 416         return Result;
 417
 418 error:
 419         MSG("pfDoForth: Error occured.\n");
 420         pfDeleteTask( cftd );
 421         return -1;
 422 }