carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-10-11 04:27:55 +03:00
Code Issues Projects Releases Wiki Activity

some help with finding location of type errors

Browse Source
This commit is contained in:
Erik Svedäng 2016-03-14 11:11:14 +01:00
parent b82d5027cb
commit 2053da5cb8
5 changed files with 77 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO.md
View File

@ -39,6 +39,7 @@
- Get inferior lisp to work
# Dynamic Runtime Small Features
- Want to be able to send Obj-arrays to ffi functions
- Allow map/filter/reduce to take arguments that are boxed void pointers to arrays
- Should be error when ptr of wrong type is sent to baked function
- Can send compiled ffi-function to another ffi-function that expects a struct

14
lisp/ast.carp
View File

@ -84,15 +84,17 @@
(let [evaled (eval x)]
(if (and (symbol? x) (macro? evaled))
(expand-macro l)
(app-to-ast x xs)))
(app-to-ast x xs))
(app-to-ast x xs l)))
(app-to-ast x xs l))
nil {:node :literal :type :any :value ""})))
(defn app-to-ast [x xs]
(defn app-to-ast [x xs original-form]
(do ;;(println (str "app-to-ast: " x ", " xs))
{:node :app
:type (gen-typevar)
:line (meta-get x :line)
:original-form original-form
:head (assoc (form-to-ast x) :type (gen-fn-type (count xs)))
:tail (map form-to-ast xs)}))
@ -147,6 +149,8 @@
(defn ref-to-ast [expr]
{:node :ref
:type (list :ref (gen-typevar))
:line (meta-get expr :line)
:original-form expr
:expr (form-to-ast expr)})
(defn reset-to-ast [symbol expr]
@ -161,9 +165,13 @@
(if (symbol? expr)
{:node :lookup
:type (gen-typevar)
:line (meta-get expr :line)
:original-form expr
:value expr} ;; change key to :name ..?
{:node :literal
:type (let [t (type expr)] (if (= :string t) '(:ref :string) t)) ; Literal strings are refs
:line (meta-get expr :line)
:original-form expr
:value expr}))
(defn is-struct-constructor? [form]

68
lisp/infer_types.carp
View File

@ -40,6 +40,15 @@
(def log-chaining false)
;; Generates a dictionary with location data used when type unification fails
(defn location [ast-a ast-b]
(do
;;(println (str "ast-a: " ast-a "\n" "ast-b: " ast-b))
{:a {:line (if (dict? ast-a) (get-maybe ast-a :line) "???")
:original-form (if (dict? ast-a) (get-maybe ast-a :original-form) "???")}
:b {:line (if (dict? ast-b) (get-maybe ast-b :line) "???")
:original-form (if (dict? ast-b) (get-maybe ast-b :original-form) "???")}}))
(defn generate-constraints-internal (constraints ast type-env)
(do
;;(println (str "gen constrs: \n" ast))
@ -60,7 +69,12 @@
(concat func-arg-constrs (cons func-ret-constr new-constraints)))
:app (let [ret-constr {:a (get ast :type) :b (get-in ast '(:head :type 2)) :doc "ret-constr for :app"}
arg-constrs (map2 (fn (a b) {:a a :b b :doc (str "app-arg " a " vs " b)}) (get-in ast '(:head :type 1)) (map :type (:tail ast)))
arg-constrs (map2 (fn (a b) {:a a
:b (:type b)
:location (location (:head ast) b)
:doc (str "app-arg " a " vs " b)})
(get-in ast '(:head :type 1))
(:tail ast))
head-constrs (generate-constraints-internal '() (:head ast) type-env)
tail-constrs (reduce (fn (constrs tail-form) (generate-constraints-internal constrs tail-form type-env))
'() (:tail ast))
@ -105,6 +119,7 @@
(error (str "Can't create constraint for lookup of '" val "', it's type is nil."))
(cons {:a (:type ast)
:b t
:location (location ast {:line "?" :original-form val})
:doc (str "lookup " val)} constraints)))))
:binop (let [x0 (generate-constraints-internal constraints (get ast :left) type-env)
@ -282,7 +297,9 @@
(do (when log-substs (println "Current binding do not match new value"))
(if (or (= :any lhs) (typevar? value-lookup))
substs
(error (str "Can't unify typevar \n\n" existing "\n\nwith\n\n" value-lookup "\n\nLocation: " (meta-get value :doc))))))))))))
:fail
;;(error (str "Can't unify typevar \n\n" existing "\n\nwith\n\n" value-lookup "\n\nLocation: " (meta-get value :doc)))
)))))))))
;; Not a typevar:
(if (list? lhs)
(let [value-lookup (lookup substs value)]
@ -298,27 +315,48 @@
(do (when log-substs (println (str "lhs " lhs " is not a tvar or list.")))
(if (or (= :any lhs) (= :any value-lookup) (= lhs value-lookup) (typevar? value-lookup))
substs
(error (str "Can't unify \n" lhs " with \n" value-lookup)))))))))
:fail
;;(error (str "Can't unify \n" lhs " with \n" value-lookup))
)))))))
(defn solve-list (substs a-list b-list)
(defn solve-list (substs a-list b-list constraint)
(match (list a-list b-list)
(() ()) substs
((a ... as) (b ... bs)) (solve (solve substs a b) as bs)
_ (error (str "Lists not matching: " a-list " - vs - " b-list ", substs: \n" substs))))
((a ... as) (b ... bs)) (solve (solve substs a b constraint) as bs constraint)
_ :fail ;;(error (str "Lists not matching: " a-list " - vs - " b-list ", substs: \n" substs))
))
(defn solve (substs a b)
(if (and (list? a) (list? b))
(solve-list substs a b)
(extend-substitutions substs a b)))
(defn solve (substs a b constraint)
(let [result (if (and (list? a) (list? b))
(if (= (count a) (count b))
(solve-list substs a b constraint)
:fail)
(extend-substitutions substs a b))]
(if (= :fail result)
(let [loc (get-maybe constraint :location)]
(if (nil? loc)
(error (str "Can't unify typevar \n\n" a "\n\nwith\n\n" b "\n\n"))
(error (str "Can't unify the types of \n\n"
"'"
(get-in loc '(:a :original-form))
"'"
" at line "
(get-in loc '(:a :line))
" of type " a
"\n\nwith\n\n"
"'"
(get-in loc '(:b :original-form))
"'"
" at line "
(get-in loc '(:b :line))
" of type " b
"\n"))))
result)))
(defn solve-contraint-internal (substs constraint)
(let [a (:a constraint)
b (:b constraint)]
(do
;; TODO: set meta earlier in process
(meta-set! a :doc (get-maybe constraint :doc))
(meta-set! b :doc (get-maybe constraint :doc))
(solve (solve substs a b) b a)))) ; Solving from both directions!
(solve (solve substs a b constraint) b a constraint))) ; Solving from both directions! TODO: is this needed?
;; Returns a substitution map from type variables to actual types
(defn solve-constraints (constraints)

14
out/project.carp
View File

@ -5,7 +5,15 @@
;;(load-gl)
;;(defn tricky-let [] ((id id) 2))
(defstruct Blahaha [x-man :int])
;; (defn h [a b]
;; (+ (strlen a)
;; (strlen b)))
(defn b [] (Blahaha 3))
(bake b)
;; (defn f []
;; (h 3 "b"))
;; (defn g []
;; (let [s (string-copy &"hej")]
;; (f s)))
;;(bake g)

2
src/primops.c
View File

@ -465,7 +465,7 @@ Obj *p_get_maybe(Obj** args, int arg_count) {
}
}
else if(args[0]->tag == 'C') {
if(args[1]->tag != 'I') { printf("get-maybe requires arg 1 to be an integer\n"); return nil; }
if(args[1]->tag != 'I') { eval_error = obj_new_string("get-maybe requires arg 1 to be an integer\n"); return nil; }
int i = 0;
int n = args[1]->i;
Obj *p = args[0];