Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1:/tmp/cvs-serv16758/src/code
Modified Files:
defboot.lisp early-extensions.lisp eval.lisp macros.lisp
package.lisp parse-body.lisp parse-defmacro.lisp
primordial-extensions.lisp seq.lisp typedefs.lisp
Log Message:
0.8.3.3:
revised PARSE-BODY to eliminate bogus style-warning for
(MACROLET (...) (DECLAIM ...))
Since there are now two optional flags, use &KEY args instead
of trying to remember the position of &OPTIONAL args.
code-sharing in PROG and PROG*
'Twas passing strange passing ENV as the second argument
to PARSE-BODY in ADD-METHOD-DECLARATIONS...
new old BUGS (dunno why I discovered both on the same day)
Index: defboot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defboot.lisp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- defboot.lisp 16 Jun 2003 14:18:17 -0000 1.35
+++ defboot.lisp 26 Aug 2003 13:21:18 -0000 1.36
@@ -105,19 +105,17 @@
;;;; various sequencing constructs
-(defmacro-mundanely prog (varlist &body body-decls)
- (multiple-value-bind (body decls) (parse-body body-decls nil)
- `(block nil
- (let ,varlist
- ,@decls
- (tagbody ,@body)))))
-
-(defmacro-mundanely prog* (varlist &body body-decls)
- (multiple-value-bind (body decls) (parse-body body-decls nil)
- `(block nil
- (let* ,varlist
- ,@decls
- (tagbody ,@body)))))
+(flet ((prog-expansion-from-let (varlist body-decls let)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
+ `(block nil
+ (,let ,varlist
+ ,@decls
+ (tagbody ,@body))))))
+ (defmacro-mundanely prog (varlist &body body-decls)
+ (prog-expansion-from-let varlist body-decls 'let))
+ (defmacro-mundanely prog* (varlist &body body-decls)
+ (prog-expansion-from-let varlist body-decls 'let*)))
(defmacro-mundanely prog1 (result &body body)
(let ((n-result (gensym)))
@@ -305,7 +303,7 @@
;; environment. We spuriously reference the gratuitous variable,
;; since we don't want to use IGNORABLE on what might be a special
;; var.
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(let ((n-list (gensym)))
`(do* ((,n-list ,list (cdr ,n-list)))
((endp ,n-list)
Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -d -r1.65 -r1.66
--- early-extensions.lisp 18 Aug 2003 07:53:35 -0000 1.65
+++ early-extensions.lisp 26 Aug 2003 13:21:18 -0000 1.66
@@ -370,7 +370,7 @@
;;; Iterate over the entries in a HASH-TABLE.
(defmacro dohash ((key-var value-var table &optional result) &body body)
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(let ((gen (gensym))
(n-more (gensym)))
`(with-hash-table-iterator (,gen ,table)
Index: eval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/eval.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- eval.lisp 20 Aug 2003 18:55:22 -0000 1.23
+++ eval.lisp 26 Aug 2003 13:21:18 -0000 1.24
@@ -47,7 +47,8 @@
(return (eval-in-lexenv (first i) lexenv)))))
(defun eval-locally (exp lexenv &optional vars)
- (multiple-value-bind (body decls) (parse-body (rest exp) nil)
+ (multiple-value-bind (body decls)
+ (parse-body (rest exp) :doc-string-allowed nil)
(let ((lexenv
;; KLUDGE: Uh, yeah. I'm not anticipating
;; winning any prizes for this code, which was
Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/macros.lisp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -d -r1.35 -r1.36
--- macros.lisp 27 Jul 2003 13:52:36 -0000 1.35
+++ macros.lisp 26 Aug 2003 13:21:18 -0000 1.36
@@ -319,7 +319,8 @@
;;;; WITH-FOO i/o-related macros
(defmacro-mundanely with-open-stream ((var stream) &body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
(let ((abortp (gensym)))
`(let ((,var ,stream)
(,abortp t))
@@ -338,7 +339,8 @@
(defmacro-mundanely with-input-from-string ((var string &key index start end)
&body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
;; The ONCE-ONLY inhibits compiler note for unreachable code when
;; END is true.
(once-only ((string string))
@@ -366,7 +368,8 @@
(defmacro-mundanely with-output-to-string
((var &optional string &key (element-type ''character))
&body forms-decls)
- (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (multiple-value-bind (forms decls)
+ (parse-body forms-decls :doc-string-allowed nil)
(if string
`(let ((,var (make-fill-pointer-output-stream ,string)))
,@decls
Index: package.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/package.lisp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- package.lisp 16 Jul 2003 08:26:00 -0000 1.14
+++ package.lisp 26 Aug 2003 13:21:18 -0000 1.15
@@ -111,7 +111,8 @@
"DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
Executes the FORMs at least once for each symbol accessible in the given
PACKAGE with VAR bound to the current symbol."
- (multiple-value-bind (body decls) (parse-body body-decls nil)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
(let ((flet-name (gensym "DO-SYMBOLS-")))
`(block nil
(flet ((,flet-name (,var)
@@ -146,7 +147,8 @@
"DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
Executes the FORMs once for each external symbol in the given PACKAGE with
VAR bound to the current symbol."
- (multiple-value-bind (body decls) (parse-body body-decls nil)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
(let ((flet-name (gensym "DO-SYMBOLS-")))
`(block nil
(flet ((,flet-name (,var)
@@ -171,7 +173,8 @@
"DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
Executes the FORMs once for each symbol in every package with VAR bound
to the current symbol."
- (multiple-value-bind (body decls) (parse-body body-decls nil)
+ (multiple-value-bind (body decls)
+ (parse-body body-decls :doc-string-allowed nil)
(let ((flet-name (gensym "DO-SYMBOLS-")))
`(block nil
(flet ((,flet-name (,var)
Index: parse-body.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/parse-body.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- parse-body.lisp 19 Jun 2003 01:20:14 -0000 1.5
+++ parse-body.lisp 26 Aug 2003 13:21:18 -0000 1.6
@@ -26,53 +26,55 @@
;;;
;;; If DOC-STRING-ALLOWED is NIL, then no forms will be treated as
;;; documentation strings.
-(defun parse-body (body &optional (doc-string-allowed t))
+(defun parse-body (body &key (doc-string-allowed t) (toplevel nil))
(let ((reversed-decls nil)
(forms body)
(doc nil))
- ;; Since we don't have macros like AND, OR, and NOT yet, it's
- ;; hard to express these tests clearly. Giving them names
- ;; seems to help a little bit.
+ ;; Since we don't have macros like AND, OR, and NOT yet, it's hard
+ ;; to express these tests clearly. Giving them names seems to help
+ ;; a little bit.
(flet ((doc-string-p (x remaining-forms)
(if (stringp x)
- (if doc-string-allowed
- ;; ANSI 3.4.11 explicitly requires that a doc
- ;; string be followed by another form (either an
- ;; ordinary form or a declaration). Hence:
- (if remaining-forms
- (if doc
- ;; ANSI 3.4.11 says that the consequences of
- ;; duplicate doc strings are unspecified.
- ;; That's probably not something the
- ;; programmer intends. We raise an error so
- ;; that this won't pass unnoticed.
- (error "duplicate doc string ~S" x)
- t)))))
+ (if doc-string-allowed
+ ;; ANSI 3.4.11 explicitly requires that a doc
+ ;; string be followed by another form (either an
+ ;; ordinary form or a declaration). Hence:
+ (if remaining-forms
+ (if doc
+ ;; ANSI 3.4.11 says that the consequences of
+ ;; duplicate doc strings are unspecified.
+ ;; That's probably not something the
+ ;; programmer intends. We raise an error so
+ ;; that this won't pass unnoticed.
+ (error "duplicate doc string ~S" x)
+ t)))))
(declaration-p (x)
(if (consp x)
(let ((name (car x)))
- (if (eq name 'declaim)
- ;; technically legal, but rather unlikely to
- ;; be what the user intended...
- (progn
- (style-warn
- "DECLAIM where DECLARE was probably intended")
- nil)
- (eq name 'declare))))))
+ (case name
+ ((declare) t)
+ ((declaim)
+ (unless toplevel
+ ;; technically legal, but rather unlikely to
+ ;; be what the user meant to do...
+ (style-warn
+ "DECLAIM where DECLARE was probably intended")
+ nil))
+ (t nil))))))
(tagbody
:again
(if forms
- (let ((form1 (first forms)))
- ;; Note: The (IF (IF ..) ..) stuff is because we don't
- ;; have the macro AND yet.:-|
- (if (doc-string-p form1 (rest forms))
- (setq doc form1)
- (if (declaration-p form1)
- (setq reversed-decls
- (cons form1 reversed-decls))
- (go :done)))
- (setq forms (rest forms))
- (go :again)))
+ (let ((form1 (first forms)))
+ ;; Note: The (IF (IF ..) ..) stuff is because we don't
+ ;; have the macro AND yet.:-|
+ (if (doc-string-p form1 (rest forms))
+ (setq doc form1)
+ (if (declaration-p form1)
+ (setq reversed-decls
+ (cons form1 reversed-decls))
+ (go :done)))
+ (setq forms (rest forms))
+ (go :again)))
:done)
(values forms
(nreverse reversed-decls)
Index: parse-defmacro.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/parse-defmacro.lisp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- parse-defmacro.lisp 11 Jun 2003 05:53:59 -0000 1.17
+++ parse-defmacro.lisp 26 Aug 2003 13:21:18 -0000 1.18
@@ -28,7 +28,7 @@
(defvar *ignorable-vars*)
(declaim (type list *ignorable-vars*))
-;;; Return, as multiple values, a body, possibly a declare form to put
+;;; Return, as multiple values, a body, possibly a DECLARE form to put
;;; where this code is inserted, the documentation for the parsed
;;; body, and bounds on the number of arguments.
(defun parse-defmacro (lambda-list arg-list-name body name error-kind
@@ -40,7 +40,7 @@
(error-fun 'error)
(wrap-block t))
(multiple-value-bind (forms declarations documentation)
- (parse-body body doc-string-allowed)
+ (parse-body body :doc-string-allowed doc-string-allowed)
(let ((*arg-tests* ())
(*user-lets* ())
(*system-lets* ())
Index: primordial-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/primordial-extensions.lisp,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -d -r1.28 -r1.29
--- primordial-extensions.lisp 16 Jul 2003 08:26:01 -0000 1.28
+++ primordial-extensions.lisp 26 Aug 2003 13:21:18 -0000 1.29
@@ -98,7 +98,8 @@
(t (illegal-varlist)))))
(t (illegal-varlist)))))
;; Construct the new form.
- (multiple-value-bind (code decls) (parse-body decls-and-code nil)
+ (multiple-value-bind (code decls)
+ (parse-body decls-and-code :doc-string-allowed nil)
`(block ,block
(,bind ,(nreverse r-inits)
,@decls
Index: seq.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/seq.lisp,v
retrieving revision 1.51
retrieving revision 1.52
diff -u -d -r1.51 -r1.52
--- seq.lisp 16 Jul 2003 08:26:01 -0000 1.51
+++ seq.lisp 26 Aug 2003 13:21:18 -0000 1.52
@@ -77,7 +77,7 @@
(sb!xc:defmacro define-sequence-traverser (name args &body body)
(multiple-value-bind (body declarations docstring)
- (parse-body body t)
+ (parse-body body :doc-string-allowed t)
(collect ((new-args) (new-declarations) (adjustments))
(dolist (arg args)
(case arg
Index: typedefs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/typedefs.lisp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- typedefs.lisp 26 May 2003 04:25:54 -0000 1.17
+++ typedefs.lisp 26 Aug 2003 13:21:18 -0000 1.18
@@ -43,7 +43,8 @@
(if (eq '&whole (car arglist))
(values (cadr arglist) (cddr arglist))
(values (gensym) arglist))
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls)
+ (parse-body body :doc-string-allowed nil)
`(progn
(!cold-init-forms
(setf (info :type :translator ',name)
|