sizeof(CELL) was greater than sizeof(CELL*). 2007-01-13
2007-05-28
THROW handling into new member function ForthVM::UncaughtException. This improves the code generated by GCC.
Classes | |
| class | WordHeader |
| Representation of a forth word's header in the dictionary. More... | |
| struct | Wordlist |
| Representaion of a forth wordlist. More... | |
| class | ForthVM |
| Implementation of the forth virtual machine. More... | |
Defines | |
| #define | LITTLE_ENDIAN |
| #define | CELLS(x) ((CELL)(((CELL*)256)+(x))-(CELL)((CELL*)256)) |
| #define | CHARS(x) ((CELL)(((CHAR*)256)+(x))-(CELL)((CHAR*)256)) |
| #define | SLASH_CELL(x) ((CELL*)(256+(x))-((CELL*)256)) |
| #define | SLASH_CHAR(x) ((CHAR*)(256+(x))-((CHAR*)256)) |
| #define | ALIGNED(x) (((x)+CELLS(1)-1)&~(CELLS(1)-1)) |
| #define | XT_BRANCH(offset) XT_PAREN_BRANCH,CELLS(offset) |
| #define | XT_0BRANCH(offset) XT_PAREN_0BRANCH,CELLS(offset) |
| #define | LIT(x) XT_PAREN_LITERAL,(CELL)x |
| #define | XT_M_SLASH_MOD (((-1)/2) ? (CELL)XT_FM_SLASH_MOD : (CELL)XT_SM_SLASH_REM) |
| #define | IMMEDIATE 0x8000 |
| #define | TOKEN 0x4000 |
| #define | LINK(n) CELLS(((n)+!!((n)&TOKEN))&~(IMMEDIATE|TOKEN)) |
| #define | FLAGS(f) ((((f)&IMMEDIATE)?(UCELL)WordHeader::Immediate:0)|(((f)&TOKEN)?(UCELL)WordHeader::Token:0)|(UCELL)WordHeader::Valid) |
| #define | PREPEND_CHAR(x, c) ((((CELL)x)<<BITS_PER_CHAR)+((CELL)c)) |
| #define | C4(a, b, c, d) ((CELL)PREPEND_CHAR(PREPEND_CHAR(PREPEND_CHAR(d,c),b),a)) |
| #define | C8(a, b, c, d, e, f, g, h) ((C4(e,f,g,h)<<(BITS_PER_CHAR*4))+C4(a,b,c,d)) |
| #define | H1(a, args) LINK(2+(args)),C4(FLAGS(args)+1,a,0,0) |
| #define | H2(a, b, args) LINK(2+(args)),C4(FLAGS(args)+2,a,b,0) |
| #define | H3(a, b, c, args) LINK(2+(args)),C4(FLAGS(args)+3,a,b,c) |
| #define | H4(a, b, c, d, args) LINK(3+(args)),C4(FLAGS(args)+4,a,b,c),C4(d,0,0,0) |
| #define | H5(a, b, c, d, e, args) LINK(3+(args)),C4(FLAGS(args)+5,a,b,c),C4(d,e,0,0) |
| #define | H6(a, b, c, d, e, f, args) LINK(3+(args)),C4(FLAGS(args)+6,a,b,c),C4(d,e,f,0) |
| #define | H7(a, b, c, d, e, f, g, args) LINK(3+(args)),C4(FLAGS(args)+7,a,b,c),C4(d,e,f,g) |
| #define | H8(a, b, c, d, e, f, g, h, args) LINK(4+(args)),C4(FLAGS(args)+8,a,b,c),C4(d,e,f,g),C4(h,0,0,0) |
| #define | H9(a, b, c, d, e, f, g, h, i, args) LINK(4+(args)),C4(FLAGS(args)+9,a,b,c),C4(d,e,f,g),C4(h,i,0,0) |
| #define | H10(a, b, c, d, e, f, g, h, i, j, args) LINK(4+(args)),C4(FLAGS(args)+10,a,b,c),C4(d,e,f,g),C4(h,i,j,0) |
| #define | H11(a, b, c, d, e, f, g, h, i, j, k, args) LINK(4+(args)),C4(FLAGS(args)+11,a,b,c),C4(d,e,f,g),C4(h,i,j,k) |
| #define | H12(a, b, c, d, e, f, g, h, i, j, k, l, args) LINK(5+(args)),C4(FLAGS(args)+12,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,0,0,0) |
| #define | H13(a, b, c, d, e, f, g, h, i, j, k, l, m, args) LINK(5+(args)),C4(FLAGS(args)+13,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,0,0) |
| #define | H14(a, b, c, d, e, f, g, h, i, j, k, l, m, n, args) LINK(5+(args)),C4(FLAGS(args)+14,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,n,0) |
| #define | H15(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, args) LINK(5+(args)),C4(FLAGS(args)+15,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,n,o) |
| #define | H16(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, args) LINK(6+(args)),C4(FLAGS(args)+16,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,n,o),C4(p,0,0,0) |
| #define | H17(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, args) LINK(6+(args)),C4(FLAGS(args)+17,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,n,o),C4(p,q,0,0) |
| #define | H18(a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, args) LINK(6+(args)),C4(FLAGS(args)+18,a,b,c),C4(d,e,f,g),C4(h,i,j,k),C4(l,m,n,o),C4(p,q,r,0) |
| #define | NEXT goto next |
| #define | BRANCH ip = (CELL*)((CELL)ip+(CELL)ip[0]); NEXT |
| #define | THROW(a) { t=a; goto exception; } |
| #define | CALL(a) { xt=(CELL)(a); goto call; } |
| #define | PUSH(a) { *--sp=(CELL)(a); } |
| #define | POP(a) { (a)=*sp++; } |
| #define | RPUSH(a) { *--rp=(CELL)(a); } |
| #define | RPOP(cast, a) { (a)=(cast)*rp++; } |
Enumerations | |
| enum | Exception |
| enum | ControlStackMarkers { ColonMagic = 12340, OrigMagic = 12341, DestMagic = 12342 } |
| enum | ForthXT { XT_STORE, XT_NUMBER_SIGN, XT_NUMBER_SIGN_GREATER, XT_STAR, XT_PLUS, XT_PLUS_STORE, XT_PAREN_PLUS_LOOP, XT_COMMA, XT_MINUS, XT_0_LESS, XT_0_EQUALS, XT_1_PLUS, XT_1_MINUS, XT_2_STORE, XT_2_STAR, XT_2_SLASH, XT_2_FETCH, XT_2DROP, XT_2DUP, XT_2OVER, XT_2SWAP, XT_LESS_THAN, XT_LESS_NUMBER_SIGN, XT_EQUALS, XT_GREATER_THAN, XT_TO_IN, XT_TO_NUMBER, XT_TO_R, XT_QUESTION_DUP, XT_FETCH, XT_ABS, XT_ACCEPT, XT_ALIGN, XT_ALIGNED, XT_ALLOT, XT_AND, XT_BASE, XT_C_STORE, XT_C_COMMA, XT_C_FETCH, XT_CELL_PLUS, XT_CELLS, XT_CHAR_PLUS, XT_CHARS, XT_PAREN_CONSTANT, XT_COUNT, XT_DEPTH, XT_PAREN_DO, XT_DROP, XT_DUP, XT_PAREN_BRANCH, XT_EMIT, XT_EXECUTE, XT_EXIT, XT_FILL, XT_HERE, XT_HOLD, XT_I, XT_PAREN_0BRANCH, XT_INVERT, XT_J, XT_KEY, XT_LEAVE, XT_PAREN_LITERAL, XT_PAREN_LOOP, XT_LSHIFT, XT_MAX, XT_MIN, XT_MOVE, XT_NEGATE, XT_OR, XT_OVER, XT_R_FROM, XT_R_FETCH, XT_ROT, XT_RSHIFT, XT_S_TO_D, XT_SIGN, XT_SPACE, XT_STATE, XT_SWAP, XT_TYPE, XT_U_LESS_THAN, XT_UM_STAR, XT_UNLOOP, XT_XOR, XT_LEFT_BRACKET, XT_RIGHT_BRACKET, XT_0_NOT_EQUALS, XT_0_GREATER, XT_2_TO_R, XT_2_R_FROM, XT_2_R_FETCH, XT_NOT_EQUALS, XT_PAREN_QUESTION_DO, XT_ERASE, XT_FALSE, XT_NIP, XT_PAD, XT_PARSE, XT_PICK, XT_ROLL, XT_TRUE, XT_TUCK, XT_U_GREATER_THAN, XT_UNUSED, XT_D_PLUS, XT_DABS, XT_DNEGATE, XT_M_PLUS, XT_CATCH, XT_THROW, XT_CMOVE, XT_CMOVE_UP } |
Functions | |
| bool | MatchChars (CELL a, CELL b) |
| bool | ForthVM::DoReset () |
| CELL | ForthVM::DoExecute (CELL xt) |
| CELL | ForthVM::DoQuit () |
| CELL | ForthVM::DoEvaluate (const CHAR *text, unsigned textLength) |
| const CELL * | ForthVM::DoPop (unsigned numCells) |
| void | ForthVM::DoPush (const CELL *cells, unsigned numCells) |
| CELL | ForthVM::Run (const CELL *ip) |
| CELL | ForthVM::UncaughtException (CELL exceptionNumber) |
| static void | ForthVM::MultiplyPrimitive (CELL *sp) |
| static void | ForthVM::DividePrimitive (CELL *sp) |
| static void | ForthVM::ToNumber (CELL *sp, UCELL base) |
| void | ForthVM::ParsePrimitive (CELL *sp, CELL delimiter) |
| CELL | ForthVM::FindPrimitive (CELL *sp, CELL wordlist) |
| CELL | ForthVM::Accept (CHAR *buffer, CELL maxLen) |
Variables | |
| static const CELL | BitsPerCell = BITS_PER_CHAR*CHARS_PER_CELL |
| static const CELL | CellLoMask = ((CELL)1<<(BitsPerCell/2))-1 |
| static const CELL | SlashCountedString = 255 |
| static const CELL | NameLengthMask = 31 |
| static const CELL | NumberTIB = 80 |
| static const CELL | SlashPad = 84 |
| static const CELL | DictionaryOverhead = CHARS(SlashCountedString+2+SlashPad) |
| static const CELL | MaxWordlists = 16 |
| static const CELL | StackCells = 256 |
| static const CELL | ReturnStackCells = 256 |
| static const CELL | XT_NEST_CHECK [] |
| static const CELL | XT_FORWARD_BRANCH_COMMA [] |
| static const CELL | XT_BACKWARD_BRANCH_COMMA [] |
| static const CELL | XT_IF [] |
| static const CELL | XT_AHEAD [] |
| static const CELL | XT_THEN [] |
| static const CELL | XT_BEGIN [] |
| static const CELL | XT_AGAIN [] |
| static const CELL | XT_UM_SLASH_MOD [] |
| static const CELL | XT_CHECK_NEG [] |
| static const CELL | XT_CHECK_POS [] |
| static const CELL | XT_SM_SLASH_REM [] |
| static const CELL | XT_FM_SLASH_MOD [] |
| static const CELL | XT_SLASH_MOD [] |
| static const CELL | XT_M_STAR [] |
| static const CELL | XT_STAR_SLASH_MOD [] |
| static const CELL | XT_NUMBER_SIGN_S [] |
| static const CELL | XT_D_DOT [] |
| static const CELL | XT_DOT [] |
| static const CELL | XT_CR [] |
| static const CELL | XT_CREATE_WORD [] |
| static const CELL | XT_VALIDATE [] |
| static const CELL | XT_PAREN_CREATE [] |
| static const CELL | XT_CREATE [] |
| static const CELL | XT_PAREN_DOES [] |
| static const CELL | XT_LITERAL [] |
| static const CELL | XT_PAREN_S_QUOTE [] |
| static const CELL | XT_S_QUOTE [] |
| static const CELL | XT_CHAR [] |
| static const CELL | XT_PAREN_FIND [] |
| static const CELL | XT_THROW_QUOTE [] |
| static const CELL | XT_PAREN_TICK [] |
| static const CELL | XT_TICK [] |
| static const CELL | XT_TO_SIGN [] |
| static const CELL | XT_NUMBER_QUERY [] |
| static const CELL | XT_INTERPRET_WORD [] |
| static const CELL | XT_COMPILE_WORD [] |
| static const CELL | XT_INTERPRET [] |
| static const CELL | XT_EVALUATE [] |
| static const CELL | XT_REFILL_TIB [] |
| static const CELL | XT_REFILL [] |
| static const CELL | XT_DO_QUIT [] |
| static const CHAR | AbortText [] = {'A','B','O','R','T'} |
| static const CHAR | ExceptionText [] = {'E','x','c','e','p','t','i','o','n'} |
| const CELL | XT_EXCEPTION_DOT [] |
| const CELL | XT_QUIT [] |
| static const CELL | ForthDictionary [] |
| static const CELL | EnvironmentDictionary [] |
|
|
Define this when compiling for a little endian target |
|
|
Size of x cells in address untits.
|
|
|
Size of x chars in address untits.
|
|
|
Number of cells in x address units.
|
|
|
Number of chars in x address units.
|
|
|
Next aligned cell address equal or higher than address x.
|
|
|
Macro for an unconditional branch. I.e. the execution sematics of
|
|
|
Macro for an conditional branch. I.e. the execution sematics of
|
|
|
Macro for construction the execution semantics of
|
|
|
Definition of non standard forth word.
: M/MOD ( d1 n1 -- n2 n3 )
\ If the system uses floored division, execute FM/MOD
\ otherwise execute SM/MOD
;
|
|
|
Exception values define by the ANS standard |
|
|
Values placed on the control stack to indicate the type of control flow nesting value. |
|
|
|
Implementation of Forth::Reset |
|
|
Implementation of Forth::Execute |
|
|
Implementation of Forth::Quit |
|
||||||||||||
|
Implementation of Forth::Evaluate |
|
|
Implementation of Forth::Pop |
|
||||||||||||
|
Implementation of Forth::Push |
|
|
Execute forth code.
|
|
|
Called if there is not a
|
|
|
Number of bits in a cell. |
|
|
The mask value for the bits in the least significant half of a cell. I.e. |
|
|
Maximum length of a counted string. |
|
|
Value to AND with the length of a words name length in order to remove any flag bits. This also represents the maximum length a word's name may have.
|
|
|
Size of the Terminal Input Buffer. |
|
|
Size of the |
|
|
The size of memory after |
|
|
Maximum number of wordlists in the search order. |
|
|
Size of parameter stack in cells. |
|
|
Size of return stack in cells. |
|
|
Definition of non standard forth word. : NEST-CHECK ( C: x1 -- ) ( x2 -- ) \ Check control structure nesting value x1 equals x2. = IF EXIT THEN -22 THROW ; |
|
|
Definition of non standard forth word.
: >BRANCH, ( C: -- orig ) ( xt -- ) \ Compile a forwards branch of type specified by xt.
, HERE 0 , OrigMagic
;
|
|
|
Definition of non standard forth word.
: <BRANCH, ( C: dest -- ) ( xt -- ) \ Compile a backwards branch of type specified by xt.
, DestMagic NEST-CHECK HERE - ,
;
|
|
|
Definition of ANS forth word.
: IF ( C: -- orig )
['] (0branch) >BRANCH,
; IMMEDIATE
|
|
|
Definition of ANS forth word.
: AHEAD ( C: -- orig )
['] (branch) >BRANCH,
; IMMEDIATE
|
|
|
Definition of ANS forth word.
: THEN ( C: orig -- )
OrigMagic NEST-CHECK
HERE OVER - SWAP !
; IMMEDIATE
|
|
|
Definition of ANS forth word.
: BEGIN ( C: -- dest )
HERE DestMagic
; IMMEDIATE
|
|
|
Definition of ANS forth word.
: AGAIN ( C: dest -- )
['] (branch) <BRANCH,
; IMMEDIATE
|
|
|
Definition of ANS forth word.
: UM/MOD ( ud u1 -- u2 u3 )
DUP 0= IF -10 THROW THEN
UDM/MOD
IF -11 THROW THEN
;
|
|
|
Definition of non standard forth word.
: CHECK-NEG ( n -- n )
\ If n is greater than zero, throw -11 (result out of range)
DUP 0> IF -11 THROW THEN
;
|
|
|
Definition of non standard forth word.
: CHECK-POS ( n -- n )
\ If n is less than zero, throw -11 (result out of range)
DUP 0< IF -11 THROW THEN
;
|
|
|
Definition of ANS forth word.
: SM/REM ( d1 n1 -- n2 n3 )
OVER >R 2DUP XOR >R
ABS >R DABS R>
UM/MOD
R> 0<
IF NEGATE CHECK-NEG
ELSE CHECK-POS
THEN
SWAP R> 0< IF NEGATE THEN
SWAP
;
|
|
|
Definition of ANS forth word.
: FM/MOD ( d1 n1 -- n2 n3 )
DUP >R 2DUP XOR >R
ABS >R DABS R>
UM/MOD
R> 0<
IF NEGATE CHECK-NEG OVER
IF 1- CHECK-NEG R@ ABS ROT - SWAP
THEN
ELSE CHECK-POS
THEN
SWAP R> 0< IF NEGATE THEN SWAP
;
|
|
|
Definition of ANS forth word.
: /MOD ( n1 n2 -- n3 n4 )
>R S>D R> M/MOD
;
|
|
|
Definition of ANS forth word.
: M* ( n1 n2 -- d )
2DUP XOR >R ABS SWAP ABS
UM* R> 0< IF DNEGATE THEN
;
|
|
|
Definition of ANS forth word.
: * /MOD ( n1 n2 n3 -- n4 n5 )
>R M* R> M/MOD
;
|
|
|
Definition of ANS forth word.
: #S ( ud1 -- ud2 )
BEGIN # 2DUP OR 0= UNTIL
;
|
|
|
Definition of ANS forth word.
: D. ( d -- )
<# BL HOLD
DUP >R DABS #S R> SIGN
#> TYPE
;
|
|
|
Definition of ANS forth word.
: . ( n -- )
S>D D.
;
|
|
|
Definition of ANS forth word.
: CR ( -- )
(cr) TYPE
;
|
|
|
Definition of non standard forth word. : CREATE-WORD ( c-addr u -- )
\ Create a dictionary entry for a word named by the string c-addr u.
\ This entry cannot be found until VALIDATE is called.
OVER 0<> OVER 0> INVERT AND IF -16 THROW THEN \ check address and length are valid
NameLengthMask MIN \ truncate name to maximum
ALIGN HERE >R \ get location to store word's header
CURRENT @ \ get current wordlist
DUP @ R@ - , \ write link field
R@ SWAP ! \ update current wordlist
DUP C, \ write name length
BEGIN DUP \ write each character in name...
WHILE OVER C@ C, SWAP CHAR+ SWAP 1-
REPEAT
2DROP ALIGN \ tidy up
R> LATEST ! \ update LATEST to point to new word
;
|
|
|
Definition of non standard forth word.
: VALIDATE ( -- ) \ Mark latest word as valid (findable).
WordValid
LATEST @ >FLAGS
TUCK C@ OR SWAP C!
;
|
|
|
Definition of runtime semantics for words defined with ANS forth word
: (create) ( -- a-addr )
R>
;
|
|
|
Definition of ANS forth word.
: CREATE ( "<spaces>name" -- )
PARSE-WORD CREATE-WORD POSTPONE (create) VALIDATE
;
|
|
|
Definition of runtime semantics for ANS forth word
: (does>) ( -- ) ( R: nest-sys1 -- )
R> LATEST @ >CFA !
;
|
|
|
Definition of ANS forth word.
: LITERAL ( x -- )
['] (literal) , ,
;
|
|
|
Definition of runtime semantics for ANS forth word
: (s") ( -- c-addr u )
R@ CELL+ R> @
2DUP CHARS + ALIGNED >R
;
|
|
|
Definition of ANS forth word.
: S" ( "ccc<quote>" -- )
[CHAR] " PARSE
POSTPONE (s")
DUP ,
HERE SWAP DUP CHARS ALLOT ALIGN CMOVE
;
|
|
|
Definition of ANS forth word.
: CHAR ( "<spaces>name" -- char )
PARSE-WORD IF C@ EXIT THEN DROP FALSE
;
|
|
|
Definition of non standard forth word. : (find) ( c-addr u -- xt flag header | c-addr u 0 )
\ Find the defination named by the string c-addr u.
\ If the definition is not found return c-addr u and zero.
\ If the definition is found, return its execution token xt,
\ a flag which is true if the word is immediate, and it's header address.
CONTEXT @ 0 \ loop through number of wordlists in CONTEXT
DO
CONTEXT I 1+ CELLS + \ get pointer to next wordlist
@ (search-wordlist) \ search this wordlist
?DUP IF UNLOOP EXIT THEN \ exit if found
LOOP
FALSE \ return FALSE for words not found
;
|
|
|
Definition of non standard forth word.
: THROW" ( c-addr u x -- ) \ Throw execption x with message string c-addr u
>R EXCEPTION-MESSAGE 2! R> THROW
;
|
|
|
Definition of non standard forth word.
: (') ( "<spaces>name" -- xt immediate-flag ) \ Implementation factor for ' (tick).
PARSE-WORD (find) IF EXIT THEN -13 THROW
;
|
|
|
Definition of ANS forth word.
: ' ( "<spaces>name" -- xt )
(') DROP
;
|
|
|
Definition of non standard forth word. : >SIGN ( c-addr1 u1 -- c-addr2 u2 true | c-addr1 u1 false )
\ If the string specified by c-addr1 u1 begings with a minus sign \ then adjust string to remove it and return true, \ else return then original string and false.
DUP 0= IF FALSE EXIT THEN OVER C@ [CHAR] - = IF SWAP CHAR+ SWAP 1- TRUE EXIT THEN FALSE ; |
|
|
Definition of non standard forth word. : NUMBER? ( c-addr1 u1 -- d 2 | n 1 | 0 )
\ Convert the string specified by c-addr1 u1 into a number.
\ Return d and 2 if the number is a double number,
\ return n and 1 if the number is a single number;
\ otherwise return zero.
>SIGN >R \ check for leading minus sign
0 0 2SWAP >NUMBER 2SWAP \ convert string to a number
R> IF DNEGATE THEN \ apply sign to number
2SWAP DUP 0= \ all of string converted?
IF 2DROP DROP 1 EXIT THEN \ return a single cell number
1 = SWAP C@ [CHAR] . = AND \ remainder of string is a single decimal point?
IF 2 EXIT THEN \ return a double cell number
2DROP 0 \ not a number, so return 0
;
|
|
|
Definition of non standard forth word. : INTERPRET-WORD ( c-addr u -- i*x | d | n )
\ Find the defination named by the string c-addr u.
\ If the definition is found, perform it's execution semantics,
\ i*x represents the results of this.
\ If the definition is not found, convert c-addr u into a number.
\ If the number is valid double number, leave its value d on the stack.
\ If the number is valid single number, leave its value n on the stack.
\ If the number isn't valid, throw exception -13.
(find) \ search dictionary for the word
IF DROP EXECUTE EXIT THEN \ if found, execute it and end
2DUP 2>R \ save string
NUMBER? \ convert string into a number
IF \ if it is a valid number
R> DROP R> DROP \ discard saved string
EXIT \ leave number's value on stack and end
THEN
2R> -13 THROW \ throw -13 (with string on top of stack)
;
|
|
|
Definition of non standard forth word. : COMPILE-WORD ( c-addr u -- i*x | )
\ Find the defination named by the string c-addr u.
\ If the definition is found, then if the word is immediate perform it's
\ execution semantics, i*x represents the results of this. If the word
\ isn't immediate, append it's execution semantics to the current definition.
\ If the definition is not found, convert c-addr u into a number.
\ If the number is valid single or double number, append code to the current
\ definition which when executed will leave the number's value on the stack.
\ If the number isn't valid, throw exception -13.
(find) \ search dictionary for the word
IF \ if found
IF \ and it's immediate,
EXECUTE EXIT \ then execute it and end
THEN \ else
, EXIT \ compile it and end
THEN
2DUP 2>R \ save string
NUMBER? DUP \ convert string into a number
IF \ if it is a valid number
R> DROP R> DROP \ discard saved string
1- IF SWAP POSTPONE LITERAL THEN \ compile number as a literal...
POSTPONE LITERAL EXIT
THEN
2R> -13 THROW \ throw -13 (with string on top of stack)
;
|
|
|
Definition of non standard forth word.
: INTERPRET ( -- i*x) \ Interpret the current input, i*x is the result of this
BEGIN
PARSE-WORD DUP \ get a word from the input
WHILE \ while there is a word
STATE @ \ if in compile state
IF COMPILE-WORD \ compile the word
ELSE INTERPRET-WORD \ else interpret the word
THEN
REPEAT \ get next word
2DROP \ discard empty word and end
;
|
|
|
Definition of ANS forth word.
: EVALUATE ( i*x c-addr u -- j*x )
(source) 2@ 2>R >IN 2@ 2>R
(source) 2! -1 0 >IN 2!
' INTERPRET CATCH
2R> >IN 2! 2R> (source) 2!
THROW
;
|
|
|
Definition of non standard forth word. : REFILL-TIB ( -- true )
\ Refill the terminal input buffer (TIB)
\ and make it the current input source.
TIB DUP /TIB ACCEPT SPACE \ get input from terminal
(source) 2! \ make SOURCE point to TIB
0 >IN ! TRUE \ set >IN to zero
;
|
|
|
Definition of ANS forth word. : REFILL ( -- flag )
\ Attempt to fill the input buffer from the input source,
\ returning a true flag if successful.
>IN CELL+ @ 0= \ if input source is 0
IF REFILL-TIB EXIT THEN \ get input from terminal and return true
FALSE \ otherwise, return false
;
|
|
|
Definition of non standard forth word.
: DO-QUIT ( -- ) ( R: i*x -- )
EMPTYR
0 >IN CELL+ ! \ set SOURCE-ID to 0
POSTPONE [
BEGIN
REFILL
WHILE
INTERPRET
STATE @ 0= IF ." OK" THEN
CR
REPEAT
;
|
|
|
Definition of ANS forth word.
: EXCEPTION. ( n -- n )
DUP -1 =
IF ." ABORT" EXIT THEN // Print 'ABORT', and end
DUP -2 =
IF EXCEPTION-STRING 2@ TYPE EXIT THEN // Print exception message, and end
DUP -13 =
IF
EXCEPTION-STRING 2@ TYPE // Print word name
SPACE [CHAR] ? EMIT EXIT // followed by " ?", then end
THEN
." Exception" DUP . // Print "Exception n", then end
;
|
|
|
Definition of ANS forth word. : QUIT ( i*x n -- ) BEGIN EMPTYR ['] DO-QUIT CATCH EXCEPTION. CR AGAIN ; |
|
|
Initial contents for FORTH dictionary |
|
|
Initial contents for ENVIRONMENT dictionary |
1.4.4