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, David Rosenboom
   9 **
  10 ** Permission to use, copy, modify, and/or distribute this
  11 ** software for any purpose with or without fee is hereby granted.
  12 **
  13 ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  14 ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  15 ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  16 ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  17 ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  18 ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  19 ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  20 ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  21 **
  22 ****************************************************************
  23 ** 940502 PLB Creation.
  24 ** 940505 PLB More macros.
  25 ** 940509 PLB Moved all stack handling into inner interpreter.
  26 **        Added Create, Colon, Semicolon, HNumberQ, etc.
  27 ** 940510 PLB Got inner interpreter working with secondaries.
  28 **        Added (LITERAL).   Compiles colon definitions.
  29 ** 940511 PLB Added conditionals, LITERAL, CREATE DOES>
  30 ** 940512 PLB Added DO LOOP DEFER, fixed R>
  31 ** 940520 PLB Added INCLUDE
  32 ** 940521 PLB Added NUMBER?
  33 ** 940930 PLB Outer Interpreter now uses deferred NUMBER?
  34 ** 941005 PLB Added ANSI locals, LEAVE, modularised
  35 ** 950320 RDG Added underflow checking for FP stack
  36 ** 970702 PLB Added STACK_SAFETY to FP stack size.
  37 ***************************************************************/
  38
  39 #include "pf_all.h"
  40
  41 /***************************************************************
  42 ** Global Data
  43 ***************************************************************/
  44
  45 char            gScratch[TIB_SIZE];
  46 pfTaskData_t   *gCurrentTask = NULL;
  47 pfDictionary_t *gCurrentDictionary;
  48 cell_t          gNumPrimitives;
  49
  50 ExecToken       gLocalCompiler_XT;   /* custom compiler for local variables */
  51 ExecToken       gNumberQ_XT;         /* XT of NUMBER? */
  52 ExecToken       gQuitP_XT;           /* XT of (QUIT) */
  53 ExecToken       gAcceptP_XT;         /* XT of ACCEPT */
  54
  55 /* Depth of data stack when colon called. */
  56 cell_t          gDepthAtColon;
  57
  58 /* Global Forth variables.
  59 * These must be initialized in pfInit below.
  60 */
  61 cell_t          gVarContext;      /* Points to last name field. */
  62 cell_t          gVarState;        /* 1 if compiling. */
  63 cell_t          gVarBase;         /* Numeric Base. */
  64 cell_t          gVarByeCode;      /* Echo input. */
  65 cell_t          gVarEcho;         /* Echo input. */
  66 cell_t          gVarTraceLevel;   /* Trace Level for Inner Interpreter. */
  67 cell_t          gVarTraceStack;   /* Dump Stack each time if true. */
  68 cell_t          gVarTraceFlags;   /* Enable various internal debug messages. */
  69 cell_t          gVarQuiet;        /* Suppress unnecessary messages, OK, etc. */
  70 cell_t          gVarReturnCode;   /* Returned to caller of Forth, eg. UNIX shell. */
  71
  72 /* data for INCLUDE that allows multiple nested files. */
  73 IncludeFrame    gIncludeStack[MAX_INCLUDE_DEPTH];
  74 cell_t          gIncludeIndex;
  75
  76 static void pfResetForthTask( void );
  77 static void pfInit( void );
  78 static void pfTerm( void );
  79
  80 #define DEFAULT_RETURN_DEPTH (512)
  81 #define DEFAULT_USER_DEPTH (512)
  82
  83 #ifndef PF_DEFAULT_HEADER_SIZE
  84 #define PF_DEFAULT_HEADER_SIZE (120000)
  85 #endif
  86
  87 #ifndef PF_DEFAULT_CODE_SIZE
  88 #define PF_DEFAULT_CODE_SIZE (300000)
  89 #endif
  90
  91 /* Initialize globals in a function to simplify loading on
  92  * embedded systems which may not support initialization of data section.
  93  */
  94 static void pfInit( void )
  95 {
  96 /* all zero */
  97     gCurrentTask = NULL;
  98     gCurrentDictionary = NULL;
  99     gNumPrimitives = 0;
 100     gLocalCompiler_XT = 0;
 101     gVarContext = (cell_t)NULL;   /* Points to last name field. */
 102     gVarState = 0;        /* 1 if compiling. */
 103     gVarByeCode = 0;      /* BYE-CODE */
 104     gVarEcho = 0;         /* Echo input. */
 105     gVarTraceLevel = 0;   /* Trace Level for Inner Interpreter. */
 106     gVarTraceFlags = 0;   /* Enable various internal debug messages. */
 107     gVarReturnCode = 0;   /* Returned to caller of Forth, eg. UNIX shell. */
 108     gIncludeIndex = 0;
 109
 110 /* non-zero */
 111     gVarBase = 10;        /* Numeric Base. */
 112     gDepthAtColon = DEPTH_AT_COLON_INVALID;
 113     gVarTraceStack = 1;
 114
 115     pfInitMemoryAllocator();
 116     ioInit();
 117 }
 118 static void pfTerm( void )
 119 {
 120     ioTerm();
 121 }
 122
 123 /***************************************************************
 124 ** Task Management
 125 ***************************************************************/
 126
 127 void pfDeleteTask( PForthTask task )
 128 {
 129     pfTaskData_t *cftd = (pfTaskData_t *)task;
 130     FREE_VAR( cftd->td_ReturnLimit );
 131     FREE_VAR( cftd->td_StackLimit );
 132     pfFreeMem( cftd );
 133 }
 134
 135 /* Allocate some extra cells to protect against mild stack underflows. */
 136 #define STACK_SAFETY  (8)
 137 PForthTask pfCreateTask( cell_t UserStackDepth, cell_t ReturnStackDepth )
 138 {
 139     pfTaskData_t *cftd;
 140
 141     cftd = ( pfTaskData_t * ) pfAllocMem( sizeof( pfTaskData_t ) );
 142     if( !cftd ) goto nomem;
 143     pfSetMemory( cftd, 0, sizeof( pfTaskData_t ));
 144
 145 /* Allocate User Stack */
 146     cftd->td_StackLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) *
 147                 (UserStackDepth + STACK_SAFETY)));
 148     if( !cftd->td_StackLimit ) goto nomem;
 149     cftd->td_StackBase = cftd->td_StackLimit + UserStackDepth;
 150     cftd->td_StackPtr = cftd->td_StackBase;
 151
 152 /* Allocate Return Stack */
 153     cftd->td_ReturnLimit = (cell_t *) pfAllocMem((ucell_t)(sizeof(cell_t) * ReturnStackDepth) );
 154     if( !cftd->td_ReturnLimit ) goto nomem;
 155     cftd->td_ReturnBase = cftd->td_ReturnLimit + ReturnStackDepth;
 156     cftd->td_ReturnPtr = cftd->td_ReturnBase;
 157
 158 /* Allocate Float Stack */
 159 #ifdef PF_SUPPORT_FP
 160 /* Allocate room for as many Floats as we do regular data. */
 161     cftd->td_FloatStackLimit = (PF_FLOAT *) pfAllocMem((ucell_t)(sizeof(PF_FLOAT) *
 162                 (UserStackDepth + STACK_SAFETY)));
 163     if( !cftd->td_FloatStackLimit ) goto nomem;
 164     cftd->td_FloatStackBase = cftd->td_FloatStackLimit + UserStackDepth;
 165     cftd->td_FloatStackPtr = cftd->td_FloatStackBase;
 166 #endif
 167
 168     cftd->td_InputStream = PF_STDIN;
 169
 170     cftd->td_SourcePtr = &cftd->td_TIB[0];
 171     cftd->td_SourceNum = 0;
 172
 173     return (PForthTask) cftd;
 174
 175 nomem:
 176     ERR("CreateTaskContext: insufficient memory.\n");
 177     if( cftd ) pfDeleteTask( (PForthTask) cftd );
 178     return NULL;
 179 }
 180
 181 /***************************************************************
 182 ** Dictionary Management
 183 ***************************************************************/
 184
 185 ThrowCode pfExecIfDefined( const char *CString )
 186 {
 187     ThrowCode result = 0;
 188     if( NAME_BASE != (cell_t)NULL)
 189     {
 190         ExecToken  XT;
 191         if( ffFindC( CString, &XT ) )
 192         {
 193             result = pfCatch( XT );
 194         }
 195     }
 196     return result;
 197 }
 198
 199 /***************************************************************
 200 ** Delete a dictionary created by pfCreateDictionary()
 201 */
 202 void pfDeleteDictionary( PForthDictionary dictionary )
 203 {
 204     pfDictionary_t *dic = (pfDictionary_t *) dictionary;
 205     if( !dic ) return;
 206
 207     if( dic->dic_Flags & PF_DICF_ALLOCATED_SEGMENTS )
 208     {
 209         FREE_VAR( dic->dic_HeaderBaseUnaligned );
 210         FREE_VAR( dic->dic_CodeBaseUnaligned );
 211     }
 212     pfFreeMem( dic );
 213 }
 214
 215 /***************************************************************
 216 ** Create a complete dictionary.
 217 ** The dictionary consists of two parts, the header with the names,
 218 ** and the code portion.
 219 ** Delete using pfDeleteDictionary().
 220 ** Return pointer to dictionary management structure.
 221 */
 222 PForthDictionary pfCreateDictionary( cell_t HeaderSize, cell_t CodeSize )
 223 {
 224 /* Allocate memory for initial dictionary. */
 225     pfDictionary_t *dic;
 226
 227     dic = ( pfDictionary_t * ) pfAllocMem( sizeof( pfDictionary_t ) );
 228     if( !dic ) goto nomem;
 229     pfSetMemory( dic, 0, sizeof( pfDictionary_t ));
 230
 231     dic->dic_Flags |= PF_DICF_ALLOCATED_SEGMENTS;
 232
 233 /* Align dictionary segments to preserve alignment of floats across hosts.
 234  * Thank you Helmut Proelss for pointing out that this needs to be cast
 235  * to (ucell_t) on 16 bit systems.
 236  */
 237 #define DIC_ALIGNMENT_SIZE  ((ucell_t)(0x10))
 238 #define DIC_ALIGN(addr)  ((((ucell_t)(addr)) + DIC_ALIGNMENT_SIZE - 1) & ~(DIC_ALIGNMENT_SIZE - 1))
 239
 240 /* Allocate memory for header. */
 241     if( HeaderSize > 0 )
 242     {
 243         dic->dic_HeaderBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) HeaderSize + DIC_ALIGNMENT_SIZE );
 244         if( !dic->dic_HeaderBaseUnaligned ) goto nomem;
 245 /* Align header base. */
 246         dic->dic_HeaderBase = DIC_ALIGN(dic->dic_HeaderBaseUnaligned);
 247         pfSetMemory( (char *) dic->dic_HeaderBase, 0xA5, (ucell_t) HeaderSize);
 248         dic->dic_HeaderLimit = dic->dic_HeaderBase + HeaderSize;
 249         dic->dic_HeaderPtr = dic->dic_HeaderBase;
 250     }
 251     else
 252     {
 253         dic->dic_HeaderBase = 0;
 254     }
 255
 256 /* Allocate memory for code. */
 257     dic->dic_CodeBaseUnaligned = (ucell_t) pfAllocMem( (ucell_t) CodeSize + DIC_ALIGNMENT_SIZE );
 258     if( !dic->dic_CodeBaseUnaligned ) goto nomem;
 259     dic->dic_CodeBase = DIC_ALIGN(dic->dic_CodeBaseUnaligned);
 260     pfSetMemory( (char *) dic->dic_CodeBase, 0x5A, (ucell_t) CodeSize);
 261
 262     dic->dic_CodeLimit = dic->dic_CodeBase + CodeSize;
 263     dic->dic_CodePtr.Byte = ((uint8_t *) (dic->dic_CodeBase + QUADUP(NUM_PRIMITIVES)));
 264
 265     return (PForthDictionary) dic;
 266 nomem:
 267     pfDeleteDictionary( dic );
 268     return NULL;
 269 }
 270
 271 /***************************************************************
 272 ** Used by Quit and other routines to restore system.
 273 ***************************************************************/
 274
 275 static void pfResetForthTask( void )
 276 {
 277 /* Go back to terminal input. */
 278     gCurrentTask->td_InputStream = PF_STDIN;
 279
 280 /* Reset stacks. */
 281     gCurrentTask->td_StackPtr = gCurrentTask->td_StackBase;
 282     gCurrentTask->td_ReturnPtr = gCurrentTask->td_ReturnBase;
 283 #ifdef PF_SUPPORT_FP  /* Reset Floating Point stack too! */
 284     gCurrentTask->td_FloatStackPtr = gCurrentTask->td_FloatStackBase;
 285 #endif
 286
 287 /* Advance >IN to end of input. */
 288     gCurrentTask->td_IN = gCurrentTask->td_SourceNum;
 289     gVarState = 0;
 290 }
 291
 292 /***************************************************************
 293 ** Set current task context.
 294 ***************************************************************/
 295
 296 void pfSetCurrentTask( PForthTask task )
 297 {
 298     gCurrentTask = (pfTaskData_t *) task;
 299 }
 300
 301 /***************************************************************
 302 ** Set Quiet Flag.
 303 ***************************************************************/
 304
 305 void pfSetQuiet( cell_t IfQuiet )
 306 {
 307     gVarQuiet = (cell_t) IfQuiet;
 308 }
 309
 310 /***************************************************************
 311 ** Query message status.
 312 ***************************************************************/
 313
 314 cell_t  pfQueryQuiet( void )
 315 {
 316     return gVarQuiet;
 317 }
 318
 319 /***************************************************************
 320 ** Top level interpreter.
 321 ***************************************************************/
 322 ThrowCode pfQuit( void )
 323 {
 324     ThrowCode exception;
 325     int go = 1;
 326
 327     while(go)
 328     {
 329         exception = ffOuterInterpreterLoop();
 330         if( exception == 0 )
 331         {
 332             exception = ffOK();
 333         }
 334
 335         switch( exception )
 336         {
 337         case 0:
 338             break;
 339
 340         case THROW_BYE:
 341             go = 0;
 342             break;
 343
 344         case THROW_ABORT:
 345         default:
 346             ffDotS();
 347             pfReportThrow( exception );
 348             pfHandleIncludeError();
 349             pfResetForthTask();
 350             break;
 351         }
 352     }
 353
 354     return gVarReturnCode;
 355 }
 356
 357 /***************************************************************
 358 ** Include file based on 'C' name.
 359 ***************************************************************/
 360
 361 cell_t pfIncludeFile( const char *FileName )
 362 {
 363     FileStream *fid;
 364     cell_t Result;
 365     char  buffer[32];
 366     cell_t numChars, len;
 367
 368 /* Open file. */
 369     fid = sdOpenFile( FileName, "r" );
 370     if( fid == NULL )
 371     {
 372         ERR("pfIncludeFile could not open ");
 373         ERR(FileName);
 374         EMIT_CR;
 375         return -1;
 376     }
 377
 378 /* Create a dictionary word named ::::FileName for FILE? */
 379     pfCopyMemory( &buffer[0], "::::", 4);
 380     len = (cell_t) pfCStringLength(FileName);
 381     numChars = ( len > (32-4-1) ) ? (32-4-1) : len;
 382     pfCopyMemory( &buffer[4], &FileName[len-numChars], numChars+1 );
 383     CreateDicEntryC( ID_NOOP, buffer, 0 );
 384
 385     Result = ffIncludeFile( fid ); /* Also close the file. */
 386
 387 /* Create a dictionary word named ;;;; for FILE? */
 388     CreateDicEntryC( ID_NOOP, ";;;;", 0 );
 389
 390     return Result;
 391 }
 392
 393 /***************************************************************
 394 ** Output 'C' string message.
 395 ** Use sdTerminalOut which works before initializing gCurrentTask.
 396 ***************************************************************/
 397 void pfDebugMessage( const char *CString )
 398 {
 399 #if 0
 400     while( *CString )
 401     {
 402         char c = *CString++;
 403         if( c == '\n' )
 404         {
 405             sdTerminalOut( 0x0D );
 406             sdTerminalOut( 0x0A );
 407             pfDebugMessage( "DBG: " );
 408         }
 409         else
 410         {
 411             sdTerminalOut( c );
 412         }
 413     }
 414 #else
 415     (void)CString;
 416 #endif
 417 }
 418
 419 /***************************************************************
 420 ** Print a decimal number to debug output.
 421 */
 422 void pfDebugPrintDecimalNumber( int n )
 423 {
 424     pfDebugMessage( ConvertNumberToText( n, 10, TRUE, 1 ) );
 425 }
 426
 427
 428 /***************************************************************
 429 ** Output 'C' string message.
 430 ** This is provided to help avoid the use of printf() and other I/O
 431 ** which may not be present on a small embedded system.
 432 ** Uses ioType & ioEmit so requires that gCurrentTask has been initialized.
 433 ***************************************************************/
 434 void pfMessage( const char *CString )
 435 {
 436     ioType( CString, (cell_t) pfCStringLength(CString) );
 437 }
 438
 439 /**************************************************************************
 440 ** Main entry point for pForth.
 441 */
 442 ThrowCode pfDoForth( const char *DicFileName, const char *SourceName, cell_t IfInit )
 443 {
 444     pfTaskData_t *cftd;
 445     pfDictionary_t *dic = NULL;
 446     ThrowCode Result = 0;
 447     ExecToken  EntryPoint = 0;
 448
 449 #ifdef PF_USER_INIT
 450     Result = PF_USER_INIT;
 451     if( Result < 0 ) goto error1;
 452 #endif
 453
 454     pfInit();
 455
 456 /* Allocate Task structure. */
 457     pfDebugMessage("pfDoForth: call pfCreateTask()\n");
 458     cftd = pfCreateTask( DEFAULT_USER_DEPTH, DEFAULT_RETURN_DEPTH );
 459
 460     if( cftd )
 461     {
 462         pfSetCurrentTask( cftd );
 463
 464         if( !gVarQuiet )
 465         {
 466             MSG( "PForth V"PFORTH_VERSION );
 467             if( IsHostLittleEndian() ) MSG("-LE");
 468             else MSG("-BE");
 469 #if PF_BIG_ENDIAN_DIC
 470             MSG("/BE");
 471 #elif PF_LITTLE_ENDIAN_DIC
 472             MSG("/LE");
 473 #endif
 474             if (sizeof(cell_t) == 8)
 475             {
 476                 MSG("/64");
 477             }
 478             else if (sizeof(cell_t) == 4)
 479             {
 480                 MSG("/32");
 481             }
 482
 483             MSG( ", built "__DATE__" "__TIME__ );
 484         }
 485
 486 /* Don't use MSG before task set. */
 487         if( SourceName )
 488         {
 489             pfDebugMessage("SourceName = "); pfDebugMessage(SourceName); pfDebugMessage("\n");
 490         }
 491
 492
 493 #ifdef PF_NO_GLOBAL_INIT
 494         if( LoadCustomFunctionTable() < 0 ) goto error2; /* Init custom 'C' call array. */
 495 #endif
 496
 497 #if (!defined(PF_NO_INIT)) && (!defined(PF_NO_SHELL))
 498         if( IfInit )
 499         {
 500             pfDebugMessage("Build dictionary from scratch.\n");
 501             dic = pfBuildDictionary( PF_DEFAULT_HEADER_SIZE, PF_DEFAULT_CODE_SIZE );
 502         }
 503         else
 504 #else
 505         TOUCH(IfInit);
 506 #endif /* !PF_NO_INIT && !PF_NO_SHELL*/
 507         {
 508             if( DicFileName )
 509             {
 510                 pfDebugMessage("DicFileName = "); pfDebugMessage(DicFileName); pfDebugMessage("\n");
 511                 if( !gVarQuiet )
 512                 {
 513                     EMIT_CR;
 514                 }
 515                 dic = pfLoadDictionary( DicFileName, &EntryPoint );
 516             }
 517             else
 518             {
 519                 if( !gVarQuiet )
 520                 {
 521                     MSG(" (static)");
 522                     EMIT_CR;
 523                 }
 524                 dic = pfLoadStaticDictionary();
 525             }
 526         }
 527         if( dic == NULL ) goto error2;
 528
 529         if( !gVarQuiet )
 530         {
 531             EMIT_CR;
 532         }
 533
 534         pfDebugMessage("pfDoForth: try AUTO.INIT\n");
 535         Result = pfExecIfDefined("AUTO.INIT");
 536         if( Result != 0 )
 537         {
 538             MSG("Error in AUTO.INIT");
 539             goto error2;
 540         }
 541
 542         if( EntryPoint != 0 )
 543         {
 544             Result = pfCatch( EntryPoint );
 545         }
 546 #ifndef PF_NO_SHELL
 547         else
 548         {
 549             if( SourceName == NULL )
 550             {
 551                 pfDebugMessage("pfDoForth: pfQuit\n");
 552                 Result = pfQuit();
 553             }
 554             else
 555             {
 556                 if( !gVarQuiet )
 557                 {
 558                     MSG("Including: ");
 559                     MSG(SourceName);
 560                     MSG("\n");
 561                 }
 562                 Result = pfIncludeFile( SourceName );
 563             }
 564         }
 565 #endif /* PF_NO_SHELL */
 566
 567     /* Clean up after running Forth. */
 568         pfExecIfDefined("AUTO.TERM");
 569         pfDeleteDictionary( dic );
 570         pfDeleteTask( cftd );
 571     }
 572
 573     pfTerm();
 574
 575 #ifdef PF_USER_TERM
 576     PF_USER_TERM;
 577 #endif
 578
 579     return Result ? Result : gVarByeCode;
 580
 581 error2:
 582     MSG("pfDoForth: Error occured.\n");
 583     pfDeleteTask( cftd );
 584     /* Terminate so we restore normal shell tty mode. */
 585     pfTerm();
 586
 587 #ifdef PF_USER_INIT
 588 error1:
 589 #endif
 590
 591     return -1;
 592 }
 593
 594
 595 #ifdef PF_UNIT_TEST
 596 cell_t pfUnitTest( void )
 597 {
 598     cell_t numErrors = 0;
 599     numErrors += pfUnitTestText();
 600     return numErrors;
 601 }
 602 #endif