Improve type compiler, implement pointers / arrays, structs

This commit is contained in:
Jeremy Penner 2023-12-02 16:01:30 -05:00
parent 2775b3cc4c
commit 28f0289a6b
2 changed files with 115 additions and 50 deletions

31
go.fnl
View file

@ -1,7 +1,28 @@
(local fennel (require :fennel)) (local fennel (require :fennel))
(import-macros {: terra : unterra : def : q} :terra) (import-macros {: terra : unterra : untype : def : q : ttype} :terra)
(local N 5) ; (local N 5)
(print (unterra (def [x int] (return (+ x N))))) ; (print (unterra
(local inc (def [x int] (return (+ x N)))) ; (def [x [int] : int64]
(print (inc 5)) ; (var y (+ x N))
; (return (cast int64 (& [y]))))))
(print (untype
{key int
:union {
string [int8]
number float
complex {real float imag float}
}
}))
(print (fennel.view (ttype
{key int
:union {
string [int8]
number float
complex {real float imag float}
}
})))
; (local inc (def [x [int]] (return [x N])))
; (print (inc 5))

134
terra.fnl
View file

@ -4,6 +4,9 @@
(let [str (tostring (gensym name))] (let [str (tostring (gensym name))]
(str:gsub "[^%w_]" #(string.format "_%02x" ($:byte))))) (str:gsub "[^%w_]" #(string.format "_%02x" ($:byte)))))
(fn kv-table? [tbl] ; this should be exported to macros but is not ;_;
(and (table? tbl) (not (sequence? tbl))))
(fn new-scope [] (fn new-scope []
{:locals {} {:locals {}
:env {} :env {}
@ -11,9 +14,12 @@
:push (fn [self] (set self.locals (setmetatable {} {:__index self.locals}))) :push (fn [self] (set self.locals (setmetatable {} {:__index self.locals})))
:pop (fn [self] (set self.locals (. (getmetatable self.locals) :__index))) :pop (fn [self] (set self.locals (. (getmetatable self.locals) :__index)))
:expr (fn [self expr] :expr (fn [self expr]
(let [name (safesym :inline-expr)] (if (and (sym? expr) (not (multi-sym? expr))) (self:env-ref expr)
(table.insert self.input {: name : expr}) (= (type expr) :number) (tostring expr)
name)) (= expr nil) :nil
(let [name (safesym :inline-expr)]
(table.insert self.input {: name : expr})
name)))
:env-ref (fn [self symbol] :env-ref (fn [self symbol]
(let [name (tostring symbol) (let [name (tostring symbol)
loc (. self.env name)] loc (. self.env name)]
@ -32,27 +38,30 @@
(tset self.locals name loc) (tset self.locals name loc)
loc))}) loc))})
(local comp {})
(local forms {}) (local forms {})
(fn commasep [list f] (fn commasep [list f]
(table.concat (icollect [_ v (ipairs list)] (f v)) ", ")) (table.concat (icollect [_ v (ipairs list)] (f v)) ", "))
(fn kvcommasep [tbl f]
(commasep (. (getmetatable tbl) :keys) #(f $1 (. tbl $1))))
(fn comp-expr [form scope] (fn comp.expr [form scope]
(case form (case form
(where [head & rest] (sym? head) (list? form) (. forms (tostring head))) (where [head & rest] (sym? head) (list? form) (. forms (tostring head)))
((. forms (tostring head)) rest scope) ((. forms (tostring head)) rest scope)
(where [head & rest] (sym? head) (list? form)) (where [head & rest] (list? form))
(.. (comp-expr head scope) "(" (commasep rest #(comp-expr $1 scope)) ")") (.. (comp.expr head scope) "(" (commasep rest #(comp.expr $1 scope)) ")")
(where [escape] (sequence? form)) (where [array] (sequence? form) (= (length form) 1))
(scope:expr escape) (.. "@" (comp.expr array scope))
(where str (= (type str) :string)) (where [array & indexes] (sequence? form))
(scope:expr str) (.. "(" (comp.expr array scope) ")" (table.concat (icollect [_ i (ipairs indexes)] (.. "[" (comp.expr i scope) "]"))))
(where num (= (type num) :number)) (where struct (kv-table? struct))
(tostring num) (.. "{ " (kvcommasep struct #(.. (tostring $1) " = " (comp.expr $2 scope))) " }")
(where multisym (multi-sym? multisym)) (where multisym (multi-sym? multisym))
(string.gsub (tostring multisym) "[^.:]+" #(scope:reference $1) 1) (string.gsub (tostring multisym) "[^.:]+" #(scope:reference $1) 1)
@ -60,60 +69,94 @@
(where symbol (sym? symbol)) (where symbol (sym? symbol))
(scope:reference symbol) (scope:reference symbol)
nil (where lit (or (= (type lit) :string) (= (type lit) :number) (= (type lit) :nil)))
"nil" (scope:expr lit)
_ (error (.. "Failed to parse expression: " (view form))))) _ (error (.. "Failed to parse expression: " (view form)))))
(fn comp-type [typ scope] (local type-constructors {})
(fn comp.type [typ scope]
(case typ (case typ
(where typlist (sequence? typlist)) (where [innertyp index] (sequence? typ))
(.. "{" (commasep typlist #(comp-type $1 scope)) "}") (.. "(" (comp.type innertyp scope) ")[" (comp.type index scope) "]")
(where [vec typ n] (list? typ) (= (type n) :number) (= vec (sym :vec))) (where [innertyp] (sequence? typ) (= (length typ) 1))
(.. "vector(" (comp-type typ scope) ", " (tostring n) ")") (.. "&" (comp.type innertyp scope))
(where tuple (list? tuple)) (where struct (kv-table? struct))
(.. "tuple(" (commasep tuple #(comp-type $1 scope)) ")") (.. "struct { " (kvcommasep struct #(comp.type-field $1 $2 scope)) " }")
(where [to in out] (list? typ) (= to (sym :->))) (where [head & args] (list? typ) (sym? head) (. type-constructors (tostring head)))
(.. (comp-type in scope) " -> " (comp-type out scope)) ((. type-constructors (tostring head)) args scope)
(where symbol (sym? symbol)) (where [head & args] (list? typ))
(tostring symbol) (.. (comp.type head scope) "(" (commasep args #(comp.type $1 scope)) ")")
(where symbol (= (type symbol) :string)) (where multisym (multi-sym? multisym))
symbol (string.gsub (tostring multisym) "[^.:]+" #(scope:reference $1) 1)
_ (scope:expr typ)))
(fn comp.type-field [name typ scope]
(case name
(where name (sym? name) (not (multi-sym? name)))
(.. (tostring name) " : " (comp.type typ scope))
_ (error (.. "Failed to parse type: " (view typ))))) :union
(.. "union { " (kvcommasep typ #(comp.type-field $1 $2 scope)) " }") ; unions shouldn't nest :/
_ (error (.. "Invalid field name: " (view name)))))
(fn arglist-type [arglist scope] (.. "{ " (commasep (or arglist []) #(comp.type $1 scope)) " }"))
(tset type-constructors :-> (fn [[in out] scope] (.. (arglist-type in scope) " -> " (arglist-type out scope))))
(tset type-constructors :& (fn [[typ] scope] (.. :& (comp.type typ scope))))
(tset type-constructors :$ (fn [typs scope] (.. "tuple(" (commasep typs #(comp.type $1 scope)) ")")))
(fn type-constructors.hashfn [[expr] scope] (scope:expr expr))
(fn forms.rawterra [[text] scope] text) (fn forms.rawterra [[text] scope] text)
(fn forms.var [[name typ] scope] (fn forms.var [defn scope]
(.. "var " (scope:addlocal name) " " (comp-type typ scope))) (case defn
[name typ initval] (.. "var " (scope:addlocal name) " : " (comp.type typ scope) " = " (comp.expr initval scope))
[name initval] (.. "var " (scope:addlocal name) " = " (comp.expr initval scope))))
(fn forms.do [stmts scope] (fn forms.do [stmts scope]
(scope:push) (scope:push)
(local lines (icollect [_ stmt (ipairs stmts)] (comp-expr stmt scope))) (local lines (icollect [_ stmt (ipairs stmts)] (comp.expr stmt scope)))
(scope:pop) (scope:pop)
(table.concat lines "\n")) (table.concat lines "\n"))
(fn find-ival [tbl pred]
(var ival nil)
(each [i val (ipairs tbl)]
(when (pred val) (set ival i)))
ival)
(fn forms.def [[arglist & stmts] scope] (fn forms.def [[arglist & stmts] scope]
(scope:push) (scope:push)
(let [argpairs (fcollect [i 1 (length arglist) 2] {:name (. arglist i) :type (. arglist (+ i 1))}) (let [iarg-return-sep (find-ival arglist #(and (sym? $1) (= (tostring $1) ":")))
_ (print (view argpairs)) argpairs (fcollect [i 1 (length arglist) 2 &until (= i iarg-return-sep)]
argdefs (commasep argpairs #(.. (scope:addlocal $1.name) " : " (comp-type $1.type scope))) {:name (. arglist i) :type (. arglist (+ i 1))})
fulldef (.. "terra (" argdefs ")\n" (forms.do stmts scope) "\nend")] rettyps (when iarg-return-sep (icollect [i typ (ipairs arglist)] (when (> i iarg-return-sep) typ)))
rettyp (if rettyps (.. ": { " (commasep rettyps #(comp.type $1 scope)) " }") "")
argdefs (commasep argpairs #(.. (scope:addlocal $1.name) " : " (comp.type $1.type scope)))
fulldef (.. "terra (" argdefs ")" rettyp "\n" (forms.do stmts scope) "\nend")]
(scope:pop) (scope:pop)
fulldef)) fulldef))
(fn forms.return [[expr] scope] (.. "return " (comp-expr expr scope))) (fn forms.predef [fntyp scope] (.. ))
(fn forms.return [[expr] scope] (.. "return " (comp.expr expr scope)))
(fn forms.cast [[typ expr] scope]
(.. "([" (comp.type typ scope)"](" (comp.expr expr scope) "))"))
(fn forms.hashfn [[expr] scope] (.. "([" (scope:expr expr) "])"))
(tset forms :& (fn [[expr] scope] (.. :& (comp.expr expr scope))))
(tset forms :$ (fn [items scope] (.. "{ " (commasep items #(comp.expr $1 scope)) " }")))
(fn def-infix [fnlop luaop] (fn def-infix [fnlop luaop]
(tset forms fnlop (fn [[left right] scope] (tset forms fnlop (fn [[left right] scope]
(.. "(" (comp-expr left scope) " " luaop " " (comp-expr right scope) ")")))) (.. "(" (comp.expr left scope) " " luaop " " (comp.expr right scope) ")"))))
(each [_ op (ipairs [:+ :- :* :/ :% :< :<= :> :>= :and :or :not :^ :<< :>>])] (each [_ op (ipairs [:+ :- :* :/ :% :< :<= :> :>= :and :or :not :^ :<< :>>])]
(def-infix op op)) (def-infix op op))
(fn forms.cast [[typ expr] scope]
(.. "([" (comp-type typ scope)"]" (comp-expr expr scope) ")"))
(def-infix := :==) (def-infix := :==)
(def-infix :not= "~=") (def-infix :not= "~=")
(def-infix :set :=) (def-infix :set :=)
@ -128,11 +171,12 @@
(icollect [_ {: expr} (ipairs scope.input) &into call] expr) (icollect [_ {: expr} (ipairs scope.input) &into call] expr)
call)) call))
(fn terra [expr] (build expr comp-expr)) (fn terra [expr] (build expr comp.expr))
(fn ttype [expr] (build expr comp-type)) (fn ttype [expr] (build expr comp.type))
(fn def [...] (terra `(,(sym :def) ,...))) (fn def [...] (terra `(,(sym :def) ,...)))
(fn q [...] (terra `(,(sym :quote) ,...))) (fn q [...] (terra `(,(sym :quote) ,...)))
(fn unterra [...] (view (macroexpand (terra ...)))) (fn unterra [...] (view (macroexpand (terra ...))))
(fn untype [...] (view (macroexpand (ttype ...))))
{: terra : ttype : def : q : unterra} {: terra : ttype : def : q : unterra : untype}