diff --git a/code/describe.lisp b/code/describe.lisp index bfcd0195576a7ddb8681accda939b5f0d89ec2ea..30fd374bcd18ba2743138ac713445ab9e48a55c1 100644 --- a/code/describe.lisp +++ b/code/describe.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/describe.lisp,v 1.38 2002/12/07 18:21:22 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/describe.lisp,v 1.39 2003/02/05 11:08:45 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -112,8 +112,7 @@ (array (describe-array x)) (fixnum (describe-fixnum x)) (cons - (if (and (eq (car x) 'setf) (consp (cdr x)) (null (cddr x)) - (symbolp (cadr x)) + (if (and (valid-function-name-p x) (fboundp x)) (describe-function (fdefinition x) :function x) (default-describe x))) @@ -217,7 +216,7 @@ (*print-length* nil)) (multiple-value-bind (type where) - (if (or (symbolp name) (and (listp name) (eq (car name) 'setf))) + (if (valid-function-name-p name) (values (type-specifier (info function type name)) (info function where-from name)) (values type-spec :defined)) diff --git a/code/eval.lisp b/code/eval.lisp index b153b2931288f88e52a0c81a6f78916b2271ca38..a5ff923a9560e2acdd690b8bfa81fa3a02f2424a 100644 --- a/code/eval.lisp +++ b/code/eval.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/eval.lisp,v 1.34 2003/01/24 16:05:50 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/eval.lisp,v 1.35 2003/02/05 11:08:45 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -173,7 +173,7 @@ :format-arguments (list exp))) (let ((name (second exp))) (cond ((consp name) - (if (eq (car name) 'setf) + (if (valid-function-name-p name) (fdefinition name) (eval:make-interpreted-function name))) ((macro-function name) diff --git a/code/exports.lisp b/code/exports.lisp index b537f6333b4b150d496697dfb538b69c8f3e3ede..fb6681a67efb66101511fbde125c2e9aa20e8676 100644 --- a/code/exports.lisp +++ b/code/exports.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/exports.lisp,v 1.197 2003/01/26 22:09:38 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.198 2003/02/05 11:08:44 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1036,6 +1036,8 @@ "PURIFY" "MAP-APROPOS" "*BATCH-MODE*" "COMPILER-LET" + "DEFINE-FUNCTION-NAME-SYNTAX" + "VALID-FUNCTION-NAME-P" ;; Gray streams extension. "FUNDAMENTAL-BINARY-STREAM" "FUNDAMENTAL-BINARY-INPUT-STREAM" diff --git a/code/fdefinition.lisp b/code/fdefinition.lisp index 650f051eab79dbb544338426d7c6c2f8a63288cb..f4e7d0ae665e2458ea2d28d8f193cf2e4484006a 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.19 2001/12/10 02:53:16 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.20 2003/02/05 11:08:44 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -22,7 +22,8 @@ (in-package "EXTENSIONS") (export '(encapsulate unencapsulate encapsulated-p - basic-definition argument-list *setf-fdefinition-hook*)) + basic-definition argument-list *setf-fdefinition-hook* + define-function-name-syntax valid-function-name-p)) (in-package "KERNEL") @@ -36,6 +37,56 @@ (export '(fdefinition fboundp fmakunbound)) + +;;;; Function names. + +(defvar *valid-function-names* ()) + +(defun %define-function-name-syntax (name syntax-checker) + (let ((found (assoc name *valid-function-names* :test #'eq))) + (if found + (setf (cdr found) syntax-checker) + (setq *valid-function-names* + (acons name syntax-checker *valid-function-names*))))) + +(defmacro define-function-name-syntax (name (var) &body body) + "Define (NAME ...) to be a valid function name whose syntax is checked + by BODY. In BODY, VAR is bound to an actual function name of the + form (NAME ...) to check. BODY should return two values. + First value true means the function name is valid. Second value + is the name, a symbol, of the function for use in the BLOCK of DEFUNs + and in similar situations." + (let ((syntax-checker (symbolicate '%check- name '-function-name))) + `(progn + (defun ,syntax-checker (,var) ,@body) + (%define-function-name-syntax ',name #',syntax-checker)))) + +(defun valid-function-name-p (name) + "First value is true if NAME has valid function name syntax. + Second value is the name, a symbol, to use as a block name in DEFUNs + and in similar situations." + (typecase name + (cons + (when (and (symbolp (car name)) + (consp (cdr name))) + (let ((syntax-checker (cdr (assoc (car name) *valid-function-names* + :test #'eq)))) + (when syntax-checker + (funcall syntax-checker name))))) + (symbol (values t name)) + (otherwise nil))) + +(define-function-name-syntax setf (name) + (destructuring-bind (setf fn &rest rest) name + (declare (ignore setf)) + (when (null rest) + (typecase fn + (symbol + (values t fn)) + (cons + (unless (eq 'setf (car fn)) + (valid-function-name-p fn))))))) + ;;;; Fdefinition (fdefn) objects. @@ -83,13 +134,7 @@ "Return the fdefn object for NAME. If it doesn't already exist and CREATE is non-NIL, create a new (unbound) one." (declare (values (or fdefn null))) - (unless (or (symbolp name) - (and (consp name) - (eq (car name) 'setf) - (let ((cdr (cdr name))) - (and (consp cdr) - (symbolp (car cdr)) - (null (cdr cdr)))))) + (unless (valid-function-name-p name) (error 'simple-type-error :datum name :expected-type '(or symbol list) diff --git a/code/macros.lisp b/code/macros.lisp index 64eb8597a57b4039cd7f3d01301db8028f6c7931..c3243ecbd928155fe6929f6804d20c9709e9181a 100644 --- a/code/macros.lisp +++ b/code/macros.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/macros.lisp,v 1.85 2003/01/23 21:05:34 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.86 2003/02/05 11:08:43 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -301,13 +301,12 @@ ;;; lambda-list. ;;; (defmacro defun (&whole source name lambda-list &body (body decls doc)) - (let ((def `(lambda ,lambda-list - ,@decls - (block ,(if (and (consp name) (eq (car name) 'setf)) - (cadr name) - name) - ,@body)))) - `(c::%defun ',name #',def ,doc ',source))) + (multiple-value-bind (valid block-name) + (valid-function-name-p name) + (let ((def `(lambda ,lambda-list + ,@decls + (block ,block-name ,@body)))) + `(c::%defun ',name #',def ,doc ',source)))) ;;; %Defun, %%Defun -- Internal diff --git a/code/profile.lisp b/code/profile.lisp index 41379c4902144892c0c489fadae13b1490986c8d..9a523672c533f443b9d0c58a15a1d55aa4953c07 100644 --- a/code/profile.lisp +++ b/code/profile.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/profile.lisp,v 1.28 2003/01/26 22:09:02 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/profile.lisp,v 1.29 2003/02/05 11:08:43 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -720,15 +720,14 @@ this, the functions are listed. If NIL, then always list the functions.") "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" (sort no-call #'string< :key #'(lambda (n) - (cond ((symbolp n) - (symbol-name n)) - ((and (listp n) - (eq (car n) 'setf) - (consp (cdr n)) - (symbolp (cadr n))) - (symbol-name (cadr n))) - (t - (princ-to-string n)))))))) + (if (symbolp n) + (symbol-name n) + (multiple-value-bind (valid block-name) + (ext:valid-function-name-p n) + (declared (ignore valid)) + (if block-name + block-name + (princ-to-string n))))))))) (values))) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index bd008c59bea724f195b8bba72c040b21a5c15429..4a8d7e643aed9a4c64a16c0f35ceb08c0c18d452 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.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/ir1tran.lisp,v 1.135 2003/01/06 15:10:17 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.136 2003/02/05 11:08:42 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2441,17 +2441,17 @@ (case (car thing) ((lambda) (reference-leaf start cont (ir1-convert-lambda thing nil 'function))) - ((setf) - (let ((var (find-lexically-apparent-function - thing "as the argument to FUNCTION"))) - (reference-leaf start cont var))) ((instance-lambda) (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)) nil 'function))) (setf (getf (functional-plist res) :fin-function) t) (reference-leaf start cont res))) (t - (compiler-error "Illegal function name: ~S" thing))) + (if (valid-function-name-p thing) + (let ((var (find-lexically-apparent-function + thing "as the argument to FUNCTION"))) + (reference-leaf start cont var)) + (compiler-error "Illegal function name: ~S" thing)))) (let ((var (find-lexically-apparent-function thing "as the argument to FUNCTION"))) (reference-leaf start cont var)))) diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp index a3f530bb3ca08ec5856cabd49fe83626a87eab99..133debe3a82dc8c4164cdd31add0cd8b15743624 100644 --- a/compiler/proclaim.lisp +++ b/compiler/proclaim.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/proclaim.lisp,v 1.37 2002/07/22 17:02:43 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.38 2003/02/05 11:08:42 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -189,9 +189,7 @@ (defun check-function-name (name) (typecase name (list - (unless (and (consp name) (consp (cdr name)) - (null (cddr name)) (eq (car name) 'setf) - (symbolp (cadr name))) + (unless (valid-function-name-p name) (compiler-error "Illegal function name: ~S." name)) name) (symbol