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

Paul Dietz' DEFGENERIC.ERROR.4. Check for repeated lambda

	variables.

	* src/pcl/boot.lisp (parse-generic-function-lambda-list)
	(analyze-lambda-list, parse-specialized-lambda-list):
	Use parse-lambda-list.
	(expand-defmethod): Proclaim the generic function using
	the unspecialized lambda list, not the method's specialized
	lambda list.

	* src/pcl/low.lisp (parse-lambda-list): New function.
parent f1455e42
No related branches found
No related tags found
No related merge requests found
...@@ -25,7 +25,7 @@ ...@@ -25,7 +25,7 @@
;;; ************************************************************************* ;;; *************************************************************************
(file-comment (file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.56 2003/05/18 12:23:21 gerd Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.57 2003/05/18 18:09:31 gerd Exp $")
(in-package :pcl) (in-package :pcl)
...@@ -171,15 +171,13 @@ work during bootstrapping. ...@@ -171,15 +171,13 @@ work during bootstrapping.
;;; ;;;
(defun parse-generic-function-lambda-list (lambda-list) (defun parse-generic-function-lambda-list (lambda-list)
;; This is like kernel:parse-lambda-list, but returns an additional ;; This is like PARSE-LAMBDA-LIST, but returns an additional
;; value AUXP which is true if LAMBDA-LIST contains any &aux keyword. ;; value AUXP which is true if LAMBDA-LIST contains any &aux keyword.
(multiple-value-bind (required optional restp rest keyp keys (multiple-value-bind (required optional restp rest keyp keys
allow-other-keys-p aux morep allow-other-keys-p aux)
more-context more-count) (parse-lambda-list lambda-list)
(kernel:parse-lambda-list lambda-list)
(values required optional restp rest keyp keys allow-other-keys-p (values required optional restp rest keyp keys allow-other-keys-p
(or aux (member '&aux lambda-list :test #'eq)) aux (or aux (member '&aux lambda-list :test #'eq)) aux)))
morep more-context more-count)))
(defun check-generic-function-lambda-list (function-specifier lambda-list) (defun check-generic-function-lambda-list (function-specifier lambda-list)
(multiple-value-bind (required optional restp rest keyp keys (multiple-value-bind (required optional restp rest keyp keys
...@@ -405,9 +403,9 @@ work during bootstrapping. ...@@ -405,9 +403,9 @@ work during bootstrapping.
(let ((initargs-form (make-method-initargs-form (let ((initargs-form (make-method-initargs-form
proto-gf proto-method proto-gf proto-method
method-function-lambda initargs env))) method-function-lambda initargs env)))
(tell-compiler-about-gf name lambda-list) (tell-compiler-about-gf name unspecialized-lambda-list)
`(progn `(progn
(proclaim-defgeneric ',name ',lambda-list) (proclaim-defgeneric ',name ',unspecialized-lambda-list)
,(make-defmethod-form name qualifiers specializers ,(make-defmethod-form name qualifiers specializers
unspecialized-lambda-list unspecialized-lambda-list
(if proto-method (if proto-method
...@@ -1265,13 +1263,9 @@ work during bootstrapping. ...@@ -1265,13 +1263,9 @@ work during bootstrapping.
(defun analyze-lambda-list (lambda-list) (defun analyze-lambda-list (lambda-list)
(multiple-value-bind (required optional restp rest keyp keys (multiple-value-bind (required optional restp rest keyp keys
allow-other-keys-p aux morep allow-other-keys-p aux)
more-context more-count) (parse-lambda-list lambda-list t)
(kernel:parse-lambda-list lambda-list) (declare (ignore rest aux))
(declare (ignore rest aux more-context more-count))
(when morep
(simple-program-error "Lambda list keyword ~s not allowed here."
'&more))
(flet ((keyword-parameter-keyword (x) (flet ((keyword-parameter-keyword (x)
(let ((key (if (atom x) x (car x)))) (let ((key (if (atom x) x (car x))))
(if (atom key) (if (atom key)
...@@ -2191,12 +2185,9 @@ work during bootstrapping. ...@@ -2191,12 +2185,9 @@ work during bootstrapping.
(defun parse-specialized-lambda-list (lambda-list) (defun parse-specialized-lambda-list (lambda-list)
(multiple-value-bind (required optional restp rest keyp keys (multiple-value-bind (required optional restp rest keyp keys
allow-other-keys-p aux morep allow-other-keys-p aux)
more-context more-count) (parse-lambda-list lambda-list t)
(kernel:parse-lambda-list lambda-list)
(declare (ignore more-context more-count)) (declare (ignore more-context more-count))
(when morep
(error "~@<~s is not allowed in specialized lambda-lists~@:>" :more))
(collect ((req) (spec)) (collect ((req) (spec))
(dolist (x required) (dolist (x required)
(req (if (consp x) (car x) x)) (req (if (consp x) (car x) x))
......
...@@ -26,7 +26,7 @@ ...@@ -26,7 +26,7 @@
;;; ;;;
(file-comment (file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.28 2003/05/13 10:16:58 gerd Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.29 2003/05/18 18:09:30 gerd Exp $")
;;; ;;;
;;; This file contains optimized low-level constructs for PCL. ;;; This file contains optimized low-level constructs for PCL.
...@@ -336,6 +336,49 @@ the compiler as completely as possible. Currently this means that ...@@ -336,6 +336,49 @@ the compiler as completely as possible. Currently this means that
(defmacro slot-ref (slots index) (defmacro slot-ref (slots index)
`(svref ,slots ,index)) `(svref ,slots ,index))
;;;
;;; Like KERNEL::PARSE-LAMBDA-LIST, but check for repeated lambda
;;; variable and &MORE.
;;;
(defun parse-lambda-list (lambda-list &optional specialized-p)
(multiple-value-bind (required optional restp rest keyp keys
allow-other-keys-p aux morep)
(kernel:parse-lambda-list lambda-list)
(when morep
(simple-program-error "~@<~s not allowed here~@:>" 'c:&more))
(collect ((vars))
(labels ((check-var (var)
(cond ((not (symbolp var))
(simple-program-error
"~@<Invalid lambda variable: ~s~@:>" var))
((memq var (vars))
(simple-program-error
"~@<Repeated lambda variable: ~s~@:>" var))
(t
(vars var))))
(check-required (var)
(if (and (consp var) specialized-p)
(check-var (car var))
(check-var var)))
(check-optional (var)
(if (consp var)
(destructuring-bind (var &optional value supplied-p)
var
(if (consp var)
(check-var (cadr var))
(check-var var))
(when supplied-p
(check-var supplied-p)))
(check-var var))))
(mapc #'check-required required)
(mapc #'check-optional optional)
(mapc #'check-optional keys)
(when restp (check-var rest))
(mapc #'check-optional aux)
(values required optional restp rest keyp keys
allow-other-keys-p aux)))))
;;; ;;;
;;; The problem with unbound markers is that they cannot be dumped to ;;; The problem with unbound markers is that they cannot be dumped to
;;; fasl files. So, we need to create unbound markers in some way, ;;; fasl files. So, we need to create unbound markers in some way,
......
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