Added a way for user code to signal their own errors. Also, better li…

…nting.

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)))

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
 

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))

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)))

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

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)

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

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")))