173 lines
6.5 KiB
Forth
173 lines
6.5 KiB
Forth
CREATE BUF 0 , \ single-character look-ahead buffer
|
|
: PEEK BUF @ 0= IF KEY BUF ! THEN BUF @ ;
|
|
: GETC PEEK 0 BUF ! ;
|
|
: SPACE? DUP BL = SWAP 9 14 WITHIN OR ;
|
|
: >SPACE BEGIN PEEK SPACE? WHILE GETC DROP REPEAT ;
|
|
: DIGIT? 48 58 WITHIN ;
|
|
: GETINT >SPACE 0
|
|
BEGIN PEEK DIGIT?
|
|
WHILE GETC [CHAR] 0 - SWAP 10 * +
|
|
REPEAT ;
|
|
: GETNAM >SPACE PAD 1+
|
|
BEGIN PEEK SPACE? INVERT
|
|
WHILE GETC OVER C! CHAR+
|
|
REPEAT PAD TUCK - 1- PAD C! ;
|
|
: GETSTR >SPACE PAD 1+ GETC DROP \ skip leading "
|
|
BEGIN GETC DUP [CHAR] " <>
|
|
WHILE OVER C! CHAR+
|
|
REPEAT DROP PAD TUCK - 1- PAD C! ;
|
|
: INTERN HERE SWAP DUP C@ 1+ BOUNDS DO I C@ C, LOOP ALIGN ;
|
|
|
|
CREATE #TK 0 ,
|
|
: TK: CREATE #TK @ , 1 #TK +! DOES> @ ;
|
|
TK: End_of_input TK: Keyword_if TK: Keyword_else
|
|
TK: Keyword_while TK: Keyword_print TK: Keyword_putc
|
|
TK: String TK: Integer TK: Identifier
|
|
TK: LeftParen TK: RightParen
|
|
TK: LeftBrace TK: RightBrace
|
|
TK: Semicolon TK: Comma
|
|
TK: Op_assign TK: Op_not
|
|
: (BINARY?) [ #TK @ ] literal >= ;
|
|
TK: Op_subtract TK: Op_add
|
|
TK: Op_mod TK: Op_multiply TK: Op_divide
|
|
TK: Op_equal TK: Op_notequal
|
|
TK: Op_less TK: Op_lessequal
|
|
TK: Op_greater TK: Op_greaterequal
|
|
TK: Op_and TK: Op_or
|
|
CREATE TOKEN 0 , 0 , 0 , 0 ,
|
|
: TOKEN-TYPE TOKEN 2 CELLS + @ ;
|
|
: TOKEN-VALUE TOKEN 3 CELLS + @ ;
|
|
: GETTOK GETINT GETINT TOKEN 2!
|
|
GETNAM FIND DROP EXECUTE
|
|
DUP Integer = IF GETINT ELSE
|
|
DUP String = IF GETSTR INTERN ELSE
|
|
DUP Identifier = IF GETNAM INTERN ELSE
|
|
0 THEN THEN THEN
|
|
TOKEN 3 CELLS + ! TOKEN 2 CELLS + ! ;
|
|
: BINARY? TOKEN-TYPE (BINARY?) ;
|
|
|
|
CREATE PREC #TK @ CELLS ALLOT PREC #TK @ CELLS -1 FILL
|
|
: PREC! CELLS PREC + ! ;
|
|
14 Op_not PREC! 13 Op_multiply PREC!
|
|
13 Op_divide PREC! 13 Op_mod PREC!
|
|
12 Op_add PREC! 12 Op_subtract PREC!
|
|
10 Op_less PREC! 10 Op_greater PREC!
|
|
10 Op_lessequal PREC! 10 Op_greaterequal PREC!
|
|
9 Op_equal PREC! 9 Op_notequal PREC!
|
|
5 Op_and PREC! 4 Op_or PREC!
|
|
: PREC@ CELLS PREC + @ ;
|
|
|
|
\ Each AST Node is a sequence of cells in data space consisting
|
|
\ of the execution token of a printing word, followed by that
|
|
\ node's data. Each printing word receives the address of the
|
|
\ node's data, and is responsible for printing that data
|
|
\ appropriately.
|
|
|
|
DEFER .NODE
|
|
: .NULL DROP ." ;" CR ;
|
|
CREATE $NULL ' .NULL ,
|
|
: .IDENTIFIER ." Identifier " @ COUNT TYPE CR ;
|
|
: $IDENTIFIER ( a-addr --) HERE SWAP ['] .IDENTIFIER , , ;
|
|
: .INTEGER ." Integer " @ . CR ;
|
|
: $INTEGER ( n --) HERE SWAP ['] .INTEGER , , ;
|
|
: "TYPE" [CHAR] " EMIT TYPE [CHAR] " EMIT ;
|
|
: .STRING ." String " @ COUNT "TYPE" CR ;
|
|
: $STRING ( a-addr --) HERE SWAP ['] .STRING , , ;
|
|
: .LEAF DUP @ COUNT TYPE CR CELL+ @ .NODE 0 .NULL ;
|
|
: LEAF CREATE HERE CELL+ , BL WORD INTERN .
|
|
DOES> HERE >R ['] .LEAF , @ , , R> ;
|
|
LEAF $PRTC Prtc LEAF $PRTS Prts LEAF $PRTI Prti
|
|
LEAF $NOT Not LEAF $NEGATE Negate
|
|
: .BINARY DUP @ COUNT TYPE CR
|
|
CELL+ DUP @ .NODE CELL+ @ .NODE ;
|
|
: BINARY CREATE HERE CELL+ , BL WORD INTERN .
|
|
DOES> HERE >R ['] .BINARY , @ , SWAP 2, R> ;
|
|
BINARY $SEQUENCE Sequence BINARY $ASSIGN Assign
|
|
BINARY $WHILE While BINARY $IF If
|
|
BINARY $SUBTRACT Subtract BINARY $ADD Add
|
|
BINARY $MOD Mod BINARY $MULTIPLY Multiply
|
|
BINARY $DIVIDE Divide
|
|
BINARY $LESS Less BINARY $LESSEQUAL LessEqual
|
|
BINARY $GREATER Greater BINARY $GREATEREQUAL GreaterEqual
|
|
BINARY $EQUAL Equal BINARY $NOTEQUAL NotEqual
|
|
BINARY $AND And BINARY $OR Or
|
|
|
|
: TOK-CONS ( x* -- node-xt) TOKEN-TYPE CASE
|
|
Op_subtract OF ['] $SUBTRACT ENDOF
|
|
Op_add OF ['] $ADD ENDOF
|
|
op_mod OF ['] $MOD ENDOF
|
|
op_multiply OF ['] $MULTIPLY ENDOF
|
|
Op_divide OF ['] $DIVIDE ENDOF
|
|
Op_equal OF ['] $EQUAL ENDOF
|
|
Op_notequal OF ['] $NOTEQUAL ENDOF
|
|
Op_less OF ['] $LESS ENDOF
|
|
Op_lessequal OF ['] $LESSEQUAL ENDOF
|
|
Op_greater OF ['] $GREATER ENDOF
|
|
Op_greaterequal OF ['] $GREATEREQUAL ENDOF
|
|
Op_and OF ['] $AND ENDOF
|
|
Op_or OF ['] $OR ENDOF
|
|
ENDCASE ;
|
|
|
|
: (.NODE) DUP CELL+ SWAP @ EXECUTE ;
|
|
' (.NODE) IS .NODE
|
|
|
|
: .- ( n --) 0 <# #S #> TYPE ;
|
|
: EXPECT ( tk --) DUP TOKEN-TYPE <>
|
|
IF CR ." stdin:" TOKEN 2@ SWAP .- ." :" .-
|
|
." : unexpected token, expecting " . CR BYE
|
|
THEN DROP GETTOK ;
|
|
: '(' LeftParen EXPECT ;
|
|
: ')' RightParen EXPECT ;
|
|
: '}' RightBrace EXPECT ;
|
|
: ';' Semicolon EXPECT ;
|
|
: ',' Comma EXPECT ;
|
|
: '=' Op_assign EXPECT ;
|
|
|
|
DEFER *EXPR DEFER EXPR DEFER STMT
|
|
: PAREN-EXPR '(' EXPR ')' ;
|
|
: PRIMARY
|
|
TOKEN-TYPE LeftParen = IF PAREN-EXPR EXIT THEN
|
|
TOKEN-TYPE Op_add = IF GETTOK 12 *EXPR EXIT THEN
|
|
TOKEN-TYPE Op_subtract = IF GETTOK 14 *EXPR $NEGATE EXIT THEN
|
|
TOKEN-TYPE Op_not = IF GETTOK 14 *EXPR $NOT EXIT THEN
|
|
TOKEN-TYPE Identifier = IF TOKEN-VALUE $IDENTIFIER ELSE
|
|
TOKEN-TYPE Integer = IF TOKEN-VALUE $INTEGER THEN THEN
|
|
GETTOK ;
|
|
: (*EXPR) ( n -- node)
|
|
PRIMARY ( n node)
|
|
BEGIN OVER TOKEN-TYPE PREC@ SWAP OVER <= BINARY? AND
|
|
WHILE ( n node prec) 1+ TOK-CONS SWAP GETTOK *EXPR SWAP EXECUTE
|
|
REPEAT ( n node prec) DROP NIP ( node) ;
|
|
: (EXPR) 0 *EXPR ;
|
|
: -)? TOKEN-TYPE RightParen <> ;
|
|
: -}? TOKEN-TYPE RightBrace <> ;
|
|
: (STMT)
|
|
TOKEN-TYPE Semicolon = IF GETTOK STMT EXIT THEN
|
|
TOKEN-TYPE Keyword_while =
|
|
IF GETTOK PAREN-EXPR STMT $WHILE EXIT THEN
|
|
TOKEN-TYPE Keyword_if =
|
|
IF GETTOK PAREN-EXPR STMT
|
|
TOKEN-TYPE Keyword_else = IF GETTOK STMT ELSE $NULL THEN
|
|
$IF $IF EXIT
|
|
THEN
|
|
TOKEN-TYPE Keyword_putc =
|
|
IF GETTOK PAREN-EXPR ';' $PRTC EXIT THEN
|
|
TOKEN-TYPE Keyword_print =
|
|
IF GETTOK '(' $NULL
|
|
BEGIN TOKEN-TYPE String =
|
|
IF TOKEN-VALUE $STRING $PRTS GETTOK
|
|
ELSE EXPR $PRTI THEN $SEQUENCE -)?
|
|
WHILE ',' REPEAT ')' ';' EXIT THEN
|
|
TOKEN-TYPE Identifier =
|
|
IF TOKEN-VALUE $IDENTIFIER GETTOK '=' EXPR ';' $ASSIGN
|
|
EXIT THEN
|
|
TOKEN-TYPE LeftBrace =
|
|
IF $NULL GETTOK BEGIN -}? WHILE STMT $SEQUENCE REPEAT
|
|
'}' EXIT THEN
|
|
TOKEN-TYPE End_of_input = IF EXIT THEN EXPR ;
|
|
' (*EXPR) IS *EXPR ' (EXPR) IS EXPR ' (STMT) IS STMT
|
|
|
|
: -EOI? TOKEN-TYPE End_of_input <> ;
|
|
: PARSE $NULL GETTOK BEGIN -EOI? WHILE STMT $SEQUENCE REPEAT ;
|
|
PARSE .NODE
|