From 3b8bd8385a96685faeb26da60d9394feafb79907 Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Thu, 31 Jul 2014 16:52:39 -0700
Subject: [PATCH] Fix ticket ##104: Source location for define-condition

This is the patch from the ticket except that the boot file name has
been changed to conform to the usual naming rules.

To test it, try (c::info :source-location :class 'error). This should
return something like

#S(C::FILE-SOURCE-LOCATION :FORM-NUMBERS 52 :PATHNAME "target:code/error.lisp")

Notes:
* compiler/globaldb.lisp: New info-type source-location/class.  As
class names can theoretically also be variable names it seemed
reasonable to introduce this instead of using the existing
source-location/defvar.

* code/error.lisp (%compiler-define-condition): Take
source-location as argument and store it in the infodb.
(define-condition): Pass source-location along.

* bootfiles/20e/boot-2014-06-1.lisp: New bootfile needed
because error.lisp is compiled before globaldb.lisp.
---
 src/bootfiles/20e/boot-2014-06-1.lisp | 4 ++++
 src/code/error.lisp                   | 9 ++++++---
 src/compiler/globaldb.lisp            | 4 ++++
 3 files changed, 14 insertions(+), 3 deletions(-)
 create mode 100644 src/bootfiles/20e/boot-2014-06-1.lisp

diff --git a/src/bootfiles/20e/boot-2014-06-1.lisp b/src/bootfiles/20e/boot-2014-06-1.lisp
new file mode 100644
index 000000000..8b1dca579
--- /dev/null
+++ b/src/bootfiles/20e/boot-2014-06-1.lisp
@@ -0,0 +1,4 @@
+;; Define source-location/class info type so that code/error.lisp can
+;; be compiled.
+(in-package c)
+(define-info-type source-location class (or form-numbers null) nil)
diff --git a/src/code/error.lisp b/src/code/error.lisp
index 3fc7f815b..ee44212c1 100644
--- a/src/code/error.lisp
+++ b/src/code/error.lisp
@@ -597,7 +597,7 @@
 ;;;; DEFINE-CONDITION
 
 (eval-when (compile load eval)
-(defun %compiler-define-condition (name direct-supers layout)
+(defun %compiler-define-condition (name direct-supers layout source-location)
   (multiple-value-bind (class old-layout)
 		       (insured-find-class name #'condition-class-p
 					   #'make-condition-class)
@@ -625,7 +625,9 @@
     ;; Initialize CPL slot.
     (setf (condition-class-cpl class)
 	  (remove-if-not #'condition-class-p 
-			 (std-compute-class-precedence-list class))))
+			 (std-compute-class-precedence-list class)))
+
+    (setf (info :source-location :class name) source-location))
   (undefined-value))
 
 ); eval-when (compile load eval)
@@ -872,7 +874,8 @@
 
       `(progn
 	 (eval-when (compile load eval)
-	   (%compiler-define-condition ',name ',parent-types ',layout))
+	   (%compiler-define-condition ',name ',parent-types ',layout
+				       (c::source-location)))
 
 	 (declaim (ftype (function (t) t) ,@(all-readers)))
 	 (declaim (ftype (function (t t) t) ,@(all-writers)))
diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index ae7b565ed..8d182c834 100644
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -1174,6 +1174,10 @@
 ;;; location for defstruct and deftype.
 (define-info-class source-location)
 (define-info-type source-location defvar (or form-numbers null) nil)
+;; This is used for define-condition.  It could also be used for
+;; defclass but PCL classes already have a "definition-source" slot and we
+;; store it there.
+(define-info-type source-location class (or form-numbers null) nil)
 
 ;; The textdomain for the documentation
 (define-info-type function textdomain (or string null) nil)
-- 
GitLab