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