[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
PCL enhancement for Genera (7.x: x>2)
- To: commonloops.pa@Xerox.COM
- Subject: PCL enhancement for Genera (7.x: x>2)
- From: Mike Thome <mthome@BBN.COM>
- Date: Fri, 09 Feb 90 17:25:06 -0500
- Redistributed: commonloops.pa
Below is a patch for PCL which teaches Genera 7.2 (&7.4) to
understand pcl-method function specs of the form
`(METHOD ,gf-name ,@method-qualifiers (,@method-specializers))
and PCL (2/8/90 Beta 2) to use 'em.
These mods may be used in a base compile to get rid of all those ugly
gensymed top-level-form symbols in warnings, and (as a side effect)
makes M-. and who-calls work nicely.
Enjoy!
-mik (mthome@bbn.com, mthome@thalamus.bu.edu)
. . . . . . . . . . . . . . . . . . . . . . . .
;;; -*- Package: PCL -*-
;;; This set of mods alters the behavior of defmethod so that it works
;;; correctly with the symbolics debugging & loading systems.
;;;
;;; Based on Beta2 2/8/90 PCL
;;;
;;; Notes:
;;; 1. we no longer need to rely on the TOP-LEVEL hack.
;;; 2. defmethods expand into DEFUNs (which get thier bodies compiled... even on
;;; smbx!) and we rely on the fspec mechanism to do the load-defmethod.
;;; 3. This is a (working) second cut, so the code is pretty ugly, and only
;;; minimally modifies original code (leaving various warnings, etc).
;;; 4. See code for more details
;;;
;;; -mike thome (mthome@bbn.com): 6 Feb 90
;;;
;; New (& complete) fspec handler.
;; 1. uses a single #'equal htable where stored elements are (fn . plist)
;; (maybe we should store the method object instead)
;; 2. also implements the fspec-plist operators here.
;; 3. fdefine not only stores the method, but actually does the loading here!
;;
;;;
;;; genera-low.lisp (replaces old method-function-spec-handler)
;;;
;; New (& complete) fspec handler.
;; 1. uses a single #'equal htable where stored elements are (fn . plist)
;; (maybe we should store the method object instead)
;; 2. also implements the fspec-plist operators here.
;; 3. fdefine not only stores the method, but actually does the loading here!
;;
(defvar *method-htable* (make-hash-table :test #'equal :size 500))
(si:define-function-spec-handler method (op spec &optional arg1 arg2)
(if (eq op 'sys:validate-function-spec)
(and (let ((gspec (cadr spec)))
(or (symbolp gspec)
(and (listp gspec)
(eq (car gspec) 'setf)
(symbolp (cadr gspec))
(null (cddr gspec)))))
(let ((tail (cddr spec)))
(loop (cond ((null tail) (return nil))
((listp (car tail)) (return t))
((atom (pop tail)))
(t (return nil))))))
(let ((table *method-htable*)
(key spec))
(case op
((si:fdefinedp si:fdefinition)
(car (gethash key table nil)))
(si:fundefine
(remhash key table))
(si:fdefine
(let ((old (gethash key table nil))
(gspec (cadr spec))
(quals nil)
(specs nil)
(ptr (cddr spec)))
(setq specs
(loop (cond ((null ptr) (return nil))
((listp (car ptr)) (return (car ptr)))
(t (push (pop ptr) quals)))))
(pcl-fdefine-helper gspec (nreverse quals) specs arg1)
(setf (gethash key table) (cons arg1 (cdr old)))))
(si:get
(let ((old (gethash key table nil)))
(getf (cdr old) arg1)))
(si:plist
(let ((old (gethash key table nil)))
(cdr old)))
(si:putprop
(let ((old (gethash key table nil)))
(unless old
(setf old (cons nil nil))
(setf (gethash key table) old))
(setf (getf (cdr old) arg2) arg1)))
(si:remprop
(let ((old (gethash key table nil)))
(when old
(remf (cdr old) arg1))))
(otherwise
(si:function-spec-default-handler op spec arg1 arg2))))))
;; this guy is just a stub to make the fspec handler simpler (and so I could trace it
;; easier).
(defun pcl-fdefine-helper (gspec qualifiers specializers fn)
(let* ((dlist (scl:debugging-info fn))
(class (cadr (assoc 'pcl-method-class dlist)))
(doc (cadr (assoc 'pcl-documentation dlist)))
(plist (cadr (assoc 'pcl-plist dlist))))
(load-defmethod
(or class 'standard-method)
gspec
qualifiers
specializers
(arglist fn)
doc
(getf plist :isl-cache-symbol)
plist
fn)))
;; define a few special declarations to get pushed onto the function's debug-info
;; list... note that we do not need to do a (proclaim (declarations ...)) here.
;;
(eval-when (compile load eval)
(setf (get 'pcl-plist 'si:debug-info) t)
(setf (get 'pcl-documentation 'si:debug-info) t)
(setf (get 'pcl-method-class 'si:debug-info) t)
(setf (get 'pcl-lambda-list 'si:debug-info) t)
)
;;;
;;; boot.lisp (expand-defmethod for genera *only*, and addition to
;;; expand-defmethod-internal)
;;;
#+Genera
(defun expand-defmethod (proto-method name qualifiers lambda-list body env)
(when (listp name) (do-standard-defsetf-1 (cadr name)))
(multiple-value-bind (fn-form specializers doc plist)
(expand-defmethod-internal name qualifiers lambda-list body env)
(declare (ignore doc plist))
(let ((fn-args (cadadr fn-form))
(fn-body (cddadr fn-form)))
`(defun (method ,name ,@qualifiers ,specializers) ,fn-args
(declare ,@(when proto-method
`((pcl-method-class
,(class-name (class-of proto-method)))))
(pcl-lambda-list
,(specialized-lambda-list-lambda-list lambda-list)))
,@fn-body))))
;; this is also modified (mt)
(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)))
(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))))))))
;;;;;;;
;;;;;;;