~vdupras/duskos

a402716aa8db071e87f6af900a2dc35ad75ecbf7 — Virgil Dupras 2 days ago 4b75272
cc: replace cc/tree's data{1,4} with proper ufields for each AST node type

Things are much clearer this way.
7 files changed, 63 insertions(+), 62 deletions(-)

M fs/cc/ast.fs
M fs/cc/gen.fs
M fs/cc/map.fs
M fs/cc/tok.fs
M fs/cc/tree.fs
M fs/tests/cc/ast.fs
M fs/tests/cc/tree.fs
M fs/cc/ast.fs => fs/cc/ast.fs +36 -24
@@ 35,22 35,35 @@ create bopsprectbl 1 c, 1 c, 0 c, 0 c, 2 c, 2 c, 2 c, 2 c,

\ AST node types
15 const ASTIDCNT
0 const AST_DECLARE    \ data1=name data2=type data3=nbelem
0 const AST_DECLARE
1 const AST_UNIT
2 const AST_FUNCTION   \ data1=name data2=MAP_FUNCTION data3=type
2 const AST_FUNCTION
3 const AST_RETURN
4 const AST_CONSTANT   \ data1=value
4 const AST_CONSTANT
5 const AST_STATEMENTS
6 const AST_ARGSPECS
7 const AST_LVALUE     \ data1=varname
8 const AST_UNARYOP    \ data1=uopid
9 const AST_POSTFIXOP  \ data1=popid
10 const AST_BINARYOP  \ data1=bopid
7 const AST_LVALUE
8 const AST_UNARYOP
9 const AST_POSTFIXOP
10 const AST_BINARYOP
11 const AST_LIST      \ list of lvalues or constants: {1, 2, 3}
12 const AST_IF
\ 13 = unused
14 const AST_FUNCALL   \ data1=name data2=MAP_FUNCTION

14 const AST_FUNCALL

NODESZ     ufield ast.decl.name
NODESZ 4 + ufield ast.decl.type
NODESZ 8 + ufield ast.decl.nbelem
NODESZ     ufield ast.func.name
NODESZ 4 + ufield ast.func.fmap
NODESZ 8 + ufield ast.func.type
NODESZ     ufield ast.const.value
NODESZ     ufield ast.lvalue.name
NODESZ     ufield ast.uop.opid
NODESZ     ufield ast.pop.opid
NODESZ     ufield ast.bop.opid
NODESZ     ufield ast.funcall.funcname
NODESZ 4 + ufield ast.funcall.fmap
ASTIDCNT stringlist astidnames
"declare" "unit" "function" "return" "constant" "stmts" "args" "lvalue"
"unaryop" "postop" "binop" "list" "if" "_" "call"


@@ 62,30 75,28 @@ ASTIDCNT stringlist astidnames

: _[ '[' emit ;
: _] ']' emit ;
: _s _[ dup data1 stype _] ;
: _i _[ dup data1 .x _] ;

ASTIDCNT wordtbl astdatatbl ( node -- node )
:w ( Declare ) _[
  dup data2 printtype spc>
  dup data1 stype
  dup data3 dup 1 > if _[ .x _] else drop then _] ;
  dup ast.decl.type printtype spc>
  dup ast.decl.name stype
  dup ast.decl.nbelem dup 1 > if _[ .x _] else drop then _] ;
'w noop ( Unit )
:w ( function ) _[
  dup data3 printtype spc>
  dup data1 stype _] ;
  dup ast.func.type printtype spc>
  dup ast.func.name stype _] ;
'w noop ( Return )
'w _i ( Constant )
:w ( Constant ) _[ dup ast.const.value .x _] ;
'w noop ( Statements )
'w noop ( ArgSpecs )
'w _s ( LValue )
:w ( UnaryOp ) _[ dup data1 uoptoken stype _] ;
'w noop ( unused )
:w ( BinaryOp ) _[ dup data1 boptoken stype _] ;
:w ( LValue ) _[ dup ast.lvalue.name stype _] ;
:w ( UnaryOp ) _[ dup ast.uop.opid uoptoken stype _] ;
:w ( PostfixOp ) _[ dup ast.pop.opid poptoken stype _] ;
:w ( BinaryOp ) _[ dup ast.bop.opid boptoken stype _] ;
'w noop ( Unused )
'w noop ( If )
'w noop ( Unused )
'w _s ( FunCall )
:w ( FunCall ) _[ dup ast.funcall.funcname stype _] ;

: printast ( node -- )
    ?dup not if ." null" exit then


@@ 196,7 207,8 @@ alias noop parseExpression ( tok -- node ) \ forward declaration
      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
      rot ( fn bn2 bn1 ) over ast.bop.opid bopprec
      over ast.bop.opid 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


@@ 224,7 236,7 @@ current to parseExpression

: parseDeclarationList ( type stmtsnode -- )
  parseDeclare nextt dup S" =" s= not if ';' expectChar drop exit then
  drop ( dnode ) dup data1 ( dnode name )
  drop ( dnode ) dup ast.decl.name ( dnode name )
  swap parentnode AST_BINARYOP newnode ( name anode ) 12 ( = ) ,
  AST_LVALUE newnode ( name lvnode ) swap , parentnode ( anode )
  nextt dup S" {" s= if

M fs/cc/gen.fs => fs/cc/gen.fs +17 -16
@@ 54,23 54,24 @@ alias noop gennode ( node -- ) \ forward declaration
  firstchild ?dup if begin dup gennode nextsibling ?dup not until then ;

: spit ( a u -- ) A>r >r >A begin Ac@+ .x1 next r>A ;
: getfuncmap ( node -- funcentry ) AST_FUNCTION parentnodeid data2 ;
: getfuncmap ( node -- funcentry ) AST_FUNCTION parentnodeid ast.func.fmap ;
: lvvar ( lvnode -- ) \ sets Varmap
  dup data1 swap getfuncmap ( name funcentry ) findvarinmap to Varmap ;
  dup ast.lvalue.name swap getfuncmap ( name funcentry )
  findvarinmap to Varmap ;

\ Multiply the value of "node" by a factor of "n"
\ TODO: support lvalues and expressions
: node*=n ( n node -- )
  dup astid case ( n node )
    AST_CONSTANT of = tuck data1 * swap data1! endof
    AST_CONSTANT of = tuck ast.const.value * swap to ast.const.value endof
    _err
  endcase ;

\ Return the "pointer arithmetic size" of "node".
: node*arisz ( node -- n )
  dup astid AST_LVALUE = if ( node )
    lvvar vmap.decl ( dnode ) dup data2 ( dnode type )
    swap data3 ( nbelem ) 1 > if type*lvl+ then *ariunitsz ( n ) else
    lvvar vmap.decl ( dnode ) dup ast.decl.type ( dnode type )
    swap ast.decl.nbelem ( nbelem ) 1 > if type*lvl+ then *ariunitsz ( n ) else
    drop 1 then ;

\ given a BinaryOp node "bnode", verify whether pointer arithmetic adjustments


@@ 136,36 137,36 @@ ASTIDCNT wordtbl gentbl ( node -- )
'w drop ( Declare )
'w genchildren ( Unit )
:w ( Function )
  _debug if ." debugging: " dup data1 stype nl> then
  _debug if ." debugging: " dup ast.func.name stype nl> then
  ops$
  dup data1 entry
  dup data2 ( astfunc mapfunc )
  dup ast.func.name entry
  dup ast.func.fmap ( astfunc mapfunc )
  here over to fmap.address \ set address
  dup fmap.argsize swap fmap.sfsize over - ( argsz locsz ) vmprelude,
  genchildren
  _debug if current here current - spit nl> then ;
:w ( Return )
  genchildren vmret, ;
:w ( Constant ) data1 const>op ;
:w ( Constant ) ast.const.value const>op ;
:w ( Statements )
  \ we run ops$ between each statement to discard any unused Result
  firstchild ?dup if begin dup gennode ops$ nextsibling ?dup not until then ;
'w genchildren ( ArgSpecs )
:w ( LValue )
  lvvar vmap.sfoff sf+>op ( )
  vmap.decl data3 ( nbelem ) 1 > if &op>op then ;
  vmap.decl ast.decl.nbelem ( nbelem ) 1 > if &op>op then ;
:w ( UnaryOp )
  _debug if ." unaryop: " dup printast nl> .ops then
  dup genchildren
  data1 uopgentbl swap wexec ;
  ast.uop.opid uopgentbl swap wexec ;
:w ( PostfixOp )
  dup genchildren
  data1 popgentbl swap wexec ;
  ast.pop.opid popgentbl swap wexec ;
\ See "Binary op resolution strategy" in opening comment
:w ( BinaryOp )
  _debug if ." binop: " dup printast nl> .ops then
  selectedop >r ( node ) >r
  r@ bopgentblpre r@ data1 wexec ( node )
  r@ bopgentblpre r@ ast.bop.opid wexec ( node )
  firstchild dup nextsibling swap ( n2 n1 )
  over needs2ops? if \ n2 == 2ops
    \ Resolve n2 before n1


@@ 175,13 176,13 @@ ASTIDCNT wordtbl gentbl ( node -- )
      selop2 gennode op1<>op2 then
  else \ nothing special needed, regular resolution
    selop1 gennode selop2 gennode then
  bopgentblpost r> data1 wexec
  bopgentblpost r> ast.bop.opid wexec
  r> ( selectedop ) if op1<>op2 else selop1 then ;
\ TODO: this doesn't work with lvalues yet
:w ( List )
  dup childcount dup 1+ 4 * scratchallot dup >r ( node len a )
  over >r tuck ! 4 + swap firstchild begin ( a node )
    dup data1 ( a node value ) rot tuck ! ( node a )
    dup ast.const.value ( a node value ) rot tuck ! ( node a )
    4 + swap nextsibling next ( a node ) 2drop
  r> constarray>op ;
:w ( If )


@@ 199,7 200,7 @@ ASTIDCNT wordtbl gentbl ( node -- )
    dup selop1 gennode swap dup selop2 sf+>op op1<>op2 vmmov, ops$
    4 - swap nextsibling ?dup not until drop then
  \ find and call
  ( node ) data1 ( name ) findfuncinmap ( mapfunc )
  ( node ) ast.funcall.funcname ( name ) findfuncinmap ( mapfunc )
  fmap.address vmcall>op1, ;

: _ ( node -- ) gentbl over astid wexec ;

M fs/cc/map.fs => fs/cc/map.fs +5 -4
@@ 42,13 42,14 @@ struct Varmap
    prevword ?dup not until ;

: Function ( astnode -- entry )
  dup data1 ( name ) curmap xentry ( astnode )
  dup ast.func.name ( name ) curmap xentry ( astnode )
  here swap , 16 allot0 ( entry ) ;

: Variable ( dnode -- )
  dup data1 curmap @ fmap.vmap xentry ( dnode )
  dup ast.decl.name curmap @ fmap.vmap xentry ( dnode )
  curmap @ fmap.sfsize , dup , ( dnode )
  dup data2 ( dnode type ) typesize swap data3 ( nbelem )
  dup ast.decl.type ( dnode type )
  typesize swap ast.decl.nbelem ( nbelem )
  1 max * ( sfsize )
  curmap @ to+ fmap.sfsize ;



@@ 58,7 59,7 @@ struct Varmap
: findfuncinmap ( name -- funcentry ) curmap xfind not if _err then ;

: mapfunction ( astfunction -- )
  dup Function ( astfunc fmap ) over data2! ( astfunc ) begin ( curnode )
  dup Function ( astfunc fmap ) over to ast.funcall.fmap ( astfunc ) begin ( curnode )
    AST_DECLARE nextnodeid dup if ( astdecl )
      dup parentnode nodeid AST_ARGSPECS = if \ inc argssize field
        4 curmap @ to+ fmap.argsize then

M fs/cc/tok.fs => fs/cc/tok.fs +1 -1
@@ 103,4 103,4 @@ create _ 10 c, ," 09AZaz__$$"
\ logic.
: nextt ( -- tok )
  nexttputback ?dup if 0 to nexttputback exit then
  nextt? ?dup not if abort" expecting token!" then dup stype nl> ;
  nextt? ?dup not if abort" expecting token!" then ;

M fs/cc/tree.fs => fs/cc/tree.fs +1 -13
@@ 10,10 10,7 @@
\ 4b addr of prev sibling (0 if none)
\ ... maybe data

\ Child slots
\ Indicate the number of children that this node can have. 0 means none, -1
\ means unlimited, other numbers indicate the number of slots. Each time a
\ children is added, the slot is decreased. When 0 is reached, we close it.
20 const NODESZ

: nodeid ( node -- id ) c@ ;
: nodeid! ( id node -- ) c! ;


@@ 25,15 22,6 @@
: nextsibling! ( next node -- ) 12 + ! ;
: prevsibling ( node -- prev ) 16 + @ ;
: prevsibling! ( prev node -- ) 16 + ! ;
: 'data ( node -- 'data ) 20 + ;
: data1 ( node -- n ) 'data @ ;
: data1! ( n node -- ) 'data ! ;
: data2 ( node -- n ) 'data 4 + @ ;
: data2! ( n node -- ) 'data 4 + ! ;
: data3 ( node -- n ) 'data 8 + @ ;
: data3! ( n node -- ) 'data 8 + ! ;
: data4 ( node -- n ) 'data 12 + @ ;
: data4! ( n node -- ) 'data 12 + ! ;
: rootnode ( n -- n ) dup parentnode if parentnode rootnode then ;
\ iterate to the next node, descending into children before continuing to
\ siblings. we stop when we reach the last child of "ref"

M fs/tests/cc/ast.fs => fs/tests/cc/ast.fs +2 -2
@@ 6,9 6,9 @@ testbegin
_parse

curunit firstchild dup astid AST_FUNCTION #eq ( fnode )
dup data1 S" retconst" s= #
dup ast.func.name S" retconst" s= #
firstchild nextsibling dup astid AST_STATEMENTS #eq ( snode )
firstchild dup astid AST_RETURN #eq ( rnode )
firstchild dup astid AST_CONSTANT #eq ( cnode )
data1 42 #eq
ast.const.value 42 #eq
testend

M fs/tests/cc/tree.fs => fs/tests/cc/tree.fs +1 -2
@@ 15,10 15,9 @@ n2 prevsibling 0 #eq
n2 firstchild 0 #eq
n1 firstchild n2 #eq

3 createnode 42 , value n3
3 createnode value n3
n3 n1 addnode
n3 nodeid 3 #eq
n3 'data @ 42 #eq
n3 parentnode n1 #eq
n3 nextsibling 0 #eq
n3 prevsibling n2 #eq