M lib/scopes/compiler/arcmem/Array.sc +20 -0
@@ 81,6 81,26 @@ typedef+ Array
inline (i) (self @ (i - 1:usize))
inline (i) (i - 1:usize)
+ inline... offset (self, offset : usize)
+ let T = (typeof self)
+ assert (offset <= (countof self))
+ ptr := getelementptr (storagecast (view self)) offset
+ bitcast (share ptr) T
+
+ inline decons (self count)
+ let T = (typeof self)
+ count := static-if (none? count) 1
+ else count
+ if (count > (countof self))
+ raise;
+ result... := va-map
+ inline (i)
+ @ (getelementptr (storagecast (view self)) i)
+ va-range count
+ ptr := getelementptr (storagecast (view self)) count
+ self := bitcast (share ptr) T
+ (va-join result...) self
+
""""Implements support for pointer casts, to pass the array to C functions
for example.
@@ memo
M lib/scopes/compiler/noir/Builder.sc +19 -0
@@ 222,6 222,25 @@ struct Builder
symbol = name
f
+ fn fntype-indirect (self cconv rtype types)
+ H := uhash.from-integer cconv
+ H := uhash.join H
+ uhash.from-integer rtype
+ sizeof rtype
+ H := fold (H) for T in types
+ uhash.join H
+ uhash.from-integer T
+ sizeof T
+ try
+ copy ('get self._fntypecache H)
+ else
+ id := self._module.c_func
+ cconv = cconv
+ rtype = rtype
+ types = types
+ 'set self._fntypecache H id
+ id
+
fn fntype (self cconv rtype types...)
H := uhash.from-integer cconv
H := uhash.join H
M lib/scopes/compiler/noir/Module.sc +1 -1
@@ 56,7 56,7 @@ enum IdKind : u8
# inlined constants
- # 56 bit unsigned integer
+ # 48 bit unsigned integer
IndexAttr = c"u"
# the nth function argument
FuncArgIndex = c"a"
M lib/scopes/compiler/pilot/DBParser.sc +1 -1
@@ 58,7 58,7 @@ struct ParserDB
items = ListItems
inline symbol (self str)
- H := hash str
+ H := hash.from-bytes ('data str)
try
copy ('get self.idx_symbol_string H)
else
M lib/scopes/downcast.sc +1 -1
@@ 114,7 114,7 @@ inline typetagof (cls T)
static-error
.. "values of type "
static-repr cls
- " can never be downcast to type "
+ " can never be downcast... to type "
static-repr T
tag
M testing/compiler/frontend.sc +184 -8
@@ 3,7 3,7 @@
This file is distributed under the MIT License.
See LICENSE.md for details.
-unlet exit
+unlet exit Value
#using import C.stat C.stdlib C.libgen C.string C.stdio C.limits String format print
using import C.stdio
@@ 14,14 14,35 @@ using import format compiler.basics
compiler.printutils
compiler.noir.Module
compiler.noir.Builder
+ compiler.noir.printer
compiler.arcmem.PMap
using import compiler.pilot.DBParser
+enum Sugar : u8
+ dlimport
+ fntype
+
+enum Value
+ id : Module.Id
+ op : Module.Operation
+ cconv : CallConv
+ sugar : Sugar
+
+Env := PMap ParserDB.Id.Symbol Value
+
struct Context
- db : arc@ ParserDB
+ db : ~arc@ ParserDB
builder : Builder
filepath : rawstring
+ assign_token : ParserDB.Id.Symbol
+
+ inline __typecall (cls db filepath)
+ assign_token := 'symbol (@ (view db)) "="
+ super-type.__typecall cls
+ db = db
+ filepath = filepath
+ assign_token = assign_token
inline iterlist (self id)
'each @self.db id
@@ 36,32 57,184 @@ struct Context
/t
/excerpt self.filepath anchor.begin (anchor.end - anchor.begin)
exit 255
+ unreachable;
+
+ fn decons-cconv (self env aid l)
+ cconv l := try
+ 'decons l
+ else
+ 'complain self aid "calling convention missing"
+ __ aid := unpack cconv
+ cconv := 'expand self env cconv
+ dispatch cconv
+ case cconv (cconv)
+ return cconv l
+ default;
+ 'complain self aid "calling convention expected"
+
+ fn decons-return-type (self env aid l)
+ rtype l := try
+ 'decons l
+ else
+ 'complain self aid "return type missing"
+ __ aid := unpack rtype
+ rtype := 'expand self env rtype
+ dispatch rtype
+ case id (rtype)
+ try
+ downcast rtype Module.Id.CRetType
+ then (rtype)
+ return rtype l
+ else;
+ default;
+ 'complain self aid "return type expected"
+
+ fn decons-element-type (self env aid l)
+ T l := try
+ 'decons l
+ else
+ 'complain self aid "type missing"
+ __ aid := unpack T
+ T := 'expand self env T
+ dispatch T
+ case id (T)
+ try
+ downcast T Module.Id.CElementType
+ then (T)
+ return T l
+ else;
+ default;
+ 'complain self aid "type expected"
+
+ fn expand-list (self env aid l)
+ viewing self env l
+ returning Value
+ head l := try
+ 'decons l
+ else
+ 'complain self aid "expression is empty"
+ head := 'expand self env head
+ dispatch head
+ case sugar (s)
+ switch s
+ case 'dlimport
+ name l := try
+ 'decons l
+ else
+ 'complain self aid "name missing"
+ name aid := unpack name
+ downcast... name
+ case ParserDB.Id.String (strid)
+ str := share (self.db.string @ strid . data)
+ return
+ Value.id
+ 'dlimport self.builder str
+ default
+ 'complain self aid "string expected"
+ case 'fntype
+ cconv l := 'decons-cconv self env aid l
+ rtype l := 'decons-return-type self env aid l
+ local types : Array Module.Id.CElementType
+ loop (l)
+ if (empty? l)
+ break;
+ T l := 'decons-element-type self env aid l
+ 'append types T
+ l
+ Value.id
+ 'fntype-indirect self.builder cconv rtype types
+ default
+ report s
+ assert false
+ default
+ report head
+ assert false
+ #do
+ 'complain self aid "cannot translate expression"
fn expand (self env expr)
viewing self env
+ returning Value
id aid := unpack expr
downcast... id
case ParserDB.Id.Symbol (symid)
try
- 'get env symid
- ;
+ copy ('get env symid)
else
'complain self aid "unknown symbol"
-
case ParserDB.Id.String (strid)
str := share (self.db.string @ strid . data)
- 'intern self.builder str
+ Value.id
+ 'intern self.builder str
case ParserDB.Id.List (lid)
- print lid
+ l := self.db.list @ lid . items
+ if (empty? l)
+ 'complain self aid "empty expression"
+ count := countof l
+ if (count >= 3)
+ tok := unpack (l @ 1)
+ downcast... tok
+ case ParserDB.Id.Symbol (symid)
+ # <name> = <expr>
+ if (symid == self.assign_token)
+ head := unpack (l @ 0)
+ downcast... head
+ case ParserDB.Id.Symbol (headid)
+ value := if (count == 3)
+ 'expand self env (copy (l @ 2))
+ else
+ 'expand-list self env aid ('offset l 2)
+ 'set env headid value
+ return value
+ default;
+ default;
+ 'expand-list self env aid l
default
assert false
fn expand-toplevel (self expr)
viewing self
- local env : PMap ParserDB.Id.Symbol Module.Id
+ local env : Env
+ va-map
+ inline (field)
+ 'set env
+ 'symbol @self.db (field.Name as zarray)
+ Value.op
+ getattr Module.Operation field.Name
+ Module.Operation.__fields__
+ va-map
+ inline (field)
+ 'set env
+ 'symbol @self.db (field.Name as zarray)
+ Value.cconv
+ getattr CallConv field.Name
+ CallConv.__fields__
+ va-map
+ inline (field)
+ 'set env
+ 'symbol @self.db (field.Name as zarray)
+ Value.id
+ 'wrap Module.Id.CUnit
+ getattr CUnitKind field.Name
+ CUnitKind.__fields__
+ va-map
+ inline (field)
+ 'set env
+ 'symbol @self.db (field.Name as zarray)
+ Value.id
+ 'wrap Module.Id.CRetUnit
+ getattr CRetUnitKind field.Name
+ CRetUnitKind.__fields__
+ va-map
+ inline (field)
+ 'set env
+ 'symbol @self.db (field.Name as zarray)
+ Value.sugar
+ getattr Sugar field.Name
+ Sugar.__fields__
for expr in ('iterlist self expr)
expand self env expr
@@ 86,6 259,9 @@ fn init (c_main argc argv)
'expand-toplevel ctx tl
+ print
+ /module @ctx.builder._module
+
0
#
path := argv @ 1