commit 9600c6c5a36955ee7fb68f7f6e92655f09ae8244
parent 2fa737b31d2dd8075ff94874600cb1537faaa11f
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Sat, 4 Jun 2022 20:13:18 -0400
cc: rework the tree structure
My early structure was simple, but really awkward to modify. Here, I bite the
bullet and have a more proper tree structure.
Diffstat:
6 files changed, 169 insertions(+), 86 deletions(-)
diff --git a/fs/cc/ast.fs b/fs/cc/ast.fs
@@ -5,7 +5,6 @@
\ AST node types
\ ID Name Data Details
-\ 0 SeqClose
\ 1 Unit
\ 2 Function name
\ 3 Return
@@ -18,13 +17,23 @@
\ 10 BinaryOp opid
11 value ASTIDCNT
+1 value AST_UNIT
+2 value AST_FUNCTION
+3 value AST_RETURN
+4 value AST_CONSTANT
+5 value AST_STATEMENTS
+6 value AST_ARGUMENTS
+7 value AST_EXPRESSION
+8 value AST_UNARYOP
+9 value AST_FACTOR
+10 value AST_BINARYOP
+
\ 8 chars per name
create astidnames
-," ) unit functionreturn constantstmts args expr "
+," ????????unit functionreturn constantstmts args expr "
," unaryop factor binop "
0 value curunit \ points to current Unit, the beginning of the AST
-0 value lastnode \ last node of the chain
0 value activenode \ node we're currently adding to
0 value _skip \ if 1, skip the next "nextt" in parseast
@@ -32,48 +41,39 @@ create astidnames
: idname ( id -- sa sl ) 8 * astidnames + 8 rtrim ;
: skipnext 1 to _skip ;
\ is currently active node empty?
-: activeempty? ( -- f ) activenode lastnode = ;
-\ Return the last child of the active node. To find it, we start from
-\ lastnode and as long its parent is not activenode, we go to prevnode.
-: lastactivechild ( -- node )
- lastnode begin dup parentnode activenode = if exit then prevnode again ;
-
-: addnode ( node -- )
- activenode over parentnode! lastnode over prevnode!
- dup lastnode nextnode! dup to lastnode
- dup haschildren? if to activenode else drop then ;
-: newnode createnode addnode ;
-
-\ AST nodes
-: SeqClose ( -- )
- 0 0 0 newnode activenode
- ?dup not if abort" can't go beyond root!" then
- parentnode to activenode
- activenode cslots- not if SeqClose then ;
-: Unit ( -- )
- -1 $01 1 createnode dup to curunit dup to lastnode to activenode ;
-: Function ( 'name namelen -- ) 2 $09 2 newnode dup c, move, ;
-: Return ( -- ) 1 $03 3 newnode ;
-: Constant ( n -- ) 0 $04 4 newnode , ;
-: Statements ( -- ) -1 $01 5 newnode ;
-: Arguments ( -- ) -1 $01 6 newnode ;
-: Expression ( -- ) -1 $01 7 newnode ;
-: UnaryOp ( opid -- ) 1 $07 8 newnode , ;
-: Factor ( -- ) 1 $01 9 newnode ;
-\ does *not* automatically add the node
-: BinaryOp ( opid -- node ) 2 $07 10 createnode swap , ;
-
-: printnode ( node -- )
+: lastactivechild ( -- node ) activenode lastchild ;
+: activeempty? ( -- f ) activenode firstchild not ;
+: printast ( node -- )
?dup not if ." null" exit then
dup astid idname stype dup flags ( node flags )
dup $04 and if ( int data ) '[' emit over intdata .x ']' emit then
$08 and if ( str data ) '[' emit over strdata stype ']' emit then
- drop ;
-: printast ( node -- ) 1 swap begin ( lvl node )
- dup astid not if ( seqclose ) swap 1- swap then
- dup printnode
- dup haschildren? if '(' emit swap 1+ swap else ',' emit then ( lvl node )
- nextnode 2dup not swap not or until 2drop ;
+ firstchild ?dup if
+ '(' emit begin
+ dup printast nextsibling dup if ',' emit then ?dup not until
+ ')' emit then ;
+
+
+: newnode
+ createnode dup activenode addnode ( node )
+ dup nodeclosed? not if to activenode else drop then ;
+
+\ AST nodes
+: SeqClose ( -- )
+ activenode ?dup not if abort" can't go beyond root!" then
+ 0 over cslots! begin parentnode dup nodeclosed? not until
+ to activenode ;
+: Unit ( -- )
+ -1 $01 AST_UNIT createnode dup to curunit to activenode ;
+: Function ( 'name namelen -- ) 2 $09 AST_FUNCTION newnode dup c, move, ;
+: Return ( -- ) 1 $03 AST_RETURN newnode ;
+: Constant ( n -- ) 0 $04 AST_CONSTANT newnode , ;
+: Statements ( -- ) -1 $01 AST_STATEMENTS newnode ;
+: Arguments ( -- ) -1 $01 AST_ARGUMENTS newnode ;
+: Expression ( -- ) -1 $01 AST_EXPRESSION newnode ;
+: UnaryOp ( opid -- ) 1 $07 AST_UNARYOP newnode , ;
+: Factor ( -- ) 1 $01 AST_FACTOR newnode ;
+: BinaryOp ( opid -- node ) 2 $07 AST_BINARYOP newnode , ;
: _err ( ta tl -- )
stype spc>
@@ -107,15 +107,10 @@ create astidnames
\ 3. The preceding node is a binop with a higher precedence than our new
\ binop. Like in scenario 1, we want to take its place. the target is the
\ old binop.
-: spit ( a u -- ) A>r >r >A begin Ac@+ .x1 spc> next r>A ;
-: binopswap ( target bopid -- )
- BinaryOp ( tgt bop )
- over parentnode over parentnode! \ bop.parent = bop.parent
- over prevnode over prevnode! \ bop.prev = tgt.prev
- dup dup prevnode nextnode! \ bop.prev.next = bop
- 2dup nextnode! \ bop.next = tgt
- 2dup swap prevnode! \ tgt.prev = bop
- dup cslots- drop to activenode drop ;
+: binopswap ( bopid target -- )
+ dup dup parentnode ( op tgt tgt parent )
+ swap removenode to activenode ( bopid tgt )
+ swap BinaryOp ( tgt ) activenode addnode ;
\ Parse words. Each of those words have the signature "ta tl -- ".
\ Some words call "skipnext" to skip the next "nextt" call. In that case, the
@@ -145,10 +140,7 @@ ASTIDCNT wordtbl astparsetbl
2dup bopid if ( ta tl binopid )
rot> 2drop
activeempty? if _err then \ can't start an expression with a binop
- lastactivechild astid 10 ( BinaryOp ) = if
- abort" TODO" else
- lastactivechild swap binopswap exit then
- then
+ lastactivechild binopswap exit then
skipnext Factor ;
:w ( UnaryOp ) skipnext Factor ;
:w ( Factor ) expectConst Constant SeqClose ;
diff --git a/fs/cc/cc1.fs b/fs/cc/cc1.fs
@@ -1,7 +1,7 @@
\ C compiler stage 1
\ Requires cc/gen.fs, cc/ast.fs, asm.fs and wordtbl.fs
-: _err ( node -- ) printnode abort" unexpected node" ;
+: _err ( node -- ) printast abort" unexpected node" ;
\ Code generation
\ We have 2 tables below, "post" and "pre". When we perform code generation,
@@ -10,13 +10,13 @@
\ word of the parent of the SeqClose.
\ All words below have the same sig: node -- node
ASTIDCNT wordtbl posttbl
-'w _err ( SeqClose )
+'w _err
'w noop ( Unit )
'w noop ( Function )
:w ( Return )
ebp 4 i32 sub,
[ebp] reg> mov, ;
-'w _err ( Constant )
+'w noop ( Constant )
:w ( Statements ) ret, ;
'w noop ( Arguments )
'w noop ( Expression )
@@ -25,7 +25,7 @@ ASTIDCNT wordtbl posttbl
:w ( BinaryOp ) dup intdata genbop ;
ASTIDCNT wordtbl pretbl
-:w ( SeqClose ) dup parentnode posttbl over astid wexec drop ;
+'w _err
'w noop ( Unit )
:w ( Function ) dup strdata entry ;
'w noop ( Return )
@@ -39,6 +39,8 @@ ASTIDCNT wordtbl pretbl
\ Compiles input coming from the cc< alias (defaulting to in<) and writes the
\ result to here. Aborts on error.
-: cc1, ( -- )
- parseast curunit begin ( node )
- pretbl over astid wexec nextnode ?dup not until ;
+: _ ( node -- )
+ pretbl over astid wexec
+ dup firstchild ?dup if begin dup _ nextsibling ?dup not until then
+ posttbl swap astid wexec ;
+: cc1, ( -- ) parseast curunit _ ;
diff --git a/fs/cc/tree.fs b/fs/cc/tree.fs
@@ -6,15 +6,15 @@
\ 1b flags (see below)
\ 1b child slots
\ 4b addr of parent node (0 if root)
-\ 4b addr of next node (0 if none)
-\ 4b addr of prev node (0 if none)
+\ 4b addr of child node (0 if none)
+\ 4b addr of next sibling (0 if none)
+\ 4b addr of prev sibling (0 if none)
\ ... maybe data
\ Type id: a numerical id. The higest 2 bits determine the category of the
\ node: 0=AST 1=expression 2=unused 3=unused
\ Flags
-\ b0 haschildren this node can contain children
\ b2 int data The 'data section contains a 4b integer
\ b3 str data The 'data section contains a 1b str length followed by a
\ string of that length.
@@ -26,26 +26,44 @@
: nodeid ( node -- id ) c@ ;
: flags ( node -- flags ) 1+ c@ ;
+: flags! ( flags node -- ) 1+ c! ;
: cslots ( node -- slots ) 1+ 1+ c@ ;
: cslots! ( slots node -- ) 1+ 1+ c! ;
-: cslots- ( node -- newslots ) dup cslots 1- tuck swap cslots! ;
-: haschildren? ( node -- f ) flags $01 and ;
+: cslots- ( node -- ) dup cslots 1- swap cslots! ;
+: cslots+ ( node -- ) dup cslots 1+ swap cslots! ;
+: closenode ( node -- ) 0 swap cslots! ;
+: nodeclosed? ( node -- f ) cslots not ;
: parentnode ( node -- parent ) 3 + @ ;
: parentnode! ( parent node -- ) 3 + ! ;
-: nextnode ( node -- next ) 7 + @ ;
-: nextnode! ( next node -- ) 7 + ! ;
-: prevnode ( node -- prev ) 11 + @ ;
-: prevnode! ( prev node -- ) 11 + ! ;
-: 'data ( node -- 'data ) 15 + ;
+: firstchild ( node -- child ) 7 + @ ;
+: firstchild! ( child node -- ) 7 + ! ;
+: nextsibling ( node -- next ) 11 + @ ;
+: nextsibling! ( next node -- ) 11 + ! ;
+: prevsibling ( node -- prev ) 15 + @ ;
+: prevsibling! ( prev node -- ) 15 + ! ;
+: 'data ( node -- 'data ) 19 + ;
: intdata ( node -- n ) 'data @ ;
: strdata ( node -- sa sl ) 'data c@+ ;
-: nextsibling ( node -- next )
- dup parentnode >r begin ( node )
- nextnode dup not if abort" no next!" then
- dup parentnode r@ = until r~ ;
-: prevsibling ( node -- prev )
- dup parentnode >r begin ( node )
- prevnode dup r@ = if abort" no prev!" then
- dup parentnode r@ = until r~ ;
-: createnode ( slots flags id -- node ) here >r c, c, c, 12 allot0 r> ;
-
+: nextnode ( node -- next )
+ dup firstchild ?dup if nip else
+ dup nextsibling ?dup if nip else
+ parentnode nextsibling then then ;
+: lastchild ( node -- child )
+ firstchild dup if begin dup nextsibling ?dup not if exit then nip again then ;
+: createnode ( slots flags id -- node ) here >r c, c, c, 16 allot0 r> ;
+: addnode ( node parent -- )
+ dup nodeclosed? if abort" node is closed" then
+ 2dup swap parentnode! dup cslots- ( node parent )
+ dup lastchild ?dup if ( n p lc ) \ add next to last child
+ nip ( n lc ) 2dup nextsibling! swap prevsibling!
+ else \ add node as first child
+ ( n p ) firstchild! then ;
+: removenode ( node -- )
+ dup parentnode cslots+
+ dup parentnode firstchild over = if
+ dup nextsibling over parentnode firstchild!
+ else
+ dup nextsibling over prevsibling nextsibling! then
+ dup nextsibling if
+ dup prevsibling swap nextsibling prevsibling!
+ else drop then ;
diff --git a/runtests.sh b/runtests.sh
@@ -1,11 +1,19 @@
#!/bin/bash
-for fn in tests/test*; do
- echo "Running $fn"
- if !(echo "bye" | cat tests/harness.fs $fn - | ./dusk); then
+function run() {
+ echo "Running $1"
+ if !(echo "bye" | cat tests/harness.fs $1 - | ./dusk); then
echo
echo "tests failed"
exit 1
fi
-done
-echo "all tests passed"
+}
+
+if [ -z "$1" ]; then
+ for fn in tests/test*; do
+ run $fn
+ done
+ echo "all tests passed"
+else
+ run $1
+fi
diff --git a/tests/testccast.fs b/tests/testccast.fs
@@ -0,0 +1,15 @@
+\ Tests for the C compiler AST
+f<< cc/cc.fs
+: opentestc S" test.c" fopen >fd ;
+opentestc
+' f< to cc<
+parseast
+
+curunit firstchild dup astid AST_FUNCTION #eq ( fnode )
+: s S" retconst";
+dup strdata s S= #
+firstchild nextsibling dup astid AST_STATEMENTS #eq ( snode )
+firstchild dup astid AST_RETURN #eq ( rnode )
+firstchild ( expr ) firstchild ( factor )
+firstchild dup astid AST_CONSTANT #eq ( cnode )
+intdata 42 #eq
diff --git a/tests/testcctree.fs b/tests/testcctree.fs
@@ -0,0 +1,48 @@
+\ C compiler tree unit
+f<< cc/tree.fs
+
+2 0 1 createnode value root
+root nodeid 1 #eq
+root nodeclosed? not #
+
+-1 0 2 createnode value n1
+n1 root addnode
+n1 nodeid 2 #eq
+n1 parentnode root #eq
+n1 nextsibling 0 #eq
+n1 prevsibling 0 #eq
+n1 firstchild 0 #eq
+root firstchild n1 #eq
+
+0 $04 3 createnode 42 , value n2
+n2 root addnode
+n2 nodeid 3 #eq
+n2 intdata 42 #eq
+n2 parentnode root #eq
+n2 nextsibling 0 #eq
+n2 prevsibling n1 #eq
+n2 firstchild 0 #eq
+root firstchild n1 #eq
+root nodeclosed? #
+root lastchild n2 #eq
+
+0 $08 4 createnode 3 c, ," foo" value n3
+n3 n1 addnode
+n3 nodeid 4 #eq
+n3 parentnode n1 #eq
+n3 nextsibling 0 #eq
+n3 prevsibling 0 #eq
+n1 firstchild n3 #eq
+: foo S" foo" ;
+n3 strdata foo S= #
+
+: traverse
+ root begin dup nodeid dup .x1 c, nextnode ?dup not until ;
+create expected 1 c, 2 c, 4 c, 3 c,
+create res traverse
+expected res 4 []= #
+
+n1 removenode
+create expected 1 c, 3 c,
+create res traverse
+expected res 2 []= #
