From 24bc431a3403af05c5df601d09c0d0c27cb500b2 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sat, 31 Aug 2002 01:19:50 +0000 Subject: [PATCH] 0.7.7.4: ported pmai's version of Gerd Moellman's "Remove PCL::EXTRACT-DECLARATIONS" patch (gm cmucl-imp 2002-08-24, pmai cvs diff -D '2002-08-26 16:00 UTC' -D '2002-08-26 16:20 UTC'), to make PCL use the same PARSE-BODY as the rest of the system, instead of reimplementing the wheel. and actually we don't even need PARSE-BODY in DOPLIST as it is currently used, nor ENV either and why the heck is PARSE-BODY in SB!SYS? Move it to SB!INT. --- package-data-list.lisp-expr | 4 +-- src/code/parse-body.lisp | 2 +- src/compiler/ir1-translators.lisp | 12 ++++---- src/compiler/ir1tran.lisp | 2 +- src/compiler/main.lisp | 2 +- src/pcl/boot.lisp | 17 +++++------ src/pcl/defcombin.lisp | 6 ++-- src/pcl/init.lisp | 12 ++++---- src/pcl/macros.lisp | 56 ++++++------------------------------- src/pcl/vector.lisp | 4 +-- version.lisp-expr | 2 +- 11 files changed, 40 insertions(+), 79 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 87a3f64..d0861fc 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -832,6 +832,7 @@ retained, possibly temporariliy, because it might be used internally." "WHITESPACE-CHAR-P" "LISTEN-SKIP-WHITESPACE" "PACKAGE-INTERNAL-SYMBOL-COUNT" "PACKAGE-EXTERNAL-SYMBOL-COUNT" + "PARSE-BODY" "PROPER-LIST-OF-LENGTH-P" "LIST-OF-LENGTH-AT-LEAST-P" "LIST-WITH-LENGTH-P" @@ -1514,8 +1515,7 @@ SB-KERNEL) have been undone, but probably more remain." "NATURALIZE-BOOLEAN" "NATURALIZE-INTEGER" "OBJECT-SET-OPERATION" "OS-COLD-INIT-OR-REINIT" "OS-CONTEXT-T" "OUTPUT-RAW-BYTES" - "PARSE-BODY" "POINTER" - "POINTER<" "POINTER>" "PORT" + "POINTER" "POINTER<" "POINTER>" "PORT" "READ-N-BYTES" "REALLOCATE-SYSTEM-MEMORY" "RECORD-SIZE" "REMOVE-FD-HANDLER" "REMOVE-PORT-DEATH-HANDLER" "REMOVE-PORT-OBJECT" diff --git a/src/code/parse-body.lisp b/src/code/parse-body.lisp index c6926a9..8a1ed02 100644 --- a/src/code/parse-body.lisp +++ b/src/code/parse-body.lisp @@ -26,7 +26,7 @@ ;;; ;;; If DOC-STRING-ALLOWED is NIL, then no forms will be treated as ;;; documentation strings. -(defun sb!sys:parse-body (body &optional (doc-string-allowed t)) +(defun parse-body (body &optional (doc-string-allowed t)) (let ((reversed-decls nil) (forms body) (doc nil)) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 1c129bf..809d384 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -547,7 +547,7 @@ During evaluation of the Forms, bind the Vars to the result of evaluating the Value forms. The variables are bound in parallel after all of the Values are evaluated." - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body nil) (multiple-value-bind (vars values) (extract-let-vars bindings 'let) (let ((fun-cont (make-continuation))) (let* ((*lexenv* (process-decls decls vars nil cont)) @@ -563,7 +563,7 @@ "LET* ({(Var [Value]) | Var}*) Declaration* Form* Similar to LET, but the variables are bound sequentially, allowing each Value form to reference any of the previous Vars." - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body nil) (multiple-value-bind (vars values) (extract-let-vars bindings 'let*) (let ((*lexenv* (process-decls decls vars nil cont))) (ir1-convert-aux-bindings start cont forms vars values))))) @@ -577,7 +577,7 @@ ;;; forms before we hit the IR1 transform level. (defun ir1-translate-locally (body start cont) (declare (type list body) (type continuation start cont)) - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body nil) (let ((*lexenv* (process-decls decls nil nil cont))) (ir1-convert-aux-bindings start cont forms nil nil)))) @@ -608,7 +608,7 @@ (let ((name (first def))) (check-fun-name name) (names name) - (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def)) + (multiple-value-bind (forms decls) (parse-body (cddr def)) (defs `(lambda ,(second def) ,@decls (block ,(fun-name-block-name name) @@ -622,7 +622,7 @@ Evaluate the Body-Forms with some local function definitions. The bindings do not enclose the definitions; any use of Name in the Forms will refer to the lexically apparent function definition in the enclosing environment." - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body nil) (multiple-value-bind (names defs) (extract-flet-vars definitions 'flet) (let* ((fvars (mapcar (lambda (n d) @@ -642,7 +642,7 @@ Evaluate the Body-Forms with some local function definitions. The bindings enclose the new definitions, so the defined functions can call themselves or each other." - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body nil) (multiple-value-bind (names defs) (extract-flet-vars definitions 'labels) (let* (;; dummy LABELS functions, to be used as placeholders diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 7b53cb5..495ac5d 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1949,7 +1949,7 @@ (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) (make-lambda-vars (cadr form)) - (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr form)) + (multiple-value-bind (forms decls) (parse-body (cddr form)) (let* ((result-cont (make-continuation)) (*lexenv* (process-decls decls (append aux-vars vars) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 610990c..b01695d 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -801,7 +801,7 @@ ;;; We parse declarations and then recursively process the body. (defun process-toplevel-locally (body path compile-time-too) (declare (list path)) - (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) + (multiple-value-bind (forms decls) (parse-body body nil) (let* ((*lexenv* (process-decls decls nil nil (make-continuation))) ;; Binding *POLICY* is pretty much of a hack, since it diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index b9633df..3a61e87 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -466,8 +466,8 @@ 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) + (parse-body body env) (values `(lambda ,unspecialized-lambda-list ,@(when documentation `(,documentation)) ;; (Old PCL code used a somewhat different style of @@ -573,8 +573,8 @@ bootstrapping. (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) + (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))) @@ -661,10 +661,11 @@ bootstrapping. 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) + (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) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index f91b20f..0b2111e 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -231,10 +231,10 @@ (defun make-long-method-combination-function (type ll method-group-specifiers args-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.) + (parse-body body nil) (let ((wrapped-body (wrap-method-group-specifier-bindings method-group-specifiers diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index a1821ec..9614439 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -225,12 +225,12 @@ ;; Now check the supplied-initarg-names and the default initargs ;; against the total set that we know are legal. (doplist (key val) initargs - (unless (memq key legal) - (if error-p - (error "Invalid initialization argument ~S for class ~S" - key - (class-name class)) - (return-from check-initargs-2-plist nil))))) + (unless (memq key legal) + (if error-p + (error "Invalid initialization argument ~S for class ~S" + key + (class-name class)) + (return-from check-initargs-2-plist nil))))) t) (defun check-initargs-2-list (initkeys class legal &optional (error-p t)) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index e2fc870..b0c5f53 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -44,42 +44,6 @@ (/show "done with DECLAIM DECLARATION") -;;; FIXME: This looks like SBCL's PARSE-BODY, and should be shared. -(eval-when (:compile-toplevel :load-toplevel :execute) - -(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))) -) ; EVAL-WHEN - -(/show "done with EVAL-WHEN (..) DEFUN EXTRACT-DECLARATIONS") - (defun get-declaration (name declarations &optional default) (dolist (d declarations default) (dolist (form (cdr d)) @@ -88,18 +52,14 @@ (/show "pcl/macros.lisp 85") -(defmacro doplist ((key val) plist &body body &environment env) - (multiple-value-bind (doc decls bod) - (extract-declarations body env) - (declare (ignore doc)) - `(let ((.plist-tail. ,plist) ,key ,val) - ,@decls - (loop (when (null .plist-tail.) (return nil)) - (setq ,key (pop .plist-tail.)) - (when (null .plist-tail.) - (error "malformed plist, odd number of elements")) - (setq ,val (pop .plist-tail.)) - (progn ,@bod))))) +(defmacro doplist ((key val) plist &body body) + `(let ((.plist-tail. ,plist) ,key ,val) + (loop (when (null .plist-tail.) (return nil)) + (setq ,key (pop .plist-tail.)) + (when (null .plist-tail.) + (error "malformed plist, odd number of elements")) + (setq ,val (pop .plist-tail.)) + (progn ,@body)))) (/show "pcl/macros.lisp 101") diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 5154482..fdd43e6 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -1008,8 +1008,8 @@ ;;; Pull a name out of the %METHOD-NAME declaration in the function ;;; body given, or return NIL if no %METHOD-NAME declaration is found. (defun body-method-name (body) - (multiple-value-bind (documentation declarations real-body) - (extract-declarations body nil) + (multiple-value-bind (real-body declarations documentation) + (parse-body body nil) (declare (ignore documentation real-body)) (let ((name-decl (get-declaration '%method-name declarations))) (and name-decl diff --git a/version.lisp-expr b/version.lisp-expr index c38e5e3..d909a0b 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.7.3" +"0.7.7.4" -- 1.7.10.4