commit a9450f9f284adb643d7424b9a803858847947d16
parent 197fd5e4f114f4b5ea88f605098625adea132a57
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Wed, 15 Jun 2022 20:56:00 -0400
cc: simplify cc/ast's assign parsing
Things get much simpler when you treat assign as it is: just another binop.
Diffstat:
| M | fs/cc/ast.fs | | | 171 | ++++++++++++++++++++++++++++++------------------------------------------------- |
| M | fs/cc/gen.fs | | | 33 | ++++++++++++++++----------------- |
2 files changed, 80 insertions(+), 124 deletions(-)
diff --git a/fs/cc/ast.fs b/fs/cc/ast.fs
@@ -3,47 +3,25 @@
\ An abstract syntax tree, AST, is a hierarchical structure of nodes
\ representing the nodes found in a C source file. See tree.fs for structure.
-\ Unary operators for expressions
-\ ID Sym Name
-\ 0 - Negate
-\ 1 ~ Complement
-\ 2 ! Not
-
-3 const UOPSCNT
-create uopssyms ," -~!?"
+\ Unary operators
+5 const UOPSCNT
+create uopssyms ," -~!&*?"
: uopid ( tok -- opid? f )
c@+ 1 = if c@ uopssyms UOPSCNT [c]? dup 0< if drop 0 else 1 then
else drop 0 then ;
: uopchar ( opid -- c ) UOPSCNT min uopssyms + c@ ;
-\ Unary operators for lvalues
-\ ID Sym Name
-\ 0 & Reference
-\ 1 * Dereference
-2 const LOPSCNT
-create lopssyms ," &*?"
-
-: lopid ( tok -- opid? f )
- c@+ 1 = if c@ lopssyms LOPSCNT [c]? dup 0< if drop 0 else 1 then
- else drop 0 then ;
-: lopchar ( opid -- c ) LOPSCNT min lopssyms + c@ ;
-
\ Binary operators
-\ ID Sym Name
-\ 0 + Addition
-\ 1 - Subtraction
-\ 2 * Multiplication
-\ 3 / Division
-
-12 const BOPSCNT
+13 const BOPSCNT
create BOPTlist 1 c, ," +" 1 c, ," -" 1 c, ," *" 1 c, ," /"
1 c, ," <" 1 c, ," >" 2 c, ," <=" 2 c, ," >="
2 c, ," ==" 2 c, ," !=" 2 c, ," &&" 2 c, ," ||"
+ 1 c, ," ="
0 c,
\ binary ops precedence. lower means more precedence
create bopsprectbl 1 c, 1 c, 0 c, 0 c, 2 c, 2 c, 2 c, 2 c,
- 3 c, 3 c, 4 c, 4 c,
+ 3 c, 3 c, 4 c, 4 c, 5 c,
: bopid ( tok -- opid? f )
BOPTlist sfind dup 0< if drop 0 else 1 then ;
@@ -61,9 +39,9 @@ create bopsprectbl 1 c, 1 c, 0 c, 0 c, 2 c, 2 c, 2 c, 2 c,
6 const AST_ARGSPECS
7 const AST_LVALUE \ data1=varname
8 const AST_UNARYOP \ data1=uopid
-9 const AST_ASSIGN
+\ 9 = unused
10 const AST_BINARYOP \ data1=bopid
-11 const AST_LVALUEOP \ data1=lopid
+\ 11 = unused
12 const AST_IF
\ 13 = unused
14 const AST_FUNCALL \ data1=name data2=MAP_FUNCTION
@@ -71,7 +49,7 @@ create bopsprectbl 1 c, 1 c, 0 c, 0 c, 2 c, 2 c, 2 c, 2 c,
create astidnames 7 c, ," declare" 4 c, ," unit" 8 c, ," function"
6 c, ," return" 8 c, ," constant" 5 c, ," stmts"
4 c, ," args" 6 c, ," lvalue" 7 c, ," unaryop"
- 6 c, ," assign" 5 c, ," binop" 6 c, ," lvalop"
+ 1 c, ," _" 5 c, ," binop" 1 c, ," _"
2 c, ," if" 1 c, ," _" 4 c, ," call"
0 c,
@@ -95,10 +73,10 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
'w noop ( ArgSpecs )
'w _s ( LValue )
:w ( UnaryOp ) _[ dup data1 uopchar emit _] ;
-'w noop ( Assign )
+'w noop ( unused )
:w ( BinaryOp ) _[ dup data1 boptoken stype _] ;
-:w ( LvalueOp ) _[ dup data1 lopchar emit _] ;
'w noop ( Unused )
+'w noop ( If )
'w noop ( Unused )
'w _s ( FunCall )
@@ -117,9 +95,8 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
\ if not 0, next _nextt call will fetch token from here
0 value nexttputback
-: _err ( tok -- )
- stype spc> abort" parsing error" ;
-: _assert ( tok f -- ) not if _err then ;
+: _err ( -- ) abort" parsing error" ;
+: _assert ( f -- ) not if _err then ;
: _nextt
nexttputback ?dup if 0 to nexttputback exit then
nextt ?dup not if abort" expecting token!" then ;
@@ -139,71 +116,61 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
\ Parse words
-\ Parse a Lvalue wrapped in its unaryops (AST_LVALUEOP) if there are any.
-: parseLvalue ( tok -- lvnode )
- dup lopid if ( tok opid )
- nip AST_LVALUEOP createnode swap , ( lopnode )
- _nextt parseLvalue ( lopnode lvnode ) over addnode
- else ( tok ) expectIdent AST_LVALUE createnode swap , then ;
-
-\ parse a constant, variable or function call
+\ A factor can be:
+\ 1. A constant
+\ 2. A Lvalue
+\ 3. A unaryop containing a factor
+\ 4. A function call
: parseFactor ( tok -- node-or-0 )
- dup isIdent? if \ lvalue or FunCall
- _nextt ( prevtok newtok ) dup S" (" s= if \ FunCall
- drop AST_FUNCALL createnode swap , begin ( node )
- _nextt dup parseFactor ?dup if \ an argument
- nip over addnode
- _nextt dup S" ," s= if drop else to nexttputback then 0
- else \ not an argument
- ')' expectChar 1 then until ( node )
- else \ lvalue
- to nexttputback parseLvalue then
- else \ Constant
- parse if AST_CONSTANT createnode swap , else 0 then
+ dup uopid if ( tok opid )
+ nip AST_UNARYOP createnode swap , ( opnode )
+ _nextt parseFactor ?dup _assert over addnode ( opnode )
+ else ( tok )
+ dup isIdent? if \ lvalue or FunCall
+ _nextt ( prevtok newtok ) dup S" (" s= if \ FunCall
+ drop AST_FUNCALL createnode swap , begin ( node )
+ _nextt dup parseFactor ?dup if \ an argument
+ nip over addnode
+ _nextt dup S" ," s= if drop else to nexttputback then 0
+ else \ not an argument
+ ')' expectChar 1 then until ( node )
+ else \ lvalue
+ to nexttputback AST_LVALUE createnode swap , then
+ else \ Constant
+ parse if AST_CONSTANT createnode swap , else 0 then
+ then
then ;
-: parseUnaryOp ( tok -- opid? astid? f )
- dup uopid if
- nip AST_UNARYOP 1 else lopid if
- AST_LVALUEOP 1 else 0 then then ;
-
-\ An expression can be 3 things:
+\ An expression can be 2 things:
\ 1. a factor
-\ 2. an unaryop containing an expression
\ 3. A binaryop containing two expressions.
: parseExpression ( tok -- exprnode )
- dup parseUnaryOp if ( tok opid astid )
- createnode ( tok opid node ) swap , nip ( node )
- _nextt parseExpression ( uopnode expr )
- over addnode ( node )
- else ( tok ) \ binaryop or factor
- \ tok is expected to be a factor
- parseFactor ?dup _assert _nextt ( factor nexttok )
- dup bopid if ( factor tok binop )
- nip ( factor binop ) AST_BINARYOP createnode swap , ( factor node )
- tuck addnode _nextt ( binnode tok )
- \ now, let's consume tokens as long as we have binops coming.
- begin ( bn tok )
- parseFactor ?dup _assert _nextt ( bn factor tok ) dup bopid if ( bn fn tok bopid )
- nip AST_BINARYOP createnode swap , ( bn1 fn bn2 )
- \ another binop! who will get fn? bn1 or bn2? the one that has the
- \ best precedence!
- rot ( fn bn2 bn1 ) over data1 bopprec over data1 bopprec < if
- \ bn2 wins. add fn to bn2, add bn2 to bn1, bn2 becomes bn
- rot> tuck addnode ( bn1 bn2 ) dup rot addnode ( bn2->bn )
- else \ bn1 wins. add fn to bn1, bn1 to bn2, bn2 becomes bn
- rot over addnode ( bn2 bn1 ) over addnode ( bn2->bn )
- then ( bn )
- _nextt 0 ( bn tok 0 )
- else ( bn fn tok ) \ not a binop
- \ tok becomes nexttok and we add fn to bn to complete the chain
- rot> over addnode swap 1 ( bn tok 1 ) then
- until ( bn tok )
- \ bn is not necessarily our result, the root node is.
- swap rootnode swap
- then \ if not binop we have nothing to do, we're done
- ( node tok ) to nexttputback
- then ;
+ \ tok is expected to be a factor
+ parseFactor ?dup _assert _nextt ( factor nexttok )
+ dup bopid if ( factor tok binop )
+ nip ( factor binop ) AST_BINARYOP createnode swap , ( factor node )
+ tuck addnode _nextt ( binnode tok )
+ \ now, let's consume tokens as long as we have binops coming.
+ begin ( bn tok )
+ parseFactor ?dup _assert _nextt ( bn factor tok ) dup bopid if ( bn fn tok bopid )
+ nip AST_BINARYOP createnode swap , ( bn1 fn bn2 )
+ \ another binop! who will get fn? bn1 or bn2? the one that has the
+ \ best precedence!
+ rot ( fn bn2 bn1 ) over data1 bopprec over data1 bopprec < if
+ \ bn2 wins. add fn to bn2, add bn2 to bn1, bn2 becomes bn
+ rot> tuck addnode ( bn1 bn2 ) dup rot addnode ( bn2->bn )
+ else \ bn1 wins. add fn to bn1, bn1 to bn2, bn2 becomes bn
+ rot over addnode ( bn2 bn1 ) over addnode ( bn2->bn )
+ then ( bn )
+ _nextt 0 ( bn tok 0 )
+ else ( bn fn tok ) \ not a binop
+ \ tok becomes nexttok and we add fn to bn to complete the chain
+ rot> over addnode swap 1 ( bn tok 1 ) then
+ until ( bn tok )
+ \ bn is not necessarily our result, the root node is.
+ swap rootnode swap
+ then \ if not binop we have nothing to do, we're done
+ ( node tok ) to nexttputback ;
: parseDeclare ( parentnode -- dnode )
0 begin ( pnode *lvl )
@@ -213,7 +180,7 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
: parseDeclarationList ( stmtsnode -- )
parseDeclare _nextt '=' expectChar dup data1 ( dnode name )
- swap parentnode AST_ASSIGN newnode ( name anode )
+ swap parentnode AST_BINARYOP newnode ( name anode ) 12 ( = ) ,
AST_LVALUE newnode ( name lvnode ) swap , parentnode ( anode )
_nextt parseExpression read; ( anode expr ) swap addnode ;
@@ -225,16 +192,6 @@ ASTIDCNT wordtbl astdatatbl ( node -- node )
_nextt dup S" )" s= if 2drop exit then
',' expectChar _nextt again ;
-\ Parse an assignment statement. It consists of a '=' char with an lvalue on
-\ the left and an expression on the right. The left part can have LValue ops
-\ applied to it.
-: parseAssign ( parent tok -- )
- \ --> assign(lvalue, expr)
- swap AST_ASSIGN newnode swap ( anode tok )
- parseLvalue ( anode lvnode ) over addnode ( anode )
- _nextt '=' expectChar ( anode )
- _nextt parseExpression read; ( anode expr ) swap addnode ;
-
alias noop parseStatements ( funcnode -- ) \ forward declaration
create statementnames 6 c, ," return" 2 c, ," if" 0 c,
@@ -258,7 +215,7 @@ create statementnames 6 c, ," return" 2 c, ," if" 0 c,
dup S" }" s= if 2drop exit then
dup statementnames sfind dup 0< if ( snode tok -1 )
drop dup isType? if drop dup parseDeclarationList else ( snode tok )
- over rot> parseAssign then ( snode )
+ parseExpression over addnode read; then ( snode )
else ( snode tok idx ) nip statementhandler swap wexec then ( snode )
_nextt again ;
current to parseStatements
diff --git a/fs/cc/gen.fs b/fs/cc/gen.fs
@@ -6,15 +6,12 @@
: _err ( node -- ) printast abort" unexpected node" ;
UOPSCNT wordtbl uopgentbl ( -- )
-'w vmneg, ( - )
-'w vmnot, ( ~ )
-'w vmboolnot, ( ! )
-
-LOPSCNT wordtbl lopgentbl ( -- )
+:w ( - ) operand?>result vmneg, ;
+:w ( ~ ) operand?>result vmnot, ;
+:w ( ! ) operand?>result vmboolnot, ;
'w operand>&operand ( & )
'w operand>[operand] ( * )
-\ In binary Ops, the result is in EAX and the source operand is EBX.
BOPSCNT wordtbl bopgentblmiddle ( node -- node )
'w noop ( + )
'w noop ( - )
@@ -28,6 +25,7 @@ BOPSCNT wordtbl bopgentblmiddle ( node -- node )
'w noop ( != )
:w ( && ) vmjz, swap ;
:w ( || ) vmjnz, swap ;
+'w noop ( = )
BOPSCNT wordtbl bopgentblpost ( -- )
'w vmadd, ( + )
@@ -42,6 +40,7 @@ BOPSCNT wordtbl bopgentblpost ( -- )
:w ( != ) abort" TODO" ;
'w vmjmp! ( && )
'w vmjmp! ( || )
+'w noop ( = )
alias noop gennode ( node -- ) \ forward declaration
@@ -55,6 +54,14 @@ alias noop gennode ( node -- ) \ forward declaration
dup data1 swap getfuncmap ( name funcentry ) findvarinmap ( varentry )
vmap.sfoff ;
+\ special binop case
+: _assign ( node -- )
+ firstchild ?dup not if _err then ( lvnode )
+ dup nextsibling ?dup not if _err then ( lvnode exprnode )
+ gennode operand?>result \ result=set
+ gennode \ operand=set
+ result>operand ;
+
ASTIDCNT wordtbl gentbl ( node -- )
'w drop ( Declare )
'w genchildren ( Unit )
@@ -75,15 +82,9 @@ ASTIDCNT wordtbl gentbl ( node -- )
:w ( LValue ) lvsfoff sf+>operand ;
:w ( UnaryOp )
dup genchildren
- operand?>result
data1 uopgentbl swap wexec ;
-:w ( Assign )
- firstchild ?dup not if _err then ( lvnode )
- dup nextsibling ?dup not if _err then ( lvnode exprnode )
- gennode operand?>result \ result=set
- gennode \ operand=set
- result>operand ;
-:w ( BinaryOp )
+'w _err ( unused )
+:w ( BinaryOp ) dup data1 12 = if _assign exit then
( node ) >r
r@ childcount 2 = not if abort" binop node with more than 2 children!" then
r@ firstchild dup nextsibling swap ( n2 n1 )
@@ -93,9 +94,7 @@ ASTIDCNT wordtbl gentbl ( node -- )
pushresult, gennode operand?>result popresult, else
gennode operand?>result then
bopgentblpost r> data1 wexec ;
-:w ( LValueOp )
- dup firstchild ?dup not if _err then gennode
- data1 lopgentbl swap wexec ;
+'w _err ( unused )
:w ( If )
firstchild ?dup not if _err then dup gennode ( exprnode )
operand?>result vmjz, swap ( jump_addr exprnode )
