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