commit 72a30850cbf1f59f0fa5f473a411e1f48e041212
parent ca88f0459fc93a4517d1181349113c3ee523fafb
Author: Virgil Dupras <hsoft@hardcoded.net>
Date: Sat, 18 Mar 2023 22:50:02 -0400
halcc: introduce the Result structure
I think it's going to end up looking pretty nice...
Diffstat:
7 files changed, 141 insertions(+), 21 deletions(-)
diff --git a/fs/comp/c/egen.fs b/fs/comp/c/egen.fs
@@ -1,5 +1,8 @@
\ Expression code generation
+require /sys/scratch.fs
?f<< /comp/c/tok.fs
+?f<< /comp/c/op.fs
+?f<< /comp/c/func.fs
: _err ( -- ) tokdbg abort" egen error" ;
: _assert ( f -- ) not if _err then ;
@@ -15,8 +18,28 @@ Arena :new structbind Arena _litarena
\ Maximum size in bytes that a single literal can have
$400 const MAXLITSZ
-alias noop parseExpression ( tok -- ) \ forward declaration
-alias noop parseFactor ( tok -- ) \ forward declaration
+struct[ Result
+ 0 const CONST \ Is a constant (value in arg)
+ 1 const W \ Value in W register
+ 2 const HALOP \ Value in memory, HAL operand is in arg.
+ sfield type
+ sfield arg \ either HAL operand or constant value
+
+ : :new ( arg type -- res ) SZ syspad :allot dup >r !+ ! r> ;
+ : :const ( n -- res ) CONST :new ;
+ : :W ( -- res ) 0 W :new ;
+ : :hal ( operand -- res ) HALOP :new ;
+
+ : :>W ( self -- ) dup bi arg | type case ( self arg )
+ CONST of = LIT>W, endof
+ W of = drop endof
+ HALOP of = @, endof
+ _err endcase W swap to type ;
+ : :hal# ( self -- halop ) dup type HALOP = _assert arg ;
+]struct
+
+alias noop parseExpression ( tok -- res ) \ forward declaration
+alias noop parseFactor ( tok -- res ) \ forward declaration
\ A factor can be:
\ 1. A constant
@@ -29,29 +52,61 @@ alias noop parseFactor ( tok -- ) \ forward declaration
\ 8. a typecast followed by a factor
\ 9. NULL
\ 10. sizeof()
-: _ ( tok -- operand isconst? ) case ( )
+: _ ( tok -- res ) case ( )
'(' of isChar?^ abort" TODO" endof
'"' of isChar?^ MAXLITSZ _litarena :[
here 0 c, ['] ," with-stdin<
ccin dup '0' = if
drop 1+ 0 c, \ null terminated
else ccputback here over - 1- over c! then ( saddr )
- _litarena :] drop ( "a ) 1 endof
+ _litarena :] drop ( "a ) Result :const endof
'{' of isChar?^ abort" TODO" endof
S" pspop" of s= abort" TODO" endof
- S" NULL" of s= 0 1 endof
- S" sizeof" of s= read( nextt parseType _assert typesize 1 read) endof
- \ of uopid ( opid ) abort" TODO" endof
- of isIdent? abort" TODO" endof \ lvalue, FunCall or macro
- r@ parse if 1 else _err then
+ S" NULL" of s= 0 Result :const endof
+ S" sizeof" of s=
+ read( nextt parseType _assert typesize Result :const read) endof
+ of uopid ( opid ) abort" TODO" endof
+ of isIdent? \ lvalue, FunCall or macro
+ r@ findIdent ?dup _assert CType :halop Result :hal ( parsePostfixOp ) endof
+ r@ parse if Result :const else _err then
endcase ;
current ' parseFactor realias
+: binop doer ' , does> @ ( left right w )
+ rot Result :>W swap Result :hal# swap execute Result :W ;
+binop _+, +,
+
+: _=, ( left right ) Result :>W Result :hal# !, Result :W ;
+
+BOPSCNT wordtbl _tbl ( -- )
+'w _+, 'w _err 'w _err 'w _err 'w _err 'w _err 'w _err 'w _err
+'w _err 'w _err 'w _err 'w _err 'w _err 'w _err 'w _err 'w _err
+'w _err 'w _err 'w _=, 'w _err 'w _err 'w _err 'w _err 'w _err
+'w _err 'w _err 'w _err 'w _err 'w _err 'w _err 'w _err
+
+: applyBinop ( left right opid -- res ) _tbl swap wexec ;
+
+\ Parse the "right" part of an expression with the leftmost factor and leftmost
+\ binary operator already parsed.
+: parseRExpr ( left binop -- res ) >r >r \ V1=binop V2=left
+ nextt parseFactor nextt ( right tok )
+ dup bopid if ( right tok opright )
+ \ another binop! let's apply precedence rules.
+ nip V1 bopprec over bopprec ( right opright lprec rprec ) > if
+ \ the right part has more precedence.
+ parseRExpr ( newright ) r> swap r> ( left right opid ) applyBinop
+ else ( right opright ) \ the left part has more precedence
+ swap r> swap r> ( opright left right opid ) applyBinop ( opr newleft )
+ swap parseRExpr then
+ else ( right tok ) to nexttputback r> swap r> applyBinop then ;
+
\ An expression can be 2 things:
\ 1. a factor
-\ 3. A binaryop containing two expressions.
-: _ ( tok -- operand isconst? ) \ parseExpression
+\ 2. A binaryop containing two expressions.
+: _ ( tok -- res ) \ parseExpression
\ first tok is always a factor
- parseFactor ;
+ parseFactor nextt ( left tok )
+ dup bopid if ( left tok binop )
+ nip parseRExpr else to nexttputback then ;
current ' parseExpression realias
diff --git a/fs/comp/c/fgen.fs b/fs/comp/c/fgen.fs
@@ -1,18 +1,16 @@
\ Function code generation
?f<< /lib/arena.fs
?f<< /comp/c/tok.fs
+?f<< /comp/c/func.fs
?f<< /comp/c/egen.fs
: _err ( -- ) tokdbg abort" fgen error" ;
: _assert ( f -- ) not if _err then ;
-0 value _curfunc \ ctype of the current function (includes arguments)
-0 value _locvars \ the root ctype of local variables for current function
-
: _postlude
_curfunc CType :argssize ?dup if ps+, then
_locvars CType :size rs+, ;
-: emitRet ( operand isconst? -- ) if LIT>W, else @, then _postlude exit, ;
+: emitRet ( res -- ) Result :>W _postlude exit, ;
: emitNullRet ( -- ) _postlude drop, exit, ;
alias noop parseStatement ( tok -- ) \ forward declaration
@@ -33,13 +31,21 @@ alias noop parseStatement ( tok -- ) \ forward declaration
0 value _laststmtid
: _ ( tok -- ) \ parseStatement
dup statementnames sfind dup >r dup 0< if ( tok -1 ) \ V1=stmtidx
- drop parseExpression 2drop read; else nip statementhandler swap wexec then
+ drop parseExpression drop read; else nip statementhandler swap wexec then
r> to _laststmtid ;
current ' parseStatement realias
+
+\ When there's variable initialization code, it has to come before the prelude
+\ and we jump to it after we've created the stack frame.
+0 value _initcode
+
: parseDeclLine ( type -- )
parseDeclarator ( ctype )
dup _locvars ?dup if CType :append else to _locvars then begin ( ctype )
- '=' readChar? if ( ctype ) abort" TODO" then ( ctype tok )
+ '=' readChar? if ( ctype )
+ _initcode not if here to _initcode then
+ nextt parseExpression ( ctype res )
+ Result :>W dup CType :halop !, nextt then ( ctype tok )
dup ';' isChar? not while ( ctype tok )
',' expectChar CType type parseDeclarator ( ctype )
dup _locvars CType :append repeat ( ctype tok ) 2drop ;
@@ -57,15 +63,17 @@ current ' parseStatement realias
\ '{' is already parsed
: parseFunctionBody ( ctype -- )
- 0 to _locvars to _curfunc _litarena :reserve ( )
+ 0 to _locvars 0 to _initcode to _curfunc _litarena :reserve ( )
STORAGE_SF to@! curstorage >r
begin nextt dup parseType while ( tok type ) nip parseDeclLine repeat ( tok )
to nexttputback r> to curstorage
+ _initcode if [compile] ahead >r then
_curfunc CType :static? not if sysdict _curfunc CType name entry then ( )
here _curfunc to CType offset ( )
_curfunc ?updateFunctionPrototype _curfunc addSymbol
\ prelude: space for stack frame. "dup," is wiggle room for W
dup, _locvars CType :size neg rs+,
+ _initcode ?dup if [compile] again r> [compile] then then
0 to _laststmtid parseStatements
_laststmtid 1 <> if emitRet then \ emit implicit return if needed
0 to _curfunc ;
@@ -78,4 +86,3 @@ current ' parseStatement realias
else dup CType name sysdict @ find ?dup not if
CType name stype abort" not found" then then ( ctype addr )
swap to CType offset ;
-
diff --git a/fs/comp/c/func.fs b/fs/comp/c/func.fs
@@ -0,0 +1,10 @@
+\ Function metadata
+?f<< /comp/c/type.fs
+
+0 value _curfunc \ ctype of the current function (includes arguments)
+0 value _locvars \ the root ctype of local variables for current function
+
+: findIdent ( name -- ctype-or-0 )
+ _curfunc if dup _curfunc CType :find ?dup if nip exit then then ( name )
+ dup _locvars if to' _locvars CType :find else drop 0 then ( name ctype-or-0 )
+ ?dup if nip else findSymbol then ;
diff --git a/fs/comp/c/op.fs b/fs/comp/c/op.fs
@@ -0,0 +1,37 @@
+\ Operators
+?f<< /lib/str.fs
+
+\ Unary operators
+7 const UOPSCNT
+UOPSCNT stringlist UOPTlist "-" "~" "!" "&" "*" "++" "--"
+
+: uopid ( tok -- opid? f )
+ UOPTlist sfind dup 0< if drop 0 else 1 then ;
+: uoptoken ( opid -- tok ) UOPTlist slistiter ;
+
+\ Postfix operators
+2 const POPSCNT
+POPSCNT stringlist POPTlist "++" "--"
+
+: popid ( tok -- opid? f )
+ POPTlist sfind dup 0< if drop 0 else 1 then ;
+: poptoken ( opid -- tok ) POPTlist slistiter ;
+
+\ Binary operators
+31 const BOPSCNT
+BOPSCNT stringlist BOPTlist
+ "+" "-" "*" "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "&" "^" "|"
+ "&&" "||" "=" "+=" "-=" "*=" "/=" "%=" "<<=" ">>=" "&=" "^=" "|=" "?" ":"
+
+\ binary ops precedence. lower means more precedence
+create bopsprectbl BOPSCNT nc,
+ 1 1 0 0 0 2 2 3 3 3 3 4 4 5 5 5
+ 6 6 7 7 7 7 7 7 7 7 7 7 7 8 9
+
+: bopid ( tok -- opid? f )
+ BOPTlist sfind dup 0< if drop 0 else 1 then ;
+: bopidconst ( tok -- opid? f ) \ bopid, but only for const ops
+ bopid dup if over 17 > if 2drop 0 then then ;
+: bopprec ( opid -- precedence ) BOPSCNT min bopsprectbl + c@ ;
+: boptoken ( opid -- tok ) BOPTlist slistiter ;
+: ptrbop? ( opid -- f ) 2 < ; \ can op be applied to pointers?
diff --git a/fs/comp/c/type.fs b/fs/comp/c/type.fs
@@ -104,6 +104,12 @@ struct[ CType
: :isarg? ( dnode -- f ) storage STORAGE_PS = ;
: :isglobal? ( dnode -- f ) storage STORAGE_MEM = ;
+ : :halop ( self -- operand ) dup bi offset | storage case ( self offset )
+ STORAGE_SF of = RSP) swap +) endof
+ STORAGE_PS of = PSP) swap +) endof
+ STORAGE_MEM of = m) endof _err endcase ( self operand )
+ swap type _typesize case 1 of = 8b) endof 2 of = 16b) endof endcase ;
+
\ Combined size of all fields in the LL.
: :size ( self -- size )
dup :isarg? over :funcsig? or if drop CELLSZ exit then
diff --git a/fs/tests/comp/c/cc.fs b/fs/tests/comp/c/cc.fs
@@ -5,8 +5,8 @@ testbegin
\ Tests for the C compiler
cc<< tests/comp/c/test2.c
retconst 42 #eq
-testend \s
variables 82 #eq
+testend \s
negate -42 #eq
bwnot $ffffffd5 #eq
exprbinops 7 #eq
diff --git a/fs/tests/comp/c/test2.c b/fs/tests/comp/c/test2.c
@@ -8,3 +8,8 @@
short retconst() {
return 42;
}
+short variables() {
+ short foo = 40, _bar = 2;
+ _bar = foo + _bar;
+ return foo + _bar;
+}
