From c4827066097ae076b47302a267ba867e51823ed7 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sun, 18 May 2003 18:09:31 +0000 Subject: [PATCH] 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. --- pcl/boot.lisp | 33 ++++++++++++--------------------- pcl/low.lisp | 45 ++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 56 insertions(+), 22 deletions(-) diff --git a/pcl/boot.lisp b/pcl/boot.lisp index f1135c8a2..e514a0849 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (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) @@ -171,15 +171,13 @@ work during bootstrapping. ;;; (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. (multiple-value-bind (required optional restp rest keyp keys - allow-other-keys-p aux morep - more-context more-count) - (kernel:parse-lambda-list lambda-list) + allow-other-keys-p aux) + (parse-lambda-list lambda-list) (values required optional restp rest keyp keys allow-other-keys-p - (or aux (member '&aux lambda-list :test #'eq)) aux - morep more-context more-count))) + (or aux (member '&aux lambda-list :test #'eq)) aux))) (defun check-generic-function-lambda-list (function-specifier lambda-list) (multiple-value-bind (required optional restp rest keyp keys @@ -405,9 +403,9 @@ work during bootstrapping. (let ((initargs-form (make-method-initargs-form proto-gf proto-method method-function-lambda initargs env))) - (tell-compiler-about-gf name lambda-list) + (tell-compiler-about-gf name unspecialized-lambda-list) `(progn - (proclaim-defgeneric ',name ',lambda-list) + (proclaim-defgeneric ',name ',unspecialized-lambda-list) ,(make-defmethod-form name qualifiers specializers unspecialized-lambda-list (if proto-method @@ -1265,13 +1263,9 @@ work during bootstrapping. (defun analyze-lambda-list (lambda-list) (multiple-value-bind (required optional restp rest keyp keys - allow-other-keys-p aux morep - more-context more-count) - (kernel:parse-lambda-list lambda-list) - (declare (ignore rest aux more-context more-count)) - (when morep - (simple-program-error "Lambda list keyword ~s not allowed here." - '&more)) + allow-other-keys-p aux) + (parse-lambda-list lambda-list t) + (declare (ignore rest aux)) (flet ((keyword-parameter-keyword (x) (let ((key (if (atom x) x (car x)))) (if (atom key) @@ -2191,12 +2185,9 @@ work during bootstrapping. (defun parse-specialized-lambda-list (lambda-list) (multiple-value-bind (required optional restp rest keyp keys - allow-other-keys-p aux morep - more-context more-count) - (kernel:parse-lambda-list lambda-list) + allow-other-keys-p aux) + (parse-lambda-list lambda-list t) (declare (ignore more-context more-count)) - (when morep - (error "~@<~s is not allowed in specialized lambda-lists~@:>" :more)) (collect ((req) (spec)) (dolist (x required) (req (if (consp x) (car x) x)) diff --git a/pcl/low.lisp b/pcl/low.lisp index 3fdf23bfa..0cfd04749 100644 --- a/pcl/low.lisp +++ b/pcl/low.lisp @@ -26,7 +26,7 @@ ;;; (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. @@ -336,6 +336,49 @@ the compiler as completely as possible. Currently this means that (defmacro slot-ref (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 ;;; fasl files. So, we need to create unbound markers in some way, -- GitLab