[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Spurious warning about ignored variables fixed.
- To: CommonLoops.pa@Xerox.COM
- Subject: Spurious warning about ignored variables fixed.
- From: Richard Lamson <rsl@max-fleischer.ila-sf.dialnet.symbolics.com>
- Date: Wed, 6 Jun 90 13:29 PDT
- Cc: rsl@max-fleischer.ila-sf.dialnet.symbolics.com, York@max-fleischer.ila-sf.dialnet.symbolics.com
- Character-type-mappings: (1 0 (NIL 0) (NIL NIL :TINY) "TINY")
- Fonts: CPTFONT, TINY
- Line-fold: No
- Redistributed: CommonLoops.pa
1In Symbolics 3620 PCL in Genera 7.2, System 376.166, Experimental Logical Pathnames Translation Files NEWEST, Utilities 27.31, Server Utilities 28.5,
Hardcopy 118.17, Zmail 165.23, LMFS 102.8, Tape 82.19, Nsage 27.246, Extended Help 18.4, Documentation Database 62.1, Mailer 17.1, Print Spooler 16.1,
Domain Name Server 17.1, Experimental ILA-SF-Site-System 1.24, Experimental ILA-SF-Site-Server-System 3.25, microcode 3620-FPA-MIC 420, FEP 208,
fep0:>g208-lisp.flod(4), fep0:>g208-loaders.flod(4), fep0:>g208-debug.flod(2), fep0:>g208-info.flod(4), Machine serial number 20194,
PCL version: 5/1/90 May Day PCL (REV 2) (from PCL:MAY-DAY-PCL;DEFSYS)
on Symbolics 3620 #20194 (Max Fleischer):
0Here is a patch which fixes the following problem: If you have a method
which IGNOREs one of its required (unclassed) arguments, which also uses
SLOT-VALUE on a constant slot-name, the method body gets rewritten in such
a way that the variable is used, but the IGNORE declaration is not removed,
so you get warned that you have used a variable you never reference
textually in your program. The fix is to remove the IGNORE declaration for
a variable you know you will use (all required arguments to such a method).
The change is the form between the ";;; ===..." lines below.
(defun expand-defmethod-internal
(generic-function-name qualifiers specialized-lambda-list body env)
(declare (values fn-form specializers doc)
(ignore qualifiers))
(when (listp generic-function-name)
(do-standard-defsetf-1 (cadr generic-function-name)))
(multiple-value-bind (documentation declarations real-body)
(extract-declarations body)
(multiple-value-bind (parameters lambda-list specializers)
(parse-specialized-lambda-list specialized-lambda-list)
(let* ((required-parameters
(mapcar #'(lambda (r s) (declare (ignore s)) r)
parameters
specializers))
(parameters-to-reference
(make-parameter-references specialized-lambda-list
required-parameters
declarations
generic-function-name
specializers))
(class-declarations
`(declare
,@(remove nil
(mapcar #'(lambda (a s) (and (symbolp s)
(neq s 't)
`(class ,a ,s)))
parameters
specializers))))
(method-lambda
;; Remove the documentation string and insert the
;; appropriate class declarations. The documentation
;; string is removed to make it easy for us to insert
;; new declarations later, they will just go after the
;; cadr of the method lambda. The class declarations
;; are inserted to communicate the class of the method's
;; arguments to the code walk.
(let ()
`(lambda ,lambda-list
,class-declarations
,@declarations
(progn ,@parameters-to-reference)
(block ,(if (listp generic-function-name)
(cadr generic-function-name)
generic-function-name)
,@real-body))))
(call-next-method-p nil) ;flag indicating that call-next-method
;should be in the method definition
(next-method-p-p nil) ;flag indicating that next-method-p
;should be in the method definition
(save-original-args nil) ;flag indicating whether or not the
;original arguments to the method
;must be preserved. This happens
;for two reasons:
; - the method takes &mumble args,
; so one of the lexical functions
; might be used in a default value
; form
; - call-next-method is used without
; arguments at least once in the
; body of the method
(original-args ())
(applyp nil) ;flag indicating whether or not the
;method takes &mumble arguments. If
;it does, it means call-next-method
;without arguments must be APPLY'd
;to original-args. If this gets set
;true, save-original-args is set so
;as well
(aux-bindings ()) ;Suffice to say that &aux is one of
;damndest things to have put in a
;language.
(slots (mapcar #'list required-parameters))
(plist ())
(walked-lambda nil))
(flet ((walk-function (form context env)
(cond ((not (eq context ':eval)) form)
((not (listp form)) form)
((eq (car form) 'call-next-method)
(setq call-next-method-p 't)
(setq save-original-args (not (cdr form)))
form)
((eq (car form) 'next-method-p)
(setq next-method-p-p 't)
form)
((and (eq (car form) 'function)
(cond ((eq (cadr form) 'call-next-method)
(setq call-next-method-p 't)
(setq save-original-args 't)
form)
((eq (cadr form) 'next-method-p)
(setq next-method-p-p 't)
form)
(t nil))))
((and (or (eq (car form) 'slot-value)
(eq (car form) 'set-slot-value))
(symbolp (cadr form))
(constantp (caddr form)))
(let ((parameter
(can-optimize-access (cadr form) required-parameters env)))
(if (null parameter)
form
(ecase (car form)
(slot-value
(optimize-slot-value slots parameter form))
(set-slot-value
(optimize-set-slot-value slots parameter form))))))
(t form))))
(setq walked-lambda (walk-form method-lambda env #'walk-function))
;;
;; Add &allow-other-keys to the lambda list as an interim
;; way of implementing lambda list congruence rules.
;;
(when (and (memq '&key lambda-list)
(not (memq '&allow-other-keys lambda-list)))
(let* ((rll (reverse lambda-list))
(aux (memq '&aux rll)))
(setq lambda-list
(if aux
(progn (setf (cdr aux)
(cons '&allow-other-keys (cdr aux)))
(nreverse rll))
(nconc (nreverse rll) (list '&allow-other-keys))))))
;; Scan the lambda list to determine whether this method
;; takes &mumble arguments. If it does, we set applyp and
;; save-original-args true.
;;
;; This is also the place where we construct the original
;; arguments lambda list if there has to be one.
(dolist (p lambda-list)
(if (memq p lambda-list-keywords)
(if (eq p '&aux)
(progn
(setq aux-bindings (cdr (memq '&aux lambda-list)))
(return nil))
(progn
(setq applyp t
save-original-args t)
(push '&rest original-args)
(push (make-symbol "AMPERSAND-ARGS") original-args)
(return nil)))
(push (make-symbol (symbol-name p)) original-args)))
(setq original-args (if save-original-args
(nreverse original-args)
()))
(multiple-value-bind (ignore walked-declarations walked-lambda-body)
(extract-declarations (cddr walked-lambda))
(declare (ignore ignore))
(when (some #'cdr slots)
(setq slots (slot-name-lists-from-slots slots))
(setq plist (list* :isl slots plist))
(setq walked-lambda-body (add-pv-binding walked-lambda-body
plist
required-parameters))
;;; =================================================================
(dolist (dcl-stm walked-declarations)
(dolist (dcl (cdr dcl-stm))
(when (eql (car dcl) 'ignore)
(setf (cdr dcl) (set-difference (cdr dcl) required-parameters)))))
;;; =================================================================
)
(when (or next-method-p-p call-next-method-p)
(setq plist (list* :needs-next-methods-p 't plist)))
;;; changes are here... (mt)
(let ((fn-body (if (or call-next-method-p next-method-p-p)
(add-lexical-functions-to-method-lambda
walked-declarations
walked-lambda-body
`(lambda ,lambda-list
,@walked-declarations
,.walked-lambda-body)
original-args
lambda-list
save-original-args
applyp
aux-bindings
call-next-method-p
next-method-p-p)
`(lambda ,lambda-list
,@walked-declarations
,.walked-lambda-body))))
#+Genera
(setq fn-body `(lambda ,(cadr fn-body)
(declare (pcl-documentation ,documentation)
(pcl-plist ,plist))
,@(cddr fn-body)))
(values
`(function ,fn-body)
specializers
documentation
plist))))))))