From e3e7a3f8c1b35af4e16b13c9aa64c1748f81886f Mon Sep 17 00:00:00 2001 From: David Thompson Date: Wed, 25 Jan 2023 08:40:38 -0500 Subject: Add exception type for type errors. --- chickadee/graphics/seagull.scm | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index d1a90da..e1db052 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -1333,7 +1333,7 @@ (define (unify:primitives a b success) (if (equal? a b) (success '()) - (unify:fail "type mismatch" a b))) + (unify:fail "primitive type mismatch" a b))) (define (unify:variable a b success) (cond @@ -1579,6 +1579,15 @@ (resolve:list exps env)) (_ exp))) +(define &seagull-type-error + (make-exception-type '&seagull-type-error &error '())) + +(define make-seagull-type-error + (record-constructor &seagull-type-error)) + +;; TODO: Add some kind of context object that is threaded through the +;; inference process so that when a type error occurs we can show the +;; expression that caused it. (define (infer-types exp stage) (call-with-unify-rollback (lambda () @@ -1587,8 +1596,15 @@ '() (lambda (subs) (resolve annotated subs))))) - (lambda args - (apply error args)))) + (match-lambda* + ((msg . args) + (raise-exception + (make-exception + (make-seagull-type-error) + (make-exception-with-origin infer-types) + (make-exception-with-message + (format #f "seagull type error: ~a" msg)) + (make-exception-with-irritants args))))))) ;;; -- cgit v1.2.3