commit 93ff71f54c74b8d5e26f93085b0fd9d3e5a311fd
parent bddaff23856a30010f977dc1d47707ee3899e89a
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Fri, 10 Jun 2022 08:21:11 -0400
wip
Diffstat:
| M | fs/cc/ast.fs | | | 128 | +++++++++++++++++++++++++++++++++++++++++++------------------------------------ |
1 file changed, 70 insertions(+), 58 deletions(-)
diff --git a/fs/cc/ast.fs b/fs/cc/ast.fs
@@ -52,15 +52,15 @@ create bopsprectbl 1 c, 1 c, 0 c, 0 c, 2 c, 2 c, 2 c, 2 c,
\ 9 = unused
10 value AST_BINARYOP \ data1=bopid
11 value AST_ASSIGN \ data1=name
-12 value AST_DECLLIST
+\ 12 = unused
13 value AST_VARIABLE \ data1=name
14 value AST_FUNCALL \ data1=name data2=MAP_FUNCTION
create astidnames 7 c, ," declare" 4 c, ," unit" 8 c, ," function"
6 c, ," return" 8 c, ," constant" 5 c, ," stmts"
4 c, ," args" 4 c, ," expr" 7 c, ," unaryop"
- 6 c, ," factor" 5 c, ," binop" 6 c, ," assign"
- 8 c, ," decllist" 3 c, ," var" 4 c, ," call"
+ 1 c, ," _" 5 c, ," binop" 6 c, ," assign"
+ 1 c, ," _" 3 c, ," var" 4 c, ," call"
0 c,
0 value curunit \ points to current Unit, the beginning of the AST
@@ -74,8 +74,6 @@ create astidnames 7 c, ," declare" 4 c, ," unit" 8 c, ," function"
activenode ?dup not if abort" can't go beyond root!" then
0 over cslots! begin parentnode dup nodeclosed? not until
to activenode ;
-: closeuntil ( astid -- )
- begin seqclose activenode astid over = until drop ;
: _[ '[' emit ;
@@ -93,10 +91,10 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
'w noop ( ArgSpecs )
'w noop ( Expression )
:w ( UnaryOp ) _[ dup data1 uopchar emit _] ;
-'w noop ( Factor )
+'w noop ( Unused )
:w ( BinaryOp ) _[ dup data1 boptoken stype _] ;
'w _s ( Assign )
-'w noop ( DeclarationList )
+'w noop ( Unused )
'w _s ( Variable )
'w _s ( FunCall )
@@ -113,22 +111,25 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
: newnode
createnode dup activenode addnode ( node )
dup nodeclosed? not if to activenode else drop then ;
+: newnode2 ( parent cslots astid -- newnode )
+ createnode ( parent node ) dup rot addnode ( node ) ;
\ AST nodes
-: Declare ( name -- ) -1 AST_DECLARE newnode , ;
-: Unit ( -- ) -1 AST_UNIT createnode dup to curunit to activenode ;
-: Function ( name -- ) 2 AST_FUNCTION newnode , 0 , ;
+: Declare ( parent name -- node )
+ swap -1 AST_DECLARE newnode2 swap , ;
+: Unit ( -- node ) -1 AST_UNIT createnode dup to curunit dup to activenode ;
+: Function ( unitnode name -- node )
+ swap 2 AST_FUNCTION newnode2 swap , 0 , ;
: Return ( -- ) 1 AST_RETURN newnode ;
-: Constant ( n -- ) 0 AST_CONSTANT newnode , ;
-: Statements ( -- ) -1 AST_STATEMENTS newnode ;
-: ArgSpecs ( -- ) -1 AST_ARGSPECS newnode ;
+: Constant ( parent n -- ) swap 0 AST_CONSTANT newnode2 drop , ;
+: Statements ( funcnode -- node ) -1 AST_STATEMENTS newnode2 ;
+: ArgSpecs ( funcnode -- node ) -1 AST_ARGSPECS newnode2 ;
: Expression ( -- ) -1 AST_EXPRESSION newnode ;
-: UnaryOp ( opid -- ) 1 AST_UNARYOP newnode , ;
+: UnaryOp ( parentnode opid -- ) swap 1 AST_UNARYOP newnode2 swap , ;
: BinaryOp ( opid -- node ) 2 AST_BINARYOP newnode , ;
: Assign ( name -- ) 1 AST_ASSIGN newnode , ;
-: DeclarationList ( -- ) -1 AST_DECLLIST newnode ;
-: Variable ( name -- ) 0 AST_VARIABLE newnode , ;
-: FunCall ( name -- ) 0 AST_FUNCALL newnode , ;
+: Variable ( parentnode name -- ) swap 0 AST_VARIABLE newnode2 drop , ;
+: FunCall ( parentnode name -- ) swap 0 AST_FUNCALL newnode2 drop , ;
: _err ( tok -- )
stype spc>
@@ -149,6 +150,21 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
: expectChar ( tok c -- )
over 1+ c@ = _assert dup c@ 1 = _assert drop ;
+\ Parse words
+
+\ parse a constant, variable or function call
+: parseFactor ( parentnode tok -- nexttok )
+ dup isIdent? if \ Variable or FunCall
+ _nextt ( pn prevtok newtok ) dup S" (" s= if \ FunCall
+ drop FunCall _nextt ')' expectChar _nextt
+ else \ Variable
+ rot> Variable ( nexttok ) then
+ else \ Constant
+ expectConst Constant _nextt then ;
+
+: parseUnaryOp ( parentnode uopid -- nexttok )
+ UnaryOp _nextt parseFactor ;
+
\ The binopswap operation is funky. It happens when we want to add a binop that
\ "eats up" the preceding node. There are 3 scenarios.
\ 1. the preceding sibling (let's call it the target node) is not a binop.
@@ -166,59 +182,55 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
swap removenode to activenode ( bopid tgt )
swap BinaryOp ( tgt ) activenode addnode ;
-\ Parse words
-
-\ parse a constant, variable or function call
-: parseFactor ( tok -- nexttok )
- dup isIdent? if \ Variable or FunCall
- _nextt ( prevtok newtok ) dup S" (" s= if \ FunCall
- drop FunCall _nextt ')' expectChar _nextt
- else \ Variable
- swap Variable ( nexttok ) then
- else \ Constant
- expectConst Constant _nextt then ;
-
-: parseExpression ( tok -- )
- dup S" ;" s= if drop AST_STATEMENTS closeuntil exit then
- activeempty? if dup uopid if
- UnaryOp drop _nextt parseFactor parseExpression exit then then
- dup bopid if ( tok binopid )
- swap activeempty? if _err then \ can't start an expression with a binop
- ( bopid tok ) drop
- activenode lastchild ( bopid prev ) dup astid AST_BINARYOP = if
- ( bopid tgt ) 2dup data1 bopprec swap bopprec > if ( bopid tgt )
+: parseBinaryOp ( parentnode bopid -- nexttok )
+ over lastchild ( pn bopid prev ) dup astid AST_BINARYOP = if
+ ( pn bopid tgt ) 2dup data1 bopprec swap bopprec > if ( pn bopid tgt )
\ new binop has a higher precedence, steal right operand!
firstchild nextsibling then then
- binopswap _nextt parseFactor parseExpression exit then
- parseFactor parseExpression ;
+ binopswap lastchild _nextt parseFactor ;
+
+: parseExpression ( parent tok -- )
+ swap to activenode begin ( tok )
+ dup S" ;" s= if drop seqclose exit then
+ dup uopid activeempty? and if \ unaryop
+ nip activenode swap parseUnaryOp
+ else \ not unaryop
+ dup bopid if ( tok binopid )
+ swap activeempty? if _err then \ can't start an expression with a binop
+ ( bopid tok ) drop activenode swap parseBinaryOp
+ else \ not binop
+ activenode swap parseFactor then then
+ again ;
: parseDeclare ( tok -- )
- '=' expectChar activenode data1 Assign Expression _nextt parseExpression ;
+ '=' expectChar activenode data1 Assign Expression activenode _nextt parseExpression ;
-: parseDeclarationList ( tok -- ) expectIdent Declare _nextt parseDeclare ;
+: parseDeclarationList ( stmtsnode -- )
+ _nextt expectIdent Declare to activenode _nextt parseDeclare ;
-: parseArgSpecs ( tok -- )
- dup S" )" s= if drop seqclose exit then
- begin ( tok )
- expectType drop _nextt expectIdent Declare seqclose
- _nextt dup S" )" s= if drop seqclose exit then
+: parseArgSpecs ( funcnode -- )
+ _nextt '(' expectChar ArgSpecs _nextt ( argsnode tok )
+ dup S" )" s= if 2drop exit then
+ begin ( argsnode tok )
+ expectType drop dup _nextt expectIdent Declare drop
+ _nextt dup S" )" s= if 2drop exit then
',' expectChar _nextt again ;
-: parseStatements ( tok -- )
+: parseStatements ( funcnode -- )
+ _nextt '{' expectChar Statements to activenode _nextt
begin ( tok )
- dup S" }" s= if drop seqclose exit then
+ dup S" }" s= if drop exit then
dup S" return" s= if
- drop Return Expression _nextt parseExpression else
- expectType drop _nextt parseDeclarationList then
+ drop Return Expression activenode _nextt parseExpression else
+ expectType drop activenode parseDeclarationList then
_nextt again ;
-: parseFunction ( tok -- )
- '(' expectChar ArgSpecs _nextt parseArgSpecs _nextt
- '{' expectChar Statements _nextt parseStatements ;
+: parseFunction ( unitnode tok -- )
+ Function ( funcnode ) dup parseArgSpecs parseStatements ;
: parseUnit ( -- )
- nextt ?dup not if exit then begin ( tok )
- isType? _assert _nextt expectIdent Function _nextt parseFunction
- nextt ?dup not until ;
+ Unit nextt ?dup not if exit then begin ( unitnode tok )
+ isType? _assert _nextt expectIdent over swap parseFunction ( unitnode )
+ nextt ?dup not until ( unitnode ) drop ;
-: parseast ( -- ) Unit parseUnit ;
+: parseast ( -- ) parseUnit ;
