From a79a7c8a9c815958ccbe515ca66698dee4e8ff16 Mon Sep 17 00:00:00 2001 From: emarsden <emarsden> Date: Sun, 16 Feb 2003 19:05:19 +0000 Subject: [PATCH] Fix an assertion on function names when dumping minimal debug info to use VALID-FUNCTION-NAME-P, instead of checking for (setf xxx) names. Declare two new valid function name classes: names of the form (:macro foo) (:compiler-macro foo) that are now used to name lambda nodes in IR1. --- code/fdefinition.lisp | 11 ++++++++++- compiler/debug-dump.lisp | 9 ++++++--- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp index f4e7d0ae6..a0df30aad 100644 --- a/code/fdefinition.lisp +++ b/code/fdefinition.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.20 2003/02/05 11:08:44 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.21 2003/02/16 19:05:19 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -87,6 +87,15 @@ (unless (eq 'setf (car fn)) (valid-function-name-p fn))))))) +(define-function-name-syntax :macro (name) + (when (eql 2 (length name)) + (valid-function-name-p (second name)))) + +(define-function-name-syntax :compiler-macro (name) + (when (eql 2 (length name)) + (valid-function-name-p (second name)))) + + ;;;; Fdefinition (fdefn) objects. diff --git a/compiler/debug-dump.lisp b/compiler/debug-dump.lisp index cbe98e867..9db4b595d 100644 --- a/compiler/debug-dump.lisp +++ b/compiler/debug-dump.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.43 2003/02/06 14:25:58 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug-dump.lisp,v 1.44 2003/02/16 19:05:19 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -651,7 +651,11 @@ (let* ((name (compiled-debug-function-name dfun)) (setf-p (and (consp name) (eq (car name) 'setf) (consp (cdr name)) (symbolp (cadr name)))) - (base-name (if setf-p (cadr name) name)) + (base-name (if (stringp name) name + (multiple-value-bind (valid block-name) + (valid-function-name-p name) + (assert valid) + block-name))) (pkg (when (symbolp base-name) (symbol-package base-name))) (name-rep @@ -663,7 +667,6 @@ minimal-debug-function-name-symbol) (t minimal-debug-function-name-packaged)))) - (assert (or (stringp name) (valid-function-name-p name))) (let ((options 0)) (setf (ldb minimal-debug-function-name-style-byte options) name-rep) (setf (ldb minimal-debug-function-kind-byte options) -- GitLab