diff --git a/harlan/front/expand-primitives.scm b/harlan/front/expand-primitives.scm index ec302cb..d940e3b 100644 --- a/harlan/front/expand-primitives.scm +++ b/harlan/front/expand-primitives.scm @@ -169,6 +169,8 @@ (expand-vec-comparison t r lhs rhs)) ((match ,t ,[e] (,p ,[e*]) ...) `(match ,t ,e (,p ,e*) ...)) + ((error! ,s) + `(call (var (fn () -> void) harlan_error) (str ,s))) ((,op ,t ,[lhs] ,[rhs]) (guard (or (relop? op) (binop? op))) `(,op ,lhs ,rhs))) diff --git a/harlan/front/lint.scm b/harlan/front/lint.scm index c8e55c6..11e641e 100644 --- a/harlan/front/lint.scm +++ b/harlan/front/lint.scm @@ -50,12 +50,29 @@ (if (eq? context 'expr) (match expr ((if ,t ,c) - (err expr "Two-armed if found in expression context. Try adding a case for if the test is false."))))) + (err expr "One-armed if found in expression context. Try adding a case for if the test is false."))))) + (define (check-error expr env context) + (match expr + ((error! ,s) + (unless (string? s) + (err expr "Error forms must take a string argument."))) + ((error! . ,_) + (err expr "Error must take one string argument.")))) + (define (check-expr expr env) - #f) + (match expr + ((,rator ,rand* ...) + (guard (assq rator env)) + ((cdr (assq rator env)) expr env 'expr)) + (,else #f))) - (define (check-stmt stmt env) #f) + (define (check-stmt stmt env) + (match stmt + ((,rator ,rand* ...) + (guard (assq rator env)) + ((cdr (assq rator env)) stmt env 'stmt)) + (,expr (check-expr expr env)))) (define (check-decl decl env context) (match decl @@ -84,7 +101,8 @@ name num-args (length a*)))))))) (define initial-env - `((if . ,check-if))) + `((if . ,check-if) + (error! . ,check-error))) ;; TODO: find a way to check if we have multiple top-level definitions diff --git a/harlan/front/parser.scm b/harlan/front/parser.scm index 1f75540..06fb4c1 100644 --- a/harlan/front/parser.scm +++ b/harlan/front/parser.scm @@ -166,6 +166,7 @@ x* x*^ s* e*))))) `(match ,e ((,tag ,x* ...) ,e*) ...))) + ((error! ,s) `(error! ,s)) ((,op ,[lhs] ,[rhs]) (guard (or (binop? op) (relop? op))) `(,op ,lhs ,rhs)) diff --git a/harlan/front/returnify.scm b/harlan/front/returnify.scm index 88f1167..b57efdf 100644 --- a/harlan/front/returnify.scm +++ b/harlan/front/returnify.scm @@ -30,6 +30,7 @@ ((while ,e ,[returnify-stmt -> s]) `(while ,e ,s)) ((return) `(return)) ((return ,expr) `(return ,expr)) + ((do (error! ,s)) `(do (error! ,s))) ((do ,expr) `(return ,expr)) ((begin ,stmt* ... ,[returnify-stmt -> stmt]) (make-begin `(,@stmt* ,stmt))) diff --git a/harlan/front/typecheck.scm b/harlan/front/typecheck.scm index 7987db4..2c0f723 100644 --- a/harlan/front/typecheck.scm +++ b/harlan/front/typecheck.scm @@ -527,6 +527,8 @@ (return (cons e^ e**^) t)))))) ((() () ()) (return '() (make-tvar (gensym 'tmatch)))))))) (return `(match ,t ,e ((,tag ,x* ...) ,e*) ...) t))))) + ((error! ,s) (guard (string? s)) + (return `(error! ,s) (gen-tvar 'error!))) ))) (define infer-body infer-expr) @@ -818,8 +820,8 @@ ((match ,[ground-type -> t] ,[e] ((,tag . ,x) ,[e*]) ...) `(match ,t ,e ((,tag . ,x) ,e*) ...)) - (,else (error 'ground-expr "Unrecognized expression" else)) - ))) + ((error! ,s) `(error! ,s)) + (,else (error 'ground-expr "Unrecognized expression" else))))) (define-match free-regions-expr ((var ,[free-regions-type -> t] ,x) t) @@ -880,7 +882,8 @@ (,p ,[e*]) ...) (apply union `(,t ,e . ,e*))) ((return) '()) - ((return ,[e]) e)) + ((return ,[e]) e) + ((error! ,s) '())) (define-match free-regions-type ;; This isn't fantastic... what if this later unifies to a type diff --git a/harlan/middle/annotate-free-vars.scm b/harlan/middle/annotate-free-vars.scm index 310bc15..569fd7e 100644 --- a/harlan/middle/annotate-free-vars.scm +++ b/harlan/middle/annotate-free-vars.scm @@ -12,7 +12,7 @@ (define-match annotate-decl* (((,tag* ,name* . ,rest*) ...) - (map (annotate-decl (append name* '(harlan_sqrt floor atan2))) + (map (annotate-decl (append name* '(harlan_sqrt floor atan2 harlan_error))) `((,tag* ,name* . ,rest*) ...)))) (define-match (annotate-decl globals) diff --git a/rt/harlan.hpp b/rt/harlan.hpp index 5b15b4d..85dcdde 100644 --- a/rt/harlan.hpp +++ b/rt/harlan.hpp @@ -53,7 +53,7 @@ void unmap_region(region *ptr); region_ptr alloc_in_region(region **r, unsigned int size); region_ptr alloc_vector(region **r, int item_size, int num_items); cl_mem get_cl_buffer(region *r); -void harlan_error(const char *msg); +void harlan_error(const char *msg) __attribute__((noreturn)); bool hstrcmp(const char *lhs, const char *rhs); #define __global diff --git a/test/error!.kfc b/test/error!.kfc new file mode 100644 index 0000000..5ea0c61 --- /dev/null +++ b/test/error!.kfc @@ -0,0 +1,7 @@ +(%testspec + (%tags failure) + (run-fail)) + +(module + (define (main) + (error! "this is to make sure Harlan's abort function works")))