From 5a61c4eec91e251a7e3aa059ba072075b1a320e1 Mon Sep 17 00:00:00 2001
From: Kartik Singh <kssingh@hrl.com>
Date: Mon, 29 Jul 2024 08:32:23 -0700
Subject: [PATCH] Add errors and conditions

---
 src/conditions.lisp | 101 ++++++++++++++++++++++++++++++++++++++++++++
 src/errors.lisp     |  74 ++++++++++++++++++++++++++++++++
 2 files changed, 175 insertions(+)
 create mode 100644 src/conditions.lisp
 create mode 100644 src/errors.lisp

diff --git a/src/conditions.lisp b/src/conditions.lisp
new file mode 100644
index 0000000..8e90e5b
--- /dev/null
+++ b/src/conditions.lisp
@@ -0,0 +1,101 @@
+(in-package #:sbcl-librarian)
+
+(defvar *print-backtrace-in-bug* nil)
+
+(define-condition lisp-error (cl:error)
+  ((reason :initarg :reason
+           :accessor lisp-error-reason)
+   (args :initarg :args
+         :accessor lisp-error-args))
+  (:report (lambda (c s)
+             (with-slots (reason args) c
+               (let ((*print-circle* nil))
+                 (format s "Lisp Error: ~?" reason args))))))
+
+(declaim (inline error))
+(defun error (reason &rest args)
+  (declare (type string reason))
+  (cl:error 'lisp-error
+            :reason reason
+            :args args))
+
+(define-condition lisp-warning (style-warning)
+  ((reason :initarg :reason
+           :accessor lisp-warning-reason)
+   (args :initarg :args
+         :accessor lisp-warning-args))
+  (:report (lambda (c s)
+             (with-slots (reason args) c
+               (let ((*print-circle* nil))
+                 (format s "Lisp Warning: ~?" reason args))))))
+
+(declaim (inline warning))
+(defun warning (reason &rest args)
+  (cl:warn 'lisp-warning
+           :reason reason
+           :args args))
+
+(define-condition lisp-bug (cl:error)
+  ((reason :initarg :reason
+           :accessor lisp-bug-reason)
+   (args :initarg :args
+         :accessor lisp-bug-args)
+   (backtrace :initarg :backtrace
+              :accessor lisp-bug-backtrace
+              :initform (error "backtrace is required"))
+   (context :initform (list)
+            :accessor lisp-bug-context))
+  (:report (lambda (c s)
+             (with-slots (reason args backtrace context) c
+               (let ((*print-circle* nil))
+                 (format s "Internal lisp bug: ~?~%
+If you are seeing this, please file an issue on Gitlab and include this error message in the description.
+~A
+
+Context:
+~{  ~{~A~^: ~}~%~}
+~A"
+                         reason
+                         args
+                         *gitlab-issue-url*
+                         context
+                         (if *print-backtrace-in-bug*
+                             backtrace
+                             "")))))))
+
+(declaim (inline bug))
+(defun bug (reason &rest args)
+  (declare (type string reason))
+  (cl:error 'lisp-bug
+            :reason reason
+            :args args
+            :backtrace (with-output-to-string (s)
+                         (sb-debug:print-backtrace
+                          :stream s
+                          :start 1      ; Don't show the `bug' call
+                          :emergency-best-effort t))))
+
+(declaim (inline unreachable))
+(defun unreachable ()
+  (bug "unreachable"))
+
+(defmacro with-bug-context (context &body body)
+  `(handler-bind
+       ((lisp-bug
+          (lambda (c)
+            (declare (ignorable c))
+            ,@(mapcar (lambda (ctx)
+                        (cl:assert (= 2 (length ctx)))
+                        `(push (list ,@ctx) (lisp-bug-context c)))
+                      context))))
+     ,@body))
+
+(defmacro assert (test-form &optional places datum arguments)
+  (let ((sym (gensym)))
+    `(with-bug-context (,@(mapcar (lambda (place)
+                                    `(,(format nil "~S" place) ,place))
+                                  places))
+       (let ((,sym ,test-form))
+         (unless ,sym
+           (bug ,(or datum "The assertion ~S failed")
+                ,@(if datum arguments `(',test-form))))))))
diff --git a/src/errors.lisp b/src/errors.lisp
new file mode 100644
index 0000000..1ca0c19
--- /dev/null
+++ b/src/errors.lisp
@@ -0,0 +1,74 @@
+(in-package #:sbcl-librarian)
+
+(define-enum-type error-type "lisp_err_t"
+  ("LISP_ERR_SUCCESS" 0)
+  ("LISP_ERR_FAILURE" 1)
+  ("LISP_ERR_BUG" 2)
+  ("LISP_ERR_FATAL" 3))
+
+(defvar *error-message* ""
+  "The most recent error message.")
+
+(defun get-error-message ()
+  *error-message*)
+
+(defvar *show-backtrace* nil)
+
+(defun enable-backtrace (code)
+  (setf *show-backtrace* (not (zerop code))))
+
+(defun crash ()
+  (error "oops"))
+
+(defun exhaust-heap ()
+  (sb-sys:without-gcing
+    (let ((test '()))
+      (loop (push 1 test)))))
+
+(define-error-map default-error-map error-type (:no-error 0 :fatal-error 3)
+  ((warning #'continue)
+
+   (sbcl-librarian:lisp-error
+    (lambda (c)
+      (when *show-backtrace*
+	(sb-debug:print-backtrace
+         :stream *error-output*
+         :emergency-best-effort t))
+      (setf *error-message* (format nil "~A" c))
+      (return-from default-error-map 1)))
+
+   (sbcl-librarian:lisp-bug
+    (lambda (c)
+      (when *show-backtrace*
+        (sb-debug:print-backtrace
+         :stream *error-output*
+         :emergency-best-effort t))
+
+      (let ((sbcl-librarian:*print-backtrace-in-bug* t))
+        (setf *error-message* (format nil "~A" c)))
+
+      (return-from default-error-map 2)))
+
+   (error
+    (lambda (c)
+      (let ((bug (make-instance 'sbcl-librarian:lisp-bug
+                                :reason (format nil "~A" c)
+                                :args nil
+                                :backtrace (with-output-to-string (s)
+                                             (sb-debug:print-backtrace
+                                              :stream s
+                                              :emergency-best-effort t)))))
+
+        (let ((sbcl-librarian:*print-backtrace-in-bug* t))
+          (setf *error-message* (format nil "~A" bug)))
+
+        (return-from default-error-map 2))))))
+
+(sbcl-librarian:define-api errors (:error-map default-error-map)
+  (:literal "/* lisp */")
+  (:type error-type)
+  (:function
+   (get-error-message :string ())
+   (enable-backtrace :void ((on :int)))
+   (crash :void ())
+   (exhaust-heap :void ())))