Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/pcl boot.lisp,1.44,1.45 generic-functions.lisp,1.9,1.10 gray-streams.lisp,1.7,1.8 macros.lisp,1.15,1.16
|
From: William H. N. <wn...@us...> - 2002-08-14 18:23:01
|
Update of /cvsroot/sbcl/sbcl/src/pcl
In directory usw-pr-cvs1:/tmp/cvs-serv14088/src/pcl
Modified Files:
boot.lisp generic-functions.lisp gray-streams.lisp macros.lisp
Log Message:
0.7.6.23:
merged APD patch for bugs 191-b (making gf lambda lists
conform to ANSI 3.4.2) from sbcl-devel
added tests, and fixed old tests whose brokenness is now
detected
(speculated about reusing SB-C:PARSE-LAMBDA-LIST instead of
adding new PROCESS-LAMBDA-LIST, but didn't actually
actually do that, in favor of checking in something
that works and fixes a bug. Maybe next version...)
reverted handling of illegal function name in DEFGENERIC
(from previous commit) since I guess it should be
PROGRAM-ERROR after all
Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -d -r1.44 -r1.45
--- boot.lisp 14 Aug 2002 13:16:12 -0000 1.44
+++ boot.lisp 14 Aug 2002 18:22:58 -0000 1.45
@@ -157,7 +157,11 @@
(defmacro defgeneric (fun-name lambda-list &body options)
(declare (type list lambda-list))
- (legal-fun-name-or-type-error fun-name)
+ (unless (legal-fun-name-p fun-name)
+ (error 'simple-program-error
+ :format-control "illegal generic function name ~S"
+ :format-arguments (list fun-name)))
+ (check-gf-lambda-list lambda-list)
(let ((initargs ())
(methods ()))
(flet ((duplicate-option (name)
@@ -228,6 +232,29 @@
:lambda-list lambda-list
:definition-source `((defgeneric ,fun-name) ,*load-truename*)
initargs))
+
+;;; As per section 3.4.2 of the ANSI spec, generic function lambda
+;;; lists have a number of limitations, which we check here.
+(defun check-gf-lambda-list (lambda-list)
+ (macrolet ((ensure (condition)
+ `(unless ,condition
+ (error "Invalid argument ~S in the generic function lambda list ~S."
+ it lambda-list))))
+ (process-lambda-list lambda-list
+ (&required (ensure (symbolp it)))
+ (&optional (ensure (or (symbolp it)
+ (and (consp it) (symbolp (car it)) (null (cdr it))))))
+ (&rest (ensure (symbolp it)))
+ (&key (ensure (or (symbolp it)
+ (and (consp it)
+ (or (symbolp (car it))
+ (and (consp (car it))
+ (symbolp (caar it))
+ (symbolp (cadar it))
+ (null (cddar it))))
+ (null (cdr it))))))
+ ((&aux (error "&AUX is not allowed in the generic function lambda list ~S."
+ lambda-list))))))
(defmacro defmethod (&rest args &environment env)
(multiple-value-bind (name qualifiers lambda-list body)
Index: generic-functions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/generic-functions.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- generic-functions.lisp 6 Jun 2002 12:32:13 -0000 1.9
+++ generic-functions.lisp 14 Aug 2002 18:22:58 -0000 1.10
@@ -440,12 +440,12 @@
(defgeneric get-method (generic-function
qualifiers
specializers
- &optional (errorp t)))
+ &optional errorp))
(defgeneric find-method (generic-function
qualifiers
specializers
- &optional (errorp t)))
+ &optional errorp))
(defgeneric remove-named-method (generic-function-name
argument-specifiers
Index: gray-streams.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/gray-streams.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- gray-streams.lisp 31 Oct 2001 19:42:57 -0000 1.7
+++ gray-streams.lisp 14 Aug 2002 18:22:58 -0000 1.8
@@ -288,7 +288,7 @@
(defmethod stream-start-line-p ((stream fundamental-character-output-stream))
(eql (stream-line-column stream) 0))
-(defgeneric stream-write-string (stream string &optional (start 0) end)
+(defgeneric stream-write-string (stream string &optional start end)
#+sb-doc
(:documentation
"This is used by WRITE-STRING. It writes the string to the stream,
Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/macros.lisp,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -d -r1.15 -r1.16
--- macros.lisp 23 Jan 2002 23:13:14 -0000 1.15
+++ macros.lisp 14 Aug 2002 18:22:58 -0000 1.16
@@ -255,5 +255,67 @@
`(setf ,name))
(defsetf slot-value set-slot-value)
+
+(defun misplaced-lambda-list-keyword (lambda-list keyword)
+ (error "Lambda list keyword ~S is misplaced in ~S." keyword lambda-list))
+
+(defmacro process-lambda-list (lambda-list &rest clauses)
+ ;; (process-lambda-list '(a b &optional (c 1))
+ ;; (&required)
+ ;; ((&optional (print "Started processing optional arguments"))
+ ;; (format "Optional argument: ~S~%" it))
+ ;; (&rest (print "Rest")))
+ (let ((clauses (loop for clause in clauses
+ collect
+ (cond ((symbolp (car clause))
+ `(,(car clause) nil . ,(cdr clause)))
+ ((consp (car clause))
+ `(,(caar clause) ,(cdar clause) . ,(cdr clause)))
+ (t (error "Invalid clause format: ~S." clause)))))
+ (ll (gensym "LL"))
+ (state (gensym "STATE"))
+ (restp (gensym "RESTP"))
+ (check-state (gensym "CHECK-STATE")))
+ `(let ((,ll ,lambda-list)
+ (,state '&required)
+ (,restp nil))
+ (dolist (it ,ll)
+ (flet ((,check-state (possible)
+ (unless (memq ,state possible)
+ (misplaced-lambda-list-keyword ,ll it))))
+ (cond ((memq it lambda-list-keywords)
+ (case it
+ (&optional (,check-state '(&required))
+ ,@(cadr (assoc '&optional clauses)))
+ (&rest (,check-state '(&required &optional))
+ ,@(cadr (assoc '&rest clauses)))
+ (&key (,check-state '(&required &optional &rest))
+ (when (and (eq ,state '&rest)
+ (not ,restp))
+ (error "Omitted &REST variable in ~S." ,ll))
+ ,@(cadr (assoc '&key clauses)))
+ (&allow-other-keys (,check-state '(&key))
+ ,@(cadr (assoc '&allow-other-keys clauses)))
+ (&aux (when (and (eq ,state '&rest)
+ (not ,restp))
+ (error "Omitted &REST variable in ~S." ,ll))
+ ,@(cadr (assoc '&aux clauses)))
+ (t (error "Unsupported lambda list keyword ~S in ~S."
+ it ,ll)))
+ (setq ,state it))
+ (t (case ,state
+ (&required ,@(cddr (assoc '&required clauses)))
+ (&optional ,@(cddr (assoc '&optional clauses)))
+ (&rest (when ,restp
+ (error "Too many variables after &REST in ~S." ,ll))
+ (setq ,restp t)
+ ,@(cddr (assoc '&rest clauses)))
+ (&key ,@(cddr (assoc '&key clauses)))
+ (&allow-other-keys (error "Variable ~S after &ALLOW-OTHER-KEY in ~S."
+ it ,ll))
+ (&aux ,@(cddr (assoc '&aux clauses))))))))
+ (when (and (eq ,state '&rest)
+ (not ,restp))
+ (error "Omitted &REST variable in ~S." ,ll)))))
(/show "finished with pcl/macros.lisp")
|