Skip to content
Snippets Groups Projects
Commit 702172bf authored by pmai's avatar pmai
Browse files

Slightly frobbed patch from Gerd Moellmann that eliminates the function

EXTRACT-DECLARATIONS in favour of SYSTEM:PARSE-BODY.  This also removes
the ability for macros to expand into declarations, which isn't allowed
anymore by ANSI CL.
parent 17f64034
No related branches found
No related tags found
No related merge requests found
......@@ -26,7 +26,7 @@
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.28 2002/08/26 02:23:10 pmai Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.29 2002/08/26 16:09:33 pmai Exp $")
(in-package :pcl)
......@@ -421,8 +421,8 @@ work during bootstrapping.
(multiple-value-bind (parameters unspecialized-lambda-list specializers)
(parse-specialized-lambda-list lambda-list)
(declare (ignore parameters))
(multiple-value-bind (documentation declarations real-body)
(extract-declarations body env)
(multiple-value-bind (real-body declarations documentation)
(system:parse-body body env)
(values `(lambda ,unspecialized-lambda-list
,@(when documentation `(,documentation))
(declare (method-name ,(list name qualifiers specializers)))
......@@ -451,8 +451,8 @@ work during bootstrapping.
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
(error "The method-lambda argument to make-method-lambda, ~S,~
is not a lambda form" method-lambda))
(multiple-value-bind (documentation declarations real-body)
(extract-declarations (cddr method-lambda) env)
(multiple-value-bind (real-body declarations documentation)
(system:parse-body (cddr method-lambda) env)
(let* ((name-decl (get-declaration 'method-name declarations))
(sll-decl (get-declaration 'method-lambda-list declarations))
(method-name (when (consp name-decl) (car name-decl)))
......@@ -515,9 +515,10 @@ work during bootstrapping.
next-method-p-p)
(walk-method-lambda method-lambda required-parameters env
slots calls)
(multiple-value-bind (ignore walked-declarations walked-lambda-body)
(extract-declarations (cddr walked-lambda))
(declare (ignore ignore))
(multiple-value-bind (walked-lambda-body walked-declarations
walked-documentation)
(system:parse-body (cddr walked-lambda) env)
(declare (ignore walked-documentation))
(when (or next-method-p-p call-next-method-p)
(setq plist (list* :needs-next-methods-p t plist)))
(when (some #'cdr slots)
......@@ -1012,10 +1013,11 @@ work during bootstrapping.
method-name
specializers)
(flet ((ignoredp (symbol)
(dolist (decl (cdar declarations))
(when (and (eq (car decl) 'ignore)
(memq symbol (cdr decl)))
(return t)))))
(dolist (form declarations)
(dolist (decl (cdr form))
(when (and (eq (car decl) 'ignore)
(memq symbol (cdr decl)))
(return-from ignoredp t))))))
(loop for s in specialized-lambda-list
and p in required-parameters
when (listp s)
......
......@@ -26,7 +26,7 @@
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.14 2002/08/26 02:23:12 pmai Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defcombin.lisp,v 1.15 2002/08/26 16:09:34 pmai Exp $")
;;;
(in-package :pcl)
......@@ -287,8 +287,9 @@
(type ll method-group-specifiers arguments-option gf-var body)
;;(declare (values documentation function))
(declare (ignore type))
(multiple-value-bind (documentation declarations real-body)
(extract-declarations body)
(multiple-value-bind (real-body declarations documentation)
;; Note that PARSE-BODY ignores its second arg ENVIRONMENT.
(system:parse-body body nil)
(let ((wrapped-body
(wrap-method-group-specifier-bindings method-group-specifiers
......
......@@ -26,7 +26,7 @@
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.18 2002/08/26 02:23:14 pmai Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/macros.lisp,v 1.19 2002/08/26 16:09:34 pmai Exp $")
;;;
;;; Macros global variable definitions, and other random support stuff used
;;; by the rest of the system.
......@@ -98,36 +98,6 @@
(defun remtail (list tail)
(if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))
(eval-when (compile load eval)
(defun extract-declarations (body &optional environment)
;;(declare (values documentation declarations body))
(let (documentation declarations form)
(when (and (stringp (car body))
(cdr body))
(setq documentation (pop body)))
(block outer
(loop
(when (null body) (return-from outer nil))
(setq form (car body))
(when (block inner
(loop (cond ((not (listp form))
(return-from outer nil))
((eq (car form) 'declare)
(return-from inner t))
(t
(multiple-value-bind (newform macrop)
(macroexpand-1 form environment)
(if (or (not (eq newform form)) macrop)
(setq form newform)
(return-from outer nil)))))))
(pop body)
(dolist (declaration (cdr form))
(push declaration declarations)))))
(values documentation
(and declarations `((declare ,.(nreverse declarations))))
body)))
)
(defun get-declaration (name declarations &optional default)
(dolist (d declarations default)
(dolist (form (cdr d))
......@@ -167,8 +137,8 @@
(car ,alist)))))
(defmacro doplist ((key val) plist &body body &environment env)
(multiple-value-bind (doc decls bod)
(extract-declarations body env)
(multiple-value-bind (bod decls doc)
(system:parse-body body env)
(declare (ignore doc))
`(let ((.plist-tail. ,plist) ,key ,val)
,@decls
......
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