Recognize Forth 2012 number syntax
[debian/pforth] / csrc / pf_guts.h
1 /* @(#) pf_guts.h 98/01/28 1.4 */
2 #ifndef _pf_guts_h
3 #define _pf_guts_h
4
5 /***************************************************************
6 ** Include file for PForth, a Forth based on 'C'
7 **
8 ** Author: Phil Burk
9 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
10 **
11 ** The pForth software code is dedicated to the public domain,
12 ** and any third party may reproduce, distribute and modify
13 ** the pForth software code or any derivative works thereof
14 ** without any compensation or license.  The pForth software
15 ** code is provided on an "as is" basis without any warranty
16 ** of any kind, including, without limitation, the implied
17 ** warranties of merchantability and fitness for a particular
18 ** purpose and their equivalents under the laws of any jurisdiction.
19 **
20 ***************************************************************/
21
22 /*
23 ** PFORTH_VERSION changes when PForth is modified and released.
24 ** See README file for version info.
25 */
26 #define PFORTH_VERSION "27"
27
28 /*
29 ** PFORTH_FILE_VERSION changes when incompatible changes are made
30 ** in the ".dic" file format.
31 **
32 ** FV3 - 950225 - Use ABS_TO_CODEREL for CodePtr. See file "pf_save.c".
33 ** FV4 - 950309 - Added NameSize and CodeSize to pfSaveForth().
34 ** FV5 - 950316 - Added Floats and reserved words.
35 ** FV6 - 961213 - Added ID_LOCAL_PLUSSTORE, ID_COLON_P, etc.
36 ** FV7 - 971203 - Added ID_FILL, (1LOCAL@),  etc., ran out of reserved, resorted.
37 ** FV8 - 980818 - Added Endian flag.
38 ** FV9 - 20100503 - Added support for 64-bit CELL.
39 */
40 #define PF_FILE_VERSION (9)   /* Bump this whenever primitives added. */
41 #define PF_EARLIEST_FILE_VERSION (9)  /* earliest one still compatible */
42
43 /***************************************************************
44 ** Sizes and other constants
45 ***************************************************************/
46
47 #define TIB_SIZE (256)
48
49 #ifndef FALSE
50     #define FALSE (0)
51 #endif
52 #ifndef TRUE
53     #define TRUE (1)
54 #endif
55
56 #define FFALSE (0)
57 #define FTRUE (-1)
58 #define BLANK (' ')
59
60 #define FLAG_PRECEDENCE (0x80)
61 #define FLAG_IMMEDIATE  (0x40)
62 #define FLAG_SMUDGE     (0x20)
63 #define MASK_NAME_SIZE  (0x1F)
64
65 /* Debug TRACE flags */
66 #define TRACE_INNER     (0x0002)
67 #define TRACE_COMPILE   (0x0004)
68 #define TRACE_SPECIAL   (0x0008)
69
70 /* Numeric types returned by NUMBER? */
71 #define NUM_TYPE_BAD    (0)
72 #define NUM_TYPE_SINGLE (1)
73 #define NUM_TYPE_DOUBLE (2)
74 #define NUM_TYPE_FLOAT  (3)
75
76 #define CREATE_BODY_OFFSET  (3*sizeof(cell_t))
77
78 /***************************************************************
79 ** Primitive Token IDS
80 ** Do NOT change the order of these IDs or dictionary files will break!
81 ***************************************************************/
82 enum cforth_primitive_ids
83 {
84     ID_EXIT = 0,  /* ID_EXIT must always be zero. */
85 /* Do NOT change the order of these IDs or dictionary files will break! */
86     ID_1MINUS,
87     ID_1PLUS,
88     ID_2DUP,
89     ID_2LITERAL,
90     ID_2LITERAL_P,
91     ID_2MINUS,
92     ID_2OVER,
93     ID_2PLUS,
94     ID_2SWAP,
95     ID_2_R_FETCH,
96     ID_2_R_FROM,
97     ID_2_TO_R,
98     ID_ACCEPT_P,
99     ID_ALITERAL,
100     ID_ALITERAL_P,
101     ID_ALLOCATE,
102     ID_AND,
103     ID_ARSHIFT,
104     ID_BAIL,
105     ID_BODY_OFFSET,
106     ID_BRANCH,
107     ID_BYE,
108     ID_CALL_C,
109     ID_CFETCH,
110     ID_CMOVE,
111     ID_CMOVE_UP,
112     ID_COLON,
113     ID_COLON_P,
114     ID_COMPARE,
115     ID_COMP_EQUAL,
116     ID_COMP_GREATERTHAN,
117     ID_COMP_LESSTHAN,
118     ID_COMP_NOT_EQUAL,
119     ID_COMP_U_GREATERTHAN,
120     ID_COMP_U_LESSTHAN,
121     ID_COMP_ZERO_EQUAL,
122     ID_COMP_ZERO_GREATERTHAN,
123     ID_COMP_ZERO_LESSTHAN,
124     ID_COMP_ZERO_NOT_EQUAL,
125     ID_CR,
126     ID_CREATE,
127     ID_CREATE_P,
128     ID_CSTORE,
129     ID_DEFER,
130     ID_DEFER_P,
131     ID_DEPTH,
132     ID_DIVIDE,
133     ID_DOT,
134     ID_DOTS,
135     ID_DO_P,
136     ID_DROP,
137     ID_DUMP,
138     ID_DUP,
139     ID_D_MINUS,
140     ID_D_MTIMES,
141     ID_D_MUSMOD,
142     ID_D_PLUS,
143     ID_D_UMSMOD,
144     ID_D_UMTIMES,
145     ID_EMIT,
146     ID_EMIT_P,
147     ID_EOL,
148     ID_ERRORQ_P,
149     ID_EXECUTE,
150     ID_FETCH,
151     ID_FILE_CLOSE,
152     ID_FILE_CREATE,
153     ID_FILE_OPEN,
154     ID_FILE_POSITION,
155     ID_FILE_READ,
156     ID_FILE_REPOSITION,
157     ID_FILE_RO,
158     ID_FILE_RW,
159     ID_FILE_SIZE,
160     ID_FILE_WRITE,
161     ID_FILL,
162     ID_FIND,
163     ID_FINDNFA,
164     ID_FLUSHEMIT,
165     ID_FREE,
166     ID_HERE,
167     ID_NUMBERQ_P,
168     ID_I,
169     ID_INCLUDE_FILE,
170     ID_J,
171     ID_KEY,
172     ID_LEAVE_P,
173     ID_LITERAL,
174     ID_LITERAL_P,
175     ID_LOADSYS,
176     ID_LOCAL_COMPILER,
177     ID_LOCAL_ENTRY,
178     ID_LOCAL_EXIT,
179     ID_LOCAL_FETCH,
180     ID_LOCAL_FETCH_1,
181     ID_LOCAL_FETCH_2,
182     ID_LOCAL_FETCH_3,
183     ID_LOCAL_FETCH_4,
184     ID_LOCAL_FETCH_5,
185     ID_LOCAL_FETCH_6,
186     ID_LOCAL_FETCH_7,
187     ID_LOCAL_FETCH_8,
188     ID_LOCAL_PLUSSTORE,
189     ID_LOCAL_STORE,
190     ID_LOCAL_STORE_1,
191     ID_LOCAL_STORE_2,
192     ID_LOCAL_STORE_3,
193     ID_LOCAL_STORE_4,
194     ID_LOCAL_STORE_5,
195     ID_LOCAL_STORE_6,
196     ID_LOCAL_STORE_7,
197     ID_LOCAL_STORE_8,
198     ID_LOOP_P,
199     ID_LSHIFT,
200     ID_MAX,
201     ID_MIN,
202     ID_MINUS,
203     ID_NAME_TO_PREVIOUS,
204     ID_NAME_TO_TOKEN,
205     ID_NOOP,
206     ID_NUMBERQ,
207     ID_OR,
208     ID_OVER,
209     ID_PICK,
210     ID_PLUS,
211     ID_PLUSLOOP_P,
212     ID_PLUS_STORE,
213     ID_QDO_P,
214     ID_QDUP,
215     ID_QTERMINAL,
216     ID_QUIT_P,
217     ID_REFILL,
218     ID_RESIZE,
219     ID_RESTORE_INPUT,
220     ID_ROLL,
221     ID_ROT,
222     ID_RP_FETCH,
223     ID_RP_STORE,
224     ID_RSHIFT,
225     ID_R_DROP,
226     ID_R_FETCH,
227     ID_R_FROM,
228     ID_SAVE_FORTH_P,
229     ID_SAVE_INPUT,
230     ID_SCAN,
231     ID_SEMICOLON,
232     ID_SKIP,
233     ID_SOURCE,
234     ID_SOURCE_ID,
235     ID_SOURCE_ID_POP,
236     ID_SOURCE_ID_PUSH,
237     ID_SOURCE_SET,
238     ID_SP_FETCH,
239     ID_SP_STORE,
240     ID_STORE,
241     ID_SWAP,
242     ID_TEST1,
243     ID_TEST2,
244     ID_TEST3,
245     ID_TICK,
246     ID_TIMES,
247     ID_TO_R,
248     ID_TYPE,
249     ID_TYPE_P,
250     ID_VAR_BASE,
251     ID_VAR_CODE_BASE,
252     ID_VAR_CODE_LIMIT,
253     ID_VAR_CONTEXT,
254     ID_VAR_DP,
255     ID_VAR_ECHO,
256     ID_VAR_HEADERS_BASE,
257     ID_VAR_HEADERS_LIMIT,
258     ID_VAR_HEADERS_PTR,
259     ID_VAR_NUM_TIB,
260     ID_VAR_OUT,
261     ID_VAR_RETURN_CODE,
262     ID_VAR_SOURCE_ID,
263     ID_VAR_STATE,
264     ID_VAR_TO_IN,
265     ID_VAR_TRACE_FLAGS,
266     ID_VAR_TRACE_LEVEL,
267     ID_VAR_TRACE_STACK,
268     ID_VLIST,
269     ID_WORD,
270     ID_WORD_FETCH,
271     ID_WORD_STORE,
272     ID_XOR,
273     ID_ZERO_BRANCH,
274     ID_CATCH,
275     ID_THROW,
276     ID_INTERPRET,
277     ID_FILE_WO,
278     ID_FILE_BIN,
279     /* Added to support 64 bit operation. */
280     ID_CELL,
281     ID_CELLS,
282     /* DELETE-FILE */
283     ID_FILE_DELETE,
284 /* If you add a word here, take away one reserved word below. */
285 #ifdef PF_SUPPORT_FP
286 /* Only reserve space if we are adding FP so that we can detect
287 ** unsupported primitives when loading dictionary.
288 */
289     ID_RESERVED01,
290     ID_RESERVED02,
291     ID_RESERVED03,
292     ID_RESERVED04,
293     ID_RESERVED05,
294     ID_RESERVED06,
295     ID_RESERVED07,
296     ID_RESERVED08,
297     ID_RESERVED09,
298     ID_RESERVED10,
299     ID_RESERVED11,
300     ID_RESERVED12,
301     ID_RESERVED13,
302     ID_FP_D_TO_F,
303     ID_FP_FSTORE,
304     ID_FP_FTIMES,
305     ID_FP_FPLUS,
306     ID_FP_FMINUS,
307     ID_FP_FSLASH,
308     ID_FP_F_ZERO_LESS_THAN,
309     ID_FP_F_ZERO_EQUALS,
310     ID_FP_F_LESS_THAN,
311     ID_FP_F_TO_D,
312     ID_FP_FFETCH,
313     ID_FP_FDEPTH,
314     ID_FP_FDROP,
315     ID_FP_FDUP,
316     ID_FP_FLITERAL,
317     ID_FP_FLITERAL_P,
318     ID_FP_FLOAT_PLUS,
319     ID_FP_FLOATS,
320     ID_FP_FLOOR,
321     ID_FP_FMAX,
322     ID_FP_FMIN,
323     ID_FP_FNEGATE,
324     ID_FP_FOVER,
325     ID_FP_FROT,
326     ID_FP_FROUND,
327     ID_FP_FSWAP,
328     ID_FP_FSTAR_STAR,
329     ID_FP_FABS,
330     ID_FP_FACOS,
331     ID_FP_FACOSH,
332     ID_FP_FALOG,
333     ID_FP_FASIN,
334     ID_FP_FASINH,
335     ID_FP_FATAN,
336     ID_FP_FATAN2,
337     ID_FP_FATANH,
338     ID_FP_FCOS,
339     ID_FP_FCOSH,
340     ID_FP_FLN,
341     ID_FP_FLNP1,
342     ID_FP_FLOG,
343     ID_FP_FSIN,
344     ID_FP_FSINCOS,
345     ID_FP_FSINH,
346     ID_FP_FSQRT,
347     ID_FP_FTAN,
348     ID_FP_FTANH,
349     ID_FP_FPICK,
350 #endif
351 /* Add new IDs by replacing reserved IDs or extending FP routines. */
352 /* Do NOT change the order of these IDs or dictionary files will break! */
353     NUM_PRIMITIVES     /* This must always be LAST */
354 };
355
356
357
358 /***************************************************************
359 ** THROW Codes
360 ***************************************************************/
361 /* ANSI standard definitions needed by pForth */
362 #define THROW_ABORT            (-1)
363 #define THROW_ABORT_QUOTE      (-2)
364 #define THROW_STACK_OVERFLOW   (-3)
365 #define THROW_STACK_UNDERFLOW  (-4)
366 #define THROW_UNDEFINED_WORD  (-13)
367 #define THROW_EXECUTING       (-14)
368 #define THROW_PAIRS           (-22)
369 #define THROW_FLOAT_STACK_UNDERFLOW  ( -45)
370 #define THROW_QUIT            (-56)
371
372 /* THROW codes unique to pForth */
373 #define THROW_BYE            (-256) /* Exit program. */
374 #define THROW_SEMICOLON      (-257) /* Error detected at ; */
375 #define THROW_DEFERRED       (-258) /* Not a deferred word. Used in system.fth */
376
377 /***************************************************************
378 ** Structures
379 ***************************************************************/
380
381 typedef struct pfTaskData_s
382 {
383     cell_t   *td_StackPtr;       /* Primary data stack */
384     cell_t   *td_StackBase;
385     cell_t   *td_StackLimit;
386     cell_t   *td_ReturnPtr;      /* Return stack */
387     cell_t   *td_ReturnBase;
388     cell_t   *td_ReturnLimit;
389 #ifdef PF_SUPPORT_FP
390     PF_FLOAT  *td_FloatStackPtr;
391     PF_FLOAT  *td_FloatStackBase;
392     PF_FLOAT  *td_FloatStackLimit;
393 #endif
394     cell_t   *td_InsPtr;          /* Instruction pointer, "PC" */
395     FileStream   *td_InputStream;
396 /* Terminal. */
397     char    td_TIB[TIB_SIZE];   /* Buffer for terminal input. */
398     cell_t    td_IN;              /* Index into Source */
399     cell_t    td_SourceNum;       /* #TIB after REFILL */
400     char   *td_SourcePtr;       /* Pointer to TIB or other source. */
401     cell_t   td_LineNumber;      /* Incremented on every refill. */
402     cell_t    td_OUT;             /* Current output column. */
403 } pfTaskData_t;
404
405 typedef struct pfNode
406 {
407     struct pfNode *n_Next;
408     struct pfNode *n_Prev;
409 } pfNode;
410
411 /* Structure of header entry in dictionary. These will be stored in dictionary specific endian format*/
412 typedef struct cfNameLinks
413 {
414     cell_t       cfnl_PreviousName;   /* name relative address of previous */
415     ExecToken  cfnl_ExecToken;      /* Execution token for word. */
416 /* Followed by variable length name field. */
417 } cfNameLinks;
418
419 #define PF_DICF_ALLOCATED_SEGMENTS  ( 0x0001)
420 typedef struct pfDictionary_s
421 {
422     pfNode  dic_Node;
423     ucell_t  dic_Flags;
424 /* Headers contain pointers to names and dictionary. */
425
426     ucell_t dic_HeaderBaseUnaligned;
427
428     ucell_t dic_HeaderBase;
429     ucell_t dic_HeaderPtr;
430     ucell_t dic_HeaderLimit;
431 /* Code segment contains tokenized code and data. */
432     ucell_t dic_CodeBaseUnaligned;
433     ucell_t dic_CodeBase;
434     union
435     {
436         cell_t  *Cell;
437         uint8_t *Byte;
438     } dic_CodePtr;
439     ucell_t dic_CodeLimit;
440 } pfDictionary_t;
441
442 /* Save state of include when nesting files. */
443 typedef struct IncludeFrame
444 {
445     FileStream   *inf_FileID;
446     cell_t         inf_LineNumber;
447     cell_t         inf_SourceNum;
448     cell_t         inf_IN;
449     char          inf_SaveTIB[TIB_SIZE];
450 } IncludeFrame;
451
452 #define MAX_INCLUDE_DEPTH (16)
453
454 /***************************************************************
455 ** Prototypes
456 ***************************************************************/
457
458 #ifdef __cplusplus
459 extern "C" {
460 #endif
461
462 int pfCatch( ExecToken XT );
463
464 #ifdef __cplusplus
465 }
466 #endif
467
468 /***************************************************************
469 ** External Globals
470 ***************************************************************/
471 extern pfTaskData_t *gCurrentTask;
472 extern pfDictionary_t *gCurrentDictionary;
473 extern char          gScratch[TIB_SIZE];
474 extern cell_t         gNumPrimitives;
475
476 extern ExecToken     gLocalCompiler_XT;      /* CFA of (LOCAL) compiler. */
477 extern ExecToken     gNumberQ_XT;         /* XT of NUMBER? */
478 extern ExecToken     gQuitP_XT;           /* XT of (QUIT) */
479 extern ExecToken     gAcceptP_XT;         /* XT of ACCEPT */
480
481 #define DEPTH_AT_COLON_INVALID (-100)
482 extern cell_t         gDepthAtColon;
483
484 /* Global variables. */
485 extern cell_t        gVarContext;    /* Points to last name field. */
486 extern cell_t        gVarState;      /* 1 if compiling. */
487 extern cell_t        gVarBase;       /* Numeric Base. */
488 extern cell_t        gVarEcho;       /* Echo input from file. */
489 extern cell_t        gVarEchoAccept; /* Echo input from ACCEPT. */
490 extern cell_t        gVarTraceLevel;
491 extern cell_t        gVarTraceStack;
492 extern cell_t        gVarTraceFlags;
493 extern cell_t        gVarQuiet;      /* Suppress unnecessary messages, OK, etc. */
494 extern cell_t        gVarReturnCode; /* Returned to caller of Forth, eg. UNIX shell. */
495
496 extern IncludeFrame  gIncludeStack[MAX_INCLUDE_DEPTH];
497 extern cell_t         gIncludeIndex;
498 /***************************************************************
499 ** Macros
500 ***************************************************************/
501
502
503 /* Endian specific macros for creating target dictionaries for machines with
504
505 ** different endian-ness.
506
507 */
508
509 #if defined(PF_BIG_ENDIAN_DIC)
510
511 #define WRITE_FLOAT_DIC             WriteFloatBigEndian
512 #define WRITE_CELL_DIC(addr,data)   WriteCellBigEndian((uint8_t *)(addr),(ucell_t)(data))
513 #define WRITE_SHORT_DIC(addr,data)  Write16BigEndian((uint8_t *)(addr),(uint16_t)(data))
514 #define READ_FLOAT_DIC              ReadFloatBigEndian
515 #define READ_CELL_DIC(addr)         ReadCellBigEndian((const uint8_t *)(addr))
516 #define READ_SHORT_DIC(addr)        Read16BigEndian((const uint8_t *)(addr))
517
518 #elif defined(PF_LITTLE_ENDIAN_DIC)
519
520 #define WRITE_FLOAT_DIC             WriteFloatLittleEndian
521 #define WRITE_CELL_DIC(addr,data)   WriteCellLittleEndian((uint8_t *)(addr),(ucell_t)(data))
522 #define WRITE_SHORT_DIC(addr,data)  Write16LittleEndian((uint8_t *)(addr),(uint16_t)(data))
523 #define READ_FLOAT_DIC              ReadFloatLittleEndian
524 #define READ_CELL_DIC(addr)         ReadCellLittleEndian((const uint8_t *)(addr))
525 #define READ_SHORT_DIC(addr)        Read16LittleEndian((const uint8_t *)(addr))
526
527 #else
528
529 #define WRITE_FLOAT_DIC(addr,data)  { *((PF_FLOAT *)(addr)) = (PF_FLOAT)(data); }
530 #define WRITE_CELL_DIC(addr,data)   { *((cell_t *)(addr)) = (cell_t)(data); }
531 #define WRITE_SHORT_DIC(addr,data)  { *((int16_t *)(addr)) = (int16_t)(data); }
532 #define READ_FLOAT_DIC(addr)        ( *((PF_FLOAT *)(addr)) )
533 #define READ_CELL_DIC(addr)         ( *((const ucell_t *)(addr)) )
534 #define READ_SHORT_DIC(addr)        ( *((const uint16_t *)(addr)) )
535
536 #endif
537
538
539 #define HEADER_HERE (gCurrentDictionary->dic_HeaderPtr.Cell)
540 #define CODE_HERE (gCurrentDictionary->dic_CodePtr.Cell)
541 #define CODE_COMMA( N ) WRITE_CELL_DIC(CODE_HERE++,(N))
542 #define NAME_BASE (gCurrentDictionary->dic_HeaderBase)
543 #define CODE_BASE (gCurrentDictionary->dic_CodeBase)
544 #define NAME_SIZE (gCurrentDictionary->dic_HeaderLimit - gCurrentDictionary->dic_HeaderBase)
545 #define CODE_SIZE (gCurrentDictionary->dic_CodeLimit - gCurrentDictionary->dic_CodeBase)
546
547 #define IN_CODE_DIC(addr) ( ( ((uint8_t *)(addr)) >= gCurrentDictionary->dic_CodeBase)   && ( ((uint8_t *)(addr)) < gCurrentDictionary->dic_CodeLimit) )
548
549 #define IN_NAME_DIC(addr) ( ( ((uint8_t *)(addr)) >= gCurrentDictionary->dic_HeaderBase) && ( ((uint8_t *)(addr)) < gCurrentDictionary->dic_HeaderLimit) )
550 #define IN_DICS(addr) (IN_CODE_DIC(addr) || IN_NAME_DIC(addr))
551
552 /* Address conversion */
553 #define ABS_TO_NAMEREL( a ) ((cell_t)  (((ucell_t) a) - NAME_BASE ))
554 #define ABS_TO_CODEREL( a ) ((cell_t)  (((ucell_t) a) - CODE_BASE ))
555 #define NAMEREL_TO_ABS( a ) ((ucell_t) (((cell_t) a) + NAME_BASE))
556 #define CODEREL_TO_ABS( a ) ((ucell_t) (((cell_t) a) + CODE_BASE))
557
558 /* The check for >0 is only needed for CLONE testing. !!! */
559 #define IsTokenPrimitive(xt) ((xt<gNumPrimitives) && (xt>=0))
560
561 #define FREE_VAR(v) { if (v) { pfFreeMem((void *)(v)); v = 0; } }
562
563 #define DATA_STACK_DEPTH (gCurrentTask->td_StackBase - gCurrentTask->td_StackPtr)
564 #define DROP_DATA_STACK (gCurrentTask->td_StackPtr++)
565 #define POP_DATA_STACK (*gCurrentTask->td_StackPtr++)
566 #define PUSH_DATA_STACK(x) {*(--(gCurrentTask->td_StackPtr)) = (cell_t) x; }
567
568 /* Force Quad alignment. */
569 #define QUADUP(x) (((x)+3)&~3)
570
571 #define MIN(a,b)  ( ((a)<(b)) ? (a) : (b) )
572 #define MAX(a,b)  ( ((a)>(b)) ? (a) : (b) )
573
574
575 #ifndef TOUCH
576     #define TOUCH(argument) ((void)argument)
577 #endif
578
579 /***************************************************************
580 ** I/O related macros
581 ***************************************************************/
582
583 #define EMIT(c)  ioEmit(c)
584 #define EMIT_CR  EMIT('\n');
585
586 #define MSG(cs)   pfMessage(cs)
587 #define ERR(x)    MSG(x)
588
589 #define DBUG(x)  /* PRT(x) */
590 #define DBUGX(x) /* DBUG(x) */
591
592 #define MSG_NUM_D(msg,num) { MSG(msg); ffDot((cell_t) num); EMIT_CR; }
593 #define MSG_NUM_H(msg,num) { MSG(msg); ffDotHex((cell_t) num); EMIT_CR; }
594
595 #define DBUG_NUM_D(msg,num) { pfDebugMessage(msg); pfDebugPrintDecimalNumber((cell_t) num); pfDebugMessage("\n"); }
596
597 #endif  /* _pf_guts_h */