Skip to content
Snippets Groups Projects
Commit a1a66688 authored by gerd's avatar gerd
Browse files

Generalized function names.

	* code/fdefinition.lisp (*valid-function-names*): New variable.
	(%define-function-name-syntax, valid-function-name-p): New
	functions.
	(define-function-name-syntax): New macro.
	(toplevel): Define the syntax of setf function names.
	(fdefinition-object): Use valid-function-name-p.

	* compiler/proclaim.lisp (check-function-name): Use
	valid-function-name-p.

	* compiler/ir1tran.lisp (function): Use valid-function-name-p.

	* code/profile.lisp (%report-times): Use valid-function-name-p.

	* code/macros.lisp (defun): Use valid-function-name-p.

	* code/eval.lisp (eval): Use valid-function-name-p.

	* code/describe.lisp (describe-aux, describe-function-name):
	Use valid-function-name-p.

	* code/exports.lisp ("EXTENSIONS"): Add
	define-function-name-syntax and valid-function-name-p.
parent c4050a82
No related branches found
No related tags found
No related merge requests found
......@@ -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))
......
......@@ -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)
......
......@@ -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"
......
......@@ -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)
......
......@@ -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
......
......@@ -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)))
......
......@@ -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))))
......
......@@ -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
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment