Skip to content
Snippets Groups Projects
Commit fe5959bd authored by emarsden's avatar emarsden
Browse files

Improve error checking of defmacro lambda-lists. Checking for compatible

number of arguments was being disabled in the presence of a dotted
lambda-list or when a &rest keyword is present. Change this so that the
test is only disabled for dotted lambda-lists. This modification fixes
a number of bugs in source-transforms used by the compiler, since the
macro lambda-list parsing code is used to determine whether a given
source-transform can be applied to the form being compiled. When
source-transforms were defined for functions with &rest parameters, the
macro-lambda-list checking was not signalling an error when an inappropriate
number of arguments were present in the form being compiled. This resulted
in inappropriate use of the source-transform.

This change reveals a problem in the gray-stream class definitions (now
fixed).
parent b93518a4
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.23 2002/11/02 23:18:21 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.24 2003/02/24 10:04:10 emarsden Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -100,7 +100,7 @@ ...@@ -100,7 +100,7 @@
(cond ((null rest-of-args) nil) (cond ((null rest-of-args) nil)
;; Varlist is dotted, treat as &rest arg and exit. ;; Varlist is dotted, treat as &rest arg and exit.
(t (push-let-binding rest-of-args path nil) (t (push-let-binding rest-of-args path nil)
(setf restp t)))) (setf restp :dotted))))
(let ((var (car rest-of-args))) (let ((var (car rest-of-args)))
(cond ((eq var '&whole) (cond ((eq var '&whole)
(cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
...@@ -252,7 +252,7 @@ ...@@ -252,7 +252,7 @@
(simple-program-error "Non-symbol in lambda-list - ~S." var))))) (simple-program-error "Non-symbol in lambda-list - ~S." var)))))
;; Generate code to check the number of arguments, unless dotted ;; Generate code to check the number of arguments, unless dotted
;; in which case length will not work. ;; in which case length will not work.
(unless restp (unless (eq restp :dotted)
(push `(unless (<= ,minimum (push `(unless (<= ,minimum
(length (the list ,(if top-level (length (the list ,(if top-level
`(cdr ,arg-list-name) `(cdr ,arg-list-name)
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
;;; the Public domain, and is provided 'as is'. ;;; the Public domain, and is provided 'as is'.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams-class.lisp,v 1.2 1998/06/02 02:43:15 dtc Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/gray-streams-class.lisp,v 1.3 2003/02/24 10:04:11 emarsden Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -23,25 +23,25 @@ ...@@ -23,25 +23,25 @@
(:documentation "Base class for all CLOS streams"))) (:documentation "Base class for all CLOS streams")))
;;; Define the stream classes. ;;; Define the stream classes.
(defclass fundamental-input-stream (fundamental-stream)) (defclass fundamental-input-stream (fundamental-stream) ())
(defclass fundamental-output-stream (fundamental-stream)) (defclass fundamental-output-stream (fundamental-stream) ())
(defclass fundamental-character-stream (fundamental-stream)) (defclass fundamental-character-stream (fundamental-stream) ())
(defclass fundamental-binary-stream (fundamental-stream)) (defclass fundamental-binary-stream (fundamental-stream) ())
(defclass fundamental-character-input-stream (defclass fundamental-character-input-stream
(fundamental-input-stream fundamental-character-stream)) (fundamental-input-stream fundamental-character-stream) ())
(defclass fundamental-character-output-stream (defclass fundamental-character-output-stream
(fundamental-output-stream fundamental-character-stream)) (fundamental-output-stream fundamental-character-stream) ())
(defclass fundamental-binary-input-stream (defclass fundamental-binary-input-stream
(fundamental-input-stream fundamental-binary-stream)) (fundamental-input-stream fundamental-binary-stream) ())
(defclass fundamental-binary-output-stream (defclass fundamental-binary-output-stream
(fundamental-output-stream fundamental-binary-stream)) (fundamental-output-stream fundamental-binary-stream) ())
;;; Example character input and output streams. ;;; Example character input and output streams.
......
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