home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #18 / NN_1992_18.iso / spool / comp / lang / lisp / mcl / 1268 < prev    next >
Encoding:
Text File  |  1992-08-18  |  3.5 KB  |  97 lines
  1. Path: sparky!uunet!cis.ohio-state.edu!zaphod.mps.ohio-state.edu!sdd.hp.com!elroy.jpl.nasa.gov!ames!data.nas.nasa.gov!taligent!apple!cambridge.apple.com!bill@cambridge.apple.com
  2. From: bill@cambridge.apple.com (Bill St. Clair)
  3. Newsgroups: comp.lang.lisp.mcl
  4. Subject: Re: MOP in MCL 2.0
  5. Message-ID: <9208181556.AA03584@cambridge.apple.com>
  6. Date: 18 Aug 92 16:59:12 GMT
  7. Sender: info-mcl-request@cambridge.apple.com
  8. Lines: 83
  9. Approved: comp.lang.lisp.mcl@Cambridge.Apple.C0M
  10. Full-Name: Bill St. Clair
  11. Original-To: george@hsvaic.boeing.com (George Williams)
  12. Original-Cc: info-mcl
  13.  
  14. >On Aug 17,  4:30pm, Bill St. Clair wrote:
  15. >> I already have a cheap implementation that slows down all SLOT-VALUE
  16. >> calls and isn't called by DEFCLASS generated accessor functions. Ask and
  17. >> I'll send it (or post it if demand is great).
  18. >
  19. >Please post it, or send me a copy.
  20.  
  21. It's short, so I've included it here. It's also available for anonymous
  22. FTP from cambridge.apple.com in the file:
  23.  
  24. /pub/mcl2/contrib/slot-value-using-class.lisp
  25.  
  26. I figured out how to make it work for DEFCLASS generated accessors as
  27. well. The only price you pay is in speed.
  28.  
  29. -----------------------------------------------------------------------
  30.  
  31. ; slot-value-using-class.lisp
  32. ;
  33. ; Slow and simple implementation of SLOT-VALUE-USING-CLASS and friends
  34. ; for MCL 2.0.
  35. ; This slows down all calls to SLOT-VALUE & friends and disables all
  36. ; optimization for DEFCLASS generated accessors.
  37.  
  38. (in-package :ccl)
  39.  
  40. (export '(slot-value-using-class slot-boundp-using-class 
  41.           slot-exists-p-using-class slot-makunbound-using-class))
  42.  
  43. (eval-when (:compile-toplevel :execute)
  44.   (require "LISPEQU")                   ; for population-data
  45.   )
  46.  
  47. (defvar *slot-value-using-class-inited* nil)
  48.  
  49. (unless *slot-value-using-class-inited*
  50.   (setf (symbol-function 'std-slot-value) #'slot-value
  51.         (symbol-function 'std-set-slot-value) #'set-slot-value
  52.         (symbol-function 'std-slot-boundp) #'slot-boundp
  53.         (symbol-function 'std-slot-exists-p) #'slot-exists-p
  54.         (symbol-function 'std-slot-makunbound) #'slot-makunbound)
  55.   ; This turns off optimization for DEFCLASS generated accessors
  56.   (setq *standard-reader-method-class* nil
  57.         *standard-writer-method-class* nil)
  58.   (dolist (gf (population-data %all-gfs%))
  59.     ; unoptimize existing accessors
  60.     (compute-dcode gf))
  61.   (setq *slot-value-using-class-inited* t))
  62.  
  63. (defmethod slot-value-using-class ((class t) instance slot-name)
  64.   (std-slot-value instance slot-name))
  65.  
  66. (defmethod (setf slot-value-using-class) (value (class t) instance slot-name)
  67.   (std-set-slot-value instance slot-name value))
  68.  
  69. (defmethod slot-boundp-using-class ((class t) instance slot-name)
  70.   (std-slot-boundp instance slot-name))
  71.  
  72. (defmethod slot-exists-p-using-class ((class t) instance slot-name)
  73.   (std-slot-exists-p instance slot-name))
  74.  
  75. (defmethod slot-makunbound-using-class ((class t) instance slot-name)
  76.   (std-slot-makunbound instance slot-name))
  77.  
  78. (let ((*warn-if-redefine* nil)
  79.       (*warn-if-redefine-kernel* nil))
  80.  
  81. (defun slot-value (instance slot-name)
  82.   (slot-value-using-class (class-of instance) instance slot-name))
  83.  
  84. (defun set-slot-value (instance slot-name value)
  85.   (setf (slot-value-using-class (class-of instance) instance slot-name)
  86.         value))
  87.  
  88. (defun slot-boundp (instance slot-name)
  89.   (slot-boundp-using-class (class-of instance) instance slot-name))
  90.  
  91. (defun slot-exists-p (instance slot-name)
  92.   (slot-exists-p-using-class (class-of instance) instance slot-name))
  93.  
  94. (defun slot-makunbound (instance slot-name)
  95.   (slot-makunbound-using-class (class-of instance) instance slot-name))
  96. )
  97.