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