diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp index f4e7d0ae665e2458ea2d28d8f193cf2e4484006a..a0df30aad33383d254b2f046ad27f02e2b304304 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 cbe98e867727ea030e113e9bff36a37d130c1c02..9db4b595de1c96a1717dafde2a7942bded2a829d 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)